diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,18 @@ -# ChangeLog +# Changelog -## v1.0.0.0 +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.1.0/). + +## [Unreleased] + +### Added +### Changed +### Deprecated +### Removed +### Fixed +### Security + +## [v1.0.0.0] - 2023-10-30 First official release. diff --git a/orville-postgresql.cabal b/orville-postgresql.cabal --- a/orville-postgresql.cabal +++ b/orville-postgresql.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.2. +-- This file has been generated from package.yaml by hpack version 0.38.1. -- -- see: https://github.com/sol/hpack name: orville-postgresql -version: 1.0.0.0 +version: 1.1.0.0 synopsis: A Haskell library for PostgreSQL description: Orville's goal is to provide a powerful API for applications to access PostgreSQL databases with minimal use of sophisticated language techniques or extensions. See https://github.com/flipstone/orville for more details. category: database, library, postgresql @@ -15,7 +15,7 @@ license-file: LICENSE build-type: Simple tested-with: - GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.8, GHC == 9.4.7, GHC == 9.6.3 + GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.8, GHC == 9.4.8, GHC == 9.6.7, GHC == 9.8.4, GHC == 9.10.2, GHC == 9.12.2 extra-source-files: CHANGELOG.md @@ -32,6 +32,7 @@ exposed-modules: Orville.PostgreSQL Orville.PostgreSQL.AutoMigration + Orville.PostgreSQL.ErrorDetailLevel Orville.PostgreSQL.Execution Orville.PostgreSQL.Execution.Cursor Orville.PostgreSQL.Execution.Delete @@ -46,39 +47,61 @@ Orville.PostgreSQL.Execution.Sequence Orville.PostgreSQL.Execution.Transaction Orville.PostgreSQL.Execution.Update - Orville.PostgreSQL.ErrorDetailLevel Orville.PostgreSQL.Expr + Orville.PostgreSQL.Expr.Aggregate Orville.PostgreSQL.Expr.BinaryOperator Orville.PostgreSQL.Expr.ColumnDefinition + Orville.PostgreSQL.Expr.Comment + Orville.PostgreSQL.Expr.ConditionalExpr Orville.PostgreSQL.Expr.Count Orville.PostgreSQL.Expr.Cursor Orville.PostgreSQL.Expr.DataType Orville.PostgreSQL.Expr.Delete + Orville.PostgreSQL.Expr.Extension + Orville.PostgreSQL.Expr.FetchClause + Orville.PostgreSQL.Expr.Filter + Orville.PostgreSQL.Expr.Function Orville.PostgreSQL.Expr.GroupBy Orville.PostgreSQL.Expr.IfExists + Orville.PostgreSQL.Expr.IfNotExists Orville.PostgreSQL.Expr.Index Orville.PostgreSQL.Expr.Insert + Orville.PostgreSQL.Expr.Join Orville.PostgreSQL.Expr.LimitExpr Orville.PostgreSQL.Expr.Math Orville.PostgreSQL.Expr.Name Orville.PostgreSQL.Expr.OffsetExpr + Orville.PostgreSQL.Expr.OnConflict + Orville.PostgreSQL.Expr.OrReplace Orville.PostgreSQL.Expr.OrderBy Orville.PostgreSQL.Expr.Query Orville.PostgreSQL.Expr.ReturningExpr + Orville.PostgreSQL.Expr.RowLocking Orville.PostgreSQL.Expr.Select Orville.PostgreSQL.Expr.SequenceDefinition Orville.PostgreSQL.Expr.TableConstraint Orville.PostgreSQL.Expr.TableDefinition Orville.PostgreSQL.Expr.TableReferenceList + Orville.PostgreSQL.Expr.TextSearch Orville.PostgreSQL.Expr.Time Orville.PostgreSQL.Expr.Transaction + Orville.PostgreSQL.Expr.Trigger Orville.PostgreSQL.Expr.Update + Orville.PostgreSQL.Expr.Vacuum Orville.PostgreSQL.Expr.ValueExpression + Orville.PostgreSQL.Expr.Values Orville.PostgreSQL.Expr.WhereClause + Orville.PostgreSQL.Expr.Window + Orville.PostgreSQL.Expr.Window.WindowClause + Orville.PostgreSQL.Expr.Window.WindowDefinitionExpr + Orville.PostgreSQL.Expr.Window.WindowFunction + Orville.PostgreSQL.Extension.PgTrgm Orville.PostgreSQL.Marshall + Orville.PostgreSQL.Marshall.AliasName Orville.PostgreSQL.Marshall.DefaultValue Orville.PostgreSQL.Marshall.FieldDefinition Orville.PostgreSQL.Marshall.MarshallError + Orville.PostgreSQL.Marshall.SqlComparable Orville.PostgreSQL.Marshall.SqlMarshaller Orville.PostgreSQL.Marshall.SqlType Orville.PostgreSQL.Marshall.SyntheticField @@ -87,12 +110,12 @@ Orville.PostgreSQL.Monad.MonadOrville Orville.PostgreSQL.Monad.Orville Orville.PostgreSQL.OrvilleState + Orville.PostgreSQL.PgCatalog Orville.PostgreSQL.Plan Orville.PostgreSQL.Plan.Explanation Orville.PostgreSQL.Plan.Many Orville.PostgreSQL.Plan.Operation Orville.PostgreSQL.Plan.Syntax - Orville.PostgreSQL.PgCatalog Orville.PostgreSQL.Raw.Connection Orville.PostgreSQL.Raw.PgTextFormatValue Orville.PostgreSQL.Raw.PgTime @@ -101,17 +124,23 @@ Orville.PostgreSQL.Raw.SqlValue Orville.PostgreSQL.Schema Orville.PostgreSQL.Schema.ConstraintDefinition + Orville.PostgreSQL.Schema.ExtensionIdentifier + Orville.PostgreSQL.Schema.FunctionDefinition + Orville.PostgreSQL.Schema.FunctionIdentifier Orville.PostgreSQL.Schema.IndexDefinition Orville.PostgreSQL.Schema.PrimaryKey Orville.PostgreSQL.Schema.SequenceDefinition Orville.PostgreSQL.Schema.SequenceIdentifier Orville.PostgreSQL.Schema.TableDefinition Orville.PostgreSQL.Schema.TableIdentifier + Orville.PostgreSQL.Schema.TriggerDefinition Orville.PostgreSQL.UnliftIO other-modules: + Orville.PostgreSQL.Expr.Internal.Name.Alias Orville.PostgreSQL.Expr.Internal.Name.ColumnName Orville.PostgreSQL.Expr.Internal.Name.ConstraintName Orville.PostgreSQL.Expr.Internal.Name.CursorName + Orville.PostgreSQL.Expr.Internal.Name.ExtensionName Orville.PostgreSQL.Expr.Internal.Name.FunctionName Orville.PostgreSQL.Expr.Internal.Name.Identifier Orville.PostgreSQL.Expr.Internal.Name.IndexName @@ -120,6 +149,8 @@ Orville.PostgreSQL.Expr.Internal.Name.SchemaName Orville.PostgreSQL.Expr.Internal.Name.SequenceName Orville.PostgreSQL.Expr.Internal.Name.TableName + Orville.PostgreSQL.Expr.Internal.Name.TriggerName + Orville.PostgreSQL.Expr.Internal.Name.WindowName Orville.PostgreSQL.Internal.Bracket Orville.PostgreSQL.Internal.Extra.NonEmpty Orville.PostgreSQL.Internal.FieldName @@ -134,9 +165,13 @@ Orville.PostgreSQL.PgCatalog.PgAttributeDefault Orville.PostgreSQL.PgCatalog.PgClass Orville.PostgreSQL.PgCatalog.PgConstraint + Orville.PostgreSQL.PgCatalog.PgDescription + Orville.PostgreSQL.PgCatalog.PgExtension Orville.PostgreSQL.PgCatalog.PgIndex Orville.PostgreSQL.PgCatalog.PgNamespace + Orville.PostgreSQL.PgCatalog.PgProc Orville.PostgreSQL.PgCatalog.PgSequence + Orville.PostgreSQL.PgCatalog.PgTrigger Paths_orville_postgresql hs-source-dirs: src @@ -144,23 +179,27 @@ attoparsec >=0.10 && <0.15 , base >=4.8 && <5 , bytestring >=0.10 && <0.13 - , containers ==0.6.* + , containers >=0.6 && <0.9 , dlist >=0.8 && <1.1 , network-uri ==2.6.* - , postgresql-libpq >=0.9.4.2 && <0.11 + , postgresql-libpq >=0.9.4.2 && <0.12 , random >=1.0 && <2 - , resource-pool <0.3 || >=0.4 && <0.5 + , resource-pool <0.3 || >=0.4 && <0.6 , safe-exceptions >=0.1.7 && <0.2 , text >=1.2 && <1.3 || >=2.0 && <2.2 - , time >=1.9.1 && <1.13 + , time >=1.9.1 && <1.16 , transformers >=0.5 && <0.7 , unliftio-core >=0.1 && <0.3 , uuid >=1.3.15 && <1.4 default-language: Haskell2010 if flag(ci) - ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-uni-patterns -Wincomplete-patterns -Wincomplete-record-updates -Wmissing-local-signatures -Wmissing-export-lists -Wmissing-import-lists -Wnoncanonical-monad-instances -Wredundant-constraints -Wpartial-fields -Wmissed-specialisations -Wno-implicit-prelude -Wno-safe -Wno-unsafe - else - ghc-options: -Wall -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates + ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-uni-patterns -Wincomplete-patterns -Wincomplete-record-updates -Wmissing-local-signatures -Wmissing-export-lists -Wmissing-import-lists -Wmonomorphism-restriction -Wnoncanonical-monad-instances -Wpartial-fields -Wredundant-constraints -Wmissed-specialisations -Wno-implicit-prelude -Wno-safe -Wno-unsafe + if impl (ghc >= 9.2) + ghc-options: -Woperator-whitespace -Wredundant-bang-patterns + if impl (ghc >= 9.4) + ghc-options: -Wredundant-strictness-flags + if impl (ghc >= 9.8) + ghc-options: -Wterm-variable-capture test-suite spec type: exitcode-stdio-1.0 @@ -176,20 +215,29 @@ Test.Entities.User Test.EntityOperations Test.Execution + Test.Expr.Aggregate + Test.Expr.ConditionalExpr Test.Expr.Count Test.Expr.Cursor Test.Expr.GroupBy Test.Expr.GroupByOrderBy Test.Expr.InsertUpdateDelete + Test.Expr.Join Test.Expr.Math Test.Expr.OrderBy Test.Expr.SequenceDefinition Test.Expr.TableDefinition + Test.Expr.TableReferenceList Test.Expr.TestSchema + Test.Expr.TextSearch Test.Expr.Time + Test.Expr.Trigger + Test.Expr.Vacuum Test.Expr.Where + Test.Expr.Window Test.FieldDefinition Test.MarshallError + Test.Orphans Test.PgAssert Test.PgCatalog Test.PgGen @@ -215,17 +263,17 @@ attoparsec >=0.10 && <0.15 , base >=4.8 && <5 , bytestring >=0.10 && <0.13 - , containers ==0.6.* - , hedgehog >=1.0.5 && <1.5 + , containers >=0.6 && <0.9 + , hedgehog >=1.0.5 && <1.7 , orville-postgresql - , postgresql-libpq >=0.9.4.2 && <0.11 - , resource-pool <0.3 || >=0.4 && <0.5 + , postgresql-libpq >=0.9.4.2 && <0.12 + , resource-pool <0.3 || >=0.4 && <0.6 , safe-exceptions >=0.1.7 && <0.2 , text >=1.2 && <1.3 || >=2.0 && <2.2 - , time >=1.9.1 && <1.13 + , time >=1.9.1 && <1.16 + , transformers >=0.5 && <0.7 + , unliftio >=0.1 && <0.3 , uuid >=1.3.15 && <1.4 default-language: Haskell2010 if flag(ci) ghc-options: -j -Wall -Werror -Wcompat -Widentities -Wincomplete-uni-patterns -Wincomplete-record-updates -Wmissing-local-signatures -Wmissing-export-lists -Wno-implicit-prelude -Wno-safe -Wno-unsafe -Wnoncanonical-monad-instances -Wredundant-constraints -Wpartial-fields -Wmissed-specialisations -Woverflowed-literals - else - ghc-options: -Wall -Wcompat -Widentities -Wincomplete-uni-patterns -Wincomplete-record-updates -Wmissing-local-signatures -Wmissing-export-lists -Wno-implicit-prelude -Wno-safe -Wno-unsafe -Wnoncanonical-monad-instances -Wredundant-constraints -Wpartial-fields -Wmissed-specialisations -Woverflowed-literals diff --git a/src/Orville/PostgreSQL.hs b/src/Orville/PostgreSQL.hs --- a/src/Orville/PostgreSQL.hs +++ b/src/Orville/PostgreSQL.hs @@ -1,5 +1,5 @@ {- | -Copyright : Flipstone Technology Partners 2023 +Copyright : Flipstone Technology Partners 2023-2025 License : MIT Stability : Stable @@ -70,6 +70,10 @@ -- * Opening transactions and savepoints , Transaction.withTransaction + , Transaction.withTransactionInstruction + , Transaction.TransactionInstruction (Commit, Rollback) + , Transaction.inWithTransaction + , Transaction.InWithTransaction (InOutermostTransaction, InSavepointTransaction) -- * Types for incorporating Orville into other Monads , MonadOrville.MonadOrville @@ -97,10 +101,14 @@ , TableDefinition.mkTableDefinition , TableDefinition.mkTableDefinitionWithoutKey , TableDefinition.setTableSchema + , TableDefinition.setTableComment + , TableDefinition.tableComment , TableDefinition.tableConstraints , TableDefinition.addTableConstraints , TableDefinition.tableIndexes , TableDefinition.addTableIndexes + , TableDefinition.tableTriggers + , TableDefinition.addTableTriggers , TableDefinition.dropColumns , TableDefinition.columnsToDrop , TableDefinition.tableIdentifier @@ -144,6 +152,21 @@ , IndexDefinition.IndexCreationStrategy (Transactional, Concurrent) , IndexDefinition.setIndexCreationStrategy , IndexDefinition.indexCreationStrategy + , IndexDefinition.IndexMigrationKey (AttributeBasedIndexKey, NamedIndexKey) + , IndexDefinition.AttributeBasedIndexMigrationKey (AttributeBasedIndexMigrationKey, indexKeyUniqueness, indexKeyColumns) + , IndexDefinition.NamedIndexMigrationKey + , IndexDefinition.indexMigrationKey + , TriggerDefinition.TriggerDefinition + , TriggerDefinition.beforeInsert + , TriggerDefinition.afterInsert + , TriggerDefinition.beforeUpdate + , TriggerDefinition.afterUpdate + , TriggerDefinition.beforeDelete + , TriggerDefinition.afterDelete + , TriggerDefinition.mkTriggerDefinition + , TriggerDefinition.mkCreateTriggerExpr + , TriggerDefinition.TriggerMigrationKey (NamedTriggerKey) + , TriggerDefinition.triggerMigrationKey , PrimaryKey.PrimaryKey , PrimaryKey.primaryKey , PrimaryKey.compositePrimaryKey @@ -161,17 +184,20 @@ , SqlMarshaller.marshallReadOnlyField , SqlMarshaller.marshallPartial , SqlMarshaller.marshallMaybe + , SqlMarshaller.marshallQualifyFields , SqlMarshaller.prefixMarshaller , SqlMarshaller.foldMarshallerFields , SqlMarshaller.collectFromField , SqlMarshaller.ReadOnlyColumnOption (IncludeReadOnlyColumns, ExcludeReadOnlyColumns) , SyntheticField.SyntheticField , SyntheticField.syntheticFieldExpression + , SyntheticField.syntheticFieldName , SyntheticField.syntheticFieldAlias , SyntheticField.syntheticFieldValueFromSqlValue , SyntheticField.syntheticField , SyntheticField.nullableSyntheticField , SyntheticField.prefixSyntheticField + , SyntheticField.orderBySyntheticField , FieldDefinition.FieldDefinition , FieldDefinition.NotNull , FieldDefinition.Nullable @@ -220,6 +246,19 @@ , FieldDefinition.setField , (FieldDefinition..:=) , FieldDefinition.FieldNullability (NotNullField, NullableField) + , FieldDefinition.QualifiedFieldDefinition + , FieldDefinition.qualifyField + , FieldDefinition.qualifiedFieldColumnName + , FieldDefinition.FieldQualifier (qualifyColumnName) + , FieldDefinition.markAsIdentity + , FieldDefinition.unmarkIdentity + , Marshall.AliasName + , Marshall.stringToAliasName + , Marshall.aliasNameToString + , Marshall.aliasNameToAliasExpr + , Marshall.aliasNameAndFieldNameToColumnName + , Marshall.aliasNameToByteString + , Marshall.byteStringToAliasName , DefaultValue.DefaultValue , DefaultValue.integerDefault , DefaultValue.smallIntegerDefault @@ -250,10 +289,15 @@ , SelectOptions.where_ , SelectOptions.emptySelectOptions , SelectOptions.appendSelectOptions + , SelectOptions.forRowLock + , SelectOptions.fetchRow + , SelectOptions.window , FieldDefinition.fieldEquals , (FieldDefinition..==) , FieldDefinition.fieldNotEquals , (FieldDefinition../=) + , FieldDefinition.fieldIsDistinctFrom + , FieldDefinition.fieldIsNotDistinctFrom , FieldDefinition.fieldGreaterThan , (FieldDefinition..>) , FieldDefinition.fieldLessThan @@ -279,15 +323,26 @@ , Expr.descendingOrder , Expr.descendingOrderWith , FieldDefinition.orderByField + , Marshall.SqlComparable (toComparableSqlValue, referenceValueExpression) + , Marshall.orderBySqlComparable , Expr.orderByColumnName , Expr.andExpr , Expr.orExpr , (Expr..&&) , (Expr..||) + , Expr.rowLockingClause + , Expr.updateStrength + , Expr.noKeyUpdateStrength + , Expr.shareStrength + , Expr.keyShareStrength + , Expr.noWaitRowLockingOption + , Expr.skipLockedRowLockingOption , SelectOptions.selectGroupByClause , SelectOptions.selectOrderByClause , SelectOptions.selectWhereClause , SelectOptions.selectDistinct + , SelectOptions.selectRowLockingClause + , SelectOptions.selectFetchClause -- * Functions for defining and working with sequences , Sequence.sequenceNextValue @@ -319,6 +374,29 @@ , SequenceIdentifier.sequenceIdSchemaNameString , SequenceIdentifier.sequenceIdToString + -- * Functions for defining and working with PostgreSQL functions + , FunctionDefinition.FunctionDefinition + , FunctionDefinition.setFunctionSchema + , FunctionDefinition.mkTriggerFunction + , FunctionDefinition.mkCreateFunctionExpr + , FunctionDefinition.functionName + , FunctionDefinition.functionIdentifier + , FunctionDefinition.functionSource + , FunctionIdentifier.FunctionIdentifier + , FunctionIdentifier.unqualifiedNameToFunctionId + , FunctionIdentifier.functionIdUnqualifiedNameString + , FunctionIdentifier.functionIdQualifiedName + , FunctionIdentifier.setFunctionIdSchema + , FunctionIdentifier.functionIdSchemaNameString + , FunctionIdentifier.functionIdToString + , Expr.plpgsql + + -- * Functions for working with PostgreSQL extensions + , ExtensionIdentifier.ExtensionIdentifier + , ExtensionIdentifier.nameToExtensionId + , ExtensionIdentifier.extensionIdName + , ExtensionIdentifier.extensionIdToString + -- * Numeric types , SqlType.integer , SqlType.serial @@ -374,6 +452,7 @@ import qualified Orville.PostgreSQL.Execution.Sequence as Sequence import qualified Orville.PostgreSQL.Execution.Transaction as Transaction import qualified Orville.PostgreSQL.Expr as Expr +import qualified Orville.PostgreSQL.Marshall as Marshall import qualified Orville.PostgreSQL.Marshall.DefaultValue as DefaultValue import qualified Orville.PostgreSQL.Marshall.FieldDefinition as FieldDefinition import qualified Orville.PostgreSQL.Marshall.SqlMarshaller as SqlMarshaller @@ -386,9 +465,13 @@ import qualified Orville.PostgreSQL.Raw.Connection as Connection import qualified Orville.PostgreSQL.Raw.SqlCommenter as SqlCommenter import qualified Orville.PostgreSQL.Schema.ConstraintDefinition as ConstraintDefinition +import qualified Orville.PostgreSQL.Schema.ExtensionIdentifier as ExtensionIdentifier +import qualified Orville.PostgreSQL.Schema.FunctionDefinition as FunctionDefinition +import qualified Orville.PostgreSQL.Schema.FunctionIdentifier as FunctionIdentifier import qualified Orville.PostgreSQL.Schema.IndexDefinition as IndexDefinition import qualified Orville.PostgreSQL.Schema.PrimaryKey as PrimaryKey import qualified Orville.PostgreSQL.Schema.SequenceDefinition as SequenceDefinition import qualified Orville.PostgreSQL.Schema.SequenceIdentifier as SequenceIdentifier import qualified Orville.PostgreSQL.Schema.TableDefinition as TableDefinition import qualified Orville.PostgreSQL.Schema.TableIdentifier as TableIdentifier +import qualified Orville.PostgreSQL.Schema.TriggerDefinition as TriggerDefinition diff --git a/src/Orville/PostgreSQL/AutoMigration.hs b/src/Orville/PostgreSQL/AutoMigration.hs --- a/src/Orville/PostgreSQL/AutoMigration.hs +++ b/src/Orville/PostgreSQL/AutoMigration.hs @@ -3,7 +3,7 @@ {-# LANGUAGE RankNTypes #-} {- | -Copyright : Flipstone Technology Partners 2023 +Copyright : Flipstone Technology Partners 2023-2025 License : MIT Stability : Stable @@ -13,7 +13,7 @@ @since 1.0.0.0 -} module Orville.PostgreSQL.AutoMigration - ( MigrationOptions (runSchemaChanges, runConcurrentIndexCreations, migrationLockId) + ( MigrationOptions (runSchemaChanges, runConcurrentIndexCreations, migrationLockOptions) , defaultOptions , autoMigrateSchema , SchemaItem (..) @@ -24,6 +24,12 @@ , executeMigrationPlan , MigrationStep , MigrationDataError + , MigrationLock.MigrationLockOptions + , MigrationLock.defaultLockOptions + , MigrationLock.migrationLockId + , MigrationLock.maxLockAttempts + , MigrationLock.delayBetweenLockAttemptsMicros + , MigrationLock.lockDelayVariationMicros , MigrationLock.MigrationLockId , MigrationLock.defaultLockId , MigrationLock.nextLockId @@ -42,6 +48,7 @@ import qualified Data.Maybe as Maybe import qualified Data.Set as Set import qualified Data.String as String +import qualified Data.Text as T import qualified Data.Text.Encoding as Enc import qualified Database.PostgreSQL.LibPQ as LibPQ @@ -49,12 +56,13 @@ import qualified Orville.PostgreSQL.Expr as Expr import qualified Orville.PostgreSQL.Internal.IndexDefinition as IndexDefinition import qualified Orville.PostgreSQL.Internal.MigrationLock as MigrationLock +import qualified Orville.PostgreSQL.Marshall as Marshall import qualified Orville.PostgreSQL.PgCatalog as PgCatalog import qualified Orville.PostgreSQL.Raw.RawSql as RawSql import qualified Orville.PostgreSQL.Schema as Schema +import qualified Orville.PostgreSQL.Schema.TableIdentifier as TableIdentifier -{- | - A 'SchemaItem' represents a single item in a database schema such as a table, +{- | A 'SchemaItem' represents a single item in a database schema such as a table, index or constraint. The constructor functions below can be used to create items from other types (such as 'Orville.TableDefinition') to put them into a list to be used with 'autoMigrateSchema'. @@ -62,35 +70,60 @@ @since 1.0.0.0 -} data SchemaItem where - -- | - -- Constructs a 'SchemaItem' from a 'Orville.TableDefinition'. + -- | Constructs a 'SchemaItem' from a 'Orville.TableDefinition'. + -- -- @since 1.0.0.0 SchemaTable :: Orville.TableDefinition key writeEntity readEntity -> SchemaItem - -- | - -- Constructs a 'SchemaItem' that will drop the specified table if it is + -- | Constructs a 'SchemaItem' that will drop the specified table if it is -- found in the database. + -- -- @since 1.0.0.0 SchemaDropTable :: Orville.TableIdentifier -> SchemaItem - -- | - -- Constructs a 'SchemaItem' from a 'Orville.SequenceDefinition'. + -- | Constructs a 'SchemaItem' from a 'Orville.SequenceDefinition'. + -- -- @since 1.0.0.0 SchemaSequence :: Orville.SequenceDefinition -> SchemaItem - -- | - -- Constructs a 'SchemaItem' that will drop the specified table if it is - -- found in the database. + -- | Constructs a 'SchemaItem' that will drop the specified table if it is + -- found in the database. + -- -- @since 1.0.0.0 SchemaDropSequence :: Orville.SequenceIdentifier -> SchemaItem + -- | Constructs a 'SchemaItem' from a 'Orville.FunctionDefinition'. + -- + -- @since 1.1.0.0 + SchemaFunction :: + Orville.FunctionDefinition -> + SchemaItem + -- | Constructs a 'SchemaItem' that will drop the specified table if it is + -- found in the database. + -- + -- @since 1.1.0.0 + SchemaDropFunction :: + Orville.FunctionIdentifier -> + SchemaItem + -- | Constructs a 'SchemaItem' from a 'Orville.ExtensionName', that will load the extension. + -- + -- @since 1.1.0.0 + SchemaExtension :: + Orville.ExtensionIdentifier -> + SchemaItem + -- | Constructs a 'SchemaItem' that will unload the postgresql extension if it is found in the + -- database. + -- + -- @since 1.1.0.0 + SchemaDropExtension :: + Orville.ExtensionIdentifier -> + SchemaItem -{- | - Returns a one-line string describing the 'SchemaItem', suitable for a human +{- | Returns a one-line string describing the 'SchemaItem', suitable for a human to identify it in a list of output. For example, a 'SchemaItem' constructed via 'SchemaTable' gives @Table Orville.sequenceIdToString (Orville.sequenceIdentifier sequenceDef) SchemaDropSequence sequenceId -> "Drop sequence " <> Orville.sequenceIdToString sequenceId + SchemaFunction functionDef -> + "Function " <> Orville.functionIdToString (Orville.functionIdentifier functionDef) + SchemaDropFunction functionId -> + "Drop function " <> Orville.functionIdToString functionId + SchemaExtension extension -> + "Extension " <> Orville.extensionIdToString extension + SchemaDropExtension extension -> + "Drop Extension " <> Orville.extensionIdToString extension {- | A 'MigrationPlan' contains an ordered list of migration steps. Each one is a @@ -128,8 +169,7 @@ , i_concurrentIndexSteps :: [MigrationStep] } -{- | - Returns all the 'MigrationStep's found in a 'MigrationPlan' together in a +{- | Returns all the 'MigrationStep's found in a 'MigrationPlan' together in a single list. This is useful if you merely want to examine the steps of a plan rather than execute them. You should always use 'executeMigrationPlan' to execute a migration plan to ensure that the transactional steps are done @@ -151,12 +191,11 @@ $ steps in MigrationPlan - { i_transactionalSteps = map migrationStep transactionalSteps - , i_concurrentIndexSteps = map migrationStep concurrentIndexSteps + { i_transactionalSteps = fmap migrationStep transactionalSteps + , i_concurrentIndexSteps = fmap migrationStep concurrentIndexSteps } -{- | - A single SQL statement that will be executed in order to migrate the database +{- | A single SQL statement that will be executed in order to migrate the database to the desired result. You can use 'generateMigrationPlan' to get a list of these yourself for inspection and debugging. @@ -169,8 +208,7 @@ RawSql.SqlExpression ) -{- | - This type is used internally by Orville to order the migration steps after +{- | This type is used internally by Orville to order the migration steps after they have been created. It is not exposed outside this module. @since 1.0.0.0 @@ -197,14 +235,20 @@ DropForeignKeys -> True DropUniqueConstraints -> True DropIndexes -> True + DropTriggers -> True + DropFunctions -> True + DropExtensions -> True + AddExtensions -> True AddRemoveTablesAndColumns -> True + AddFunctions -> True + AddTriggers -> True AddIndexesTransactionally -> True AddUniqueConstraints -> True AddForeignKeys -> True AddIndexesConcurrently -> False + SetComments -> True -{- | - Indicates the kind of operation being performed by a 'MigrationStep' so +{- | Indicates the kind of operation being performed by a 'MigrationStep' so that the steps can be ordered in a sequence that is guaranteed to succeed. The order of the constructors below indicates the order in which steps will be run. @@ -212,14 +256,36 @@ @since 1.0.0.0 -} data StepType - = DropForeignKeys - | DropUniqueConstraints - | DropIndexes - | AddRemoveTablesAndColumns - | AddIndexesTransactionally - | AddUniqueConstraints - | AddForeignKeys - | AddIndexesConcurrently + = -- | @since 1.0.0.0 + DropForeignKeys + | -- | @since 1.0.0.0 + DropUniqueConstraints + | -- | @since 1.0.0.0 + DropIndexes + | -- | @since 1.1.0.0 + DropTriggers + | -- | @since 1.1.0.0 + DropFunctions + | -- | @since 1.1.0.0 + DropExtensions + | -- | @since 1.1.0.0 + AddExtensions + | -- | @since 1.0.0.0 + AddRemoveTablesAndColumns + | -- | @since 1.1.0.0 + AddFunctions + | -- | @since 1.1.0.0 + AddTriggers + | -- | @since 1.0.0.0 + AddIndexesTransactionally + | -- | @since 1.0.0.0 + AddUniqueConstraints + | -- | @since 1.0.0.0 + AddForeignKeys + | -- | @since 1.0.0.0 + AddIndexesConcurrently + | -- | @since 1.1.0.0 + SetComments deriving ( -- | @since 1.0.0.0 Eq @@ -227,8 +293,7 @@ Ord ) -{- | - A 'MigrationDataError' will be thrown from the migration functions if data +{- | A 'MigrationDataError' will be thrown from the migration functions if data necessary for migration cannot be found. @since 1.0.0.0 @@ -268,15 +333,17 @@ -- rest of the schema changes. -- -- @since 1.0.0.0 - , migrationLockId :: MigrationLock.MigrationLockId + , migrationLockOptions :: MigrationLock.MigrationLockOptions -- ^ - -- The 'MigrationLock.MigrationLockId' that will be use to ensure only + -- The 'MigrationLock.MigrationLockOptions' that will be used to ensure only -- one application is running migrations at a time. The default value - -- is 'MigrationLock.defaultLockId'. You may want to change this if you - -- want to run concurrent index creations separately from the rest of - -- the schema changes without blocking one another. + -- is 'MigrationLock.defaultLockOptions'. You may want to change these if you + -- your application has special migration needs. For instance, you might specify + -- a custom lock id along with migrating just concurrent indexes to allow them + -- to run separately from the rest of the schema changes without blocking one + -- another. -- - -- @since 1.0.0.0 + -- @since 1.1.0.0 } {- | @@ -290,11 +357,10 @@ MigrationOptions { runSchemaChanges = True , runConcurrentIndexCreations = True - , migrationLockId = MigrationLock.defaultLockId + , migrationLockOptions = MigrationLock.defaultLockOptions } -{- | - This function compares the list of 'SchemaItem's provided against the current +{- | This function compares the list of 'SchemaItem's provided against the current schema found in the database to determine whether any migrations are necessary. If any changes need to be made, this function executes. You can call 'generateMigrationPlan' and 'executeMigrationPlan' yourself if you want @@ -312,12 +378,11 @@ [SchemaItem] -> m () autoMigrateSchema options schemaItems = - MigrationLock.withMigrationLock (migrationLockId options) $ do + MigrationLock.withMigrationLock (migrationLockOptions options) $ do plan <- generateMigrationPlanWithoutLock schemaItems executeMigrationPlanWithoutLock options plan -{- | - Compares the list of 'SchemaItem's provided against the current schema found +{- | Compares the list of 'SchemaItem's provided against the current schema found in the database and returns a 'MigrationPlan' that could be executed to make the database schema match the items given. @@ -337,7 +402,7 @@ [SchemaItem] -> m MigrationPlan generateMigrationPlan options = - MigrationLock.withMigrationLock (migrationLockId options) + MigrationLock.withMigrationLock (migrationLockOptions options) . generateMigrationPlanWithoutLock generateMigrationPlanWithoutLock :: Orville.MonadOrville m => [SchemaItem] -> m MigrationPlan @@ -346,18 +411,27 @@ currentNamespace <- findCurrentNamespace let - pgCatalogRelations = fmap (schemaItemPgCatalogRelation currentNamespace) schemaItems + pgCatalogRelations = + Maybe.mapMaybe + (schemaItemPgCatalogRelation currentNamespace) + schemaItems - dbDesc <- PgCatalog.describeDatabaseRelations pgCatalogRelations + pgCatalogFunctions = + Maybe.mapMaybe + (schemaItemPgCatalogFunction currentNamespace) + schemaItems + pgCatalogExtensions = + Maybe.mapMaybe schemaItemPgCatalogExtension schemaItems + dbDesc <- PgCatalog.describeDatabase pgCatalogRelations pgCatalogFunctions pgCatalogExtensions + case traverse (calculateMigrationSteps currentNamespace dbDesc) schemaItems of Left err -> liftIO . throwIO $ err Right migrationSteps -> pure . mkMigrationPlan . concat $ migrationSteps -{- | - Executes a 'MigrationPlan' that has been previously devised via +{- | Executes a 'MigrationPlan' that has been previously devised via 'generateMigrationPlan'. Normally all the steps in a migration plan are executed in a transaction so that they will all be applied together successfully or all rolled-back if one of them fails. Any indexes using the @@ -381,7 +455,7 @@ MigrationPlan -> m () executeMigrationPlan options = - MigrationLock.withMigrationLock (migrationLockId options) + MigrationLock.withMigrationLock (migrationLockOptions options) . executeMigrationPlanWithoutLock options executeMigrationPlanWithoutLock :: @@ -398,8 +472,7 @@ when (runConcurrentIndexCreations options) . executeMigrationStepsWithoutTransaction - $ i_concurrentIndexSteps - $ plan + $ i_concurrentIndexSteps plan executeMigrationStepsWithoutTransaction :: Orville.MonadOrville m => [MigrationStep] -> m () executeMigrationStepsWithoutTransaction = @@ -482,9 +555,68 @@ AddRemoveTablesAndColumns (Expr.dropSequenceExpr Nothing (Orville.sequenceIdQualifiedName sequenceId)) ] + SchemaFunction functionDef -> + Right $ + let + (schemaName, procName) = + functionIdToPgCatalogNames currentNamespace (Orville.functionIdentifier functionDef) + in + case PgCatalog.lookupProcedure (schemaName, procName) dbDesc of + Nothing -> + [ mkMigrationStepWithType + AddFunctions + (Orville.mkCreateFunctionExpr functionDef Nothing) + ] + Just pgProc -> + if PgCatalog.pgProcSource pgProc == T.pack (Orville.functionSource functionDef) + then [] + else + [ mkMigrationStepWithType + AddFunctions + (Orville.mkCreateFunctionExpr functionDef (Just Expr.orReplace)) + ] + SchemaDropFunction functionId -> + Right $ + let + (schemaName, procName) = + functionIdToPgCatalogNames currentNamespace functionId + in + case PgCatalog.lookupProcedure (schemaName, procName) dbDesc of + Nothing -> + [] + Just _proc -> + [ mkMigrationStepWithType + DropFunctions + (Expr.dropFunction Nothing (Orville.functionIdQualifiedName functionId)) + ] + SchemaExtension extension -> + Right $ + let + catalogExtensionName = extensionIdToPgCatalogName extension + in + case PgCatalog.lookupExtension catalogExtensionName dbDesc of + Nothing -> + [ mkMigrationStepWithType + AddExtensions + (Expr.createExtensionExpr (Orville.extensionIdName extension) Nothing (Just Expr.extensionCascadeExpr)) + ] + Just _pgExtension -> + [] + SchemaDropExtension extension -> + Right $ + let + catalogExtensionName = extensionIdToPgCatalogName extension + in + case PgCatalog.lookupExtension catalogExtensionName dbDesc of + Nothing -> + [] + Just _pgExtension -> + [ mkMigrationStepWithType + DropExtensions + (Expr.dropExtensionExpr (Orville.extensionIdName extension) Nothing Nothing) + ] -{- | - Builds 'MigrationStep's that will perform table creation. This function +{- | Builds 'MigrationStep's that will perform table creation. This function assumes the table does not exist. The migration step it produces will fail if the table already exists in its schema. Multiple steps may be required to create the table if foreign keys exist to that reference other tables, which @@ -511,6 +643,8 @@ (Orville.mkTablePrimaryKeyExpr tableDef) [] + commentSteps = mkCreateTableCommentSteps tableDef + addConstraintActions = concatMap (mkAddConstraintActions currentNamespace Set.empty) @@ -520,13 +654,62 @@ concatMap (mkAddIndexSteps Set.empty tableName) (Orville.tableIndexes tableDef) + + addTriggerSteps = + concatMap + (mkAddTriggerSteps Set.empty tableName) + (Orville.tableTriggers tableDef) in mkMigrationStepWithType AddRemoveTablesAndColumns createTableExpr : mkConstraintSteps tableName addConstraintActions <> addIndexSteps + <> addTriggerSteps + <> commentSteps -{- | - Builds migration steps that are required to create or alter the table's +mkCreateTableCommentSteps :: + Orville.TableDefinition key writeEntity readEntity -> + [MigrationStepWithType] +mkCreateTableCommentSteps tableDef = + let + mbCommentTableStep = + fmap + ( mkMigrationStepWithType SetComments + . Expr.commentTableExpr (Schema.tableName tableDef) + . Just + . Expr.commentText + ) + (Schema.tableComment tableDef) + + tableId = Orville.tableIdentifier tableDef + + mbCommentColumnStep colName = + fmap + ( mkMigrationStepWithType SetComments + . Expr.commentColumnExpr + (Schema.tableIdSchemaName tableId) + (Schema.tableIdUnqualifiedName tableId) + colName + . Just + . Expr.commentText + . T.pack + ) + + mbCommentColumnsSteps = + Orville.foldMarshallerFields + (Orville.unannotatedSqlMarshaller $ Schema.tableMarshaller tableDef) + [] + ( Orville.collectFromField + Orville.IncludeReadOnlyColumns + ( const $ \fieldDef -> + mbCommentColumnStep + (Orville.fieldNameToColumnName $ Orville.fieldName fieldDef) + (Orville.fieldDescription fieldDef) + ) + ) + in + Maybe.catMaybes (mbCommentTableStep : mbCommentColumnsSteps) + +{- | Builds migration steps that are required to create or alter the table's schema to make it match the given table definition. This function uses the given relation description to determine what @@ -547,7 +730,7 @@ Orville.foldMarshallerFields (Orville.unannotatedSqlMarshaller $ Orville.tableMarshaller tableDef) [] - (Orville.collectFromField Orville.IncludeReadOnlyColumns (mkAddAlterColumnActions relationDesc)) + (Orville.collectFromField Orville.IncludeReadOnlyColumns (const (mkAddAlterColumnActions relationDesc))) dropColumnActions = concatMap @@ -606,9 +789,32 @@ dropIndexSteps = concatMap - (mkDropIndexSteps indexesToKeep systemIndexOids) + (mkDropIndexSteps indexesToKeep systemIndexOids . TableIdentifier.tableIdSchemaName $ Orville.tableIdentifier tableDef) (PgCatalog.relationIndexes relationDesc) + existingTriggers = + Set.fromList + . fmap pgTriggerMigrationKey + . PgCatalog.relationTriggers + $ relationDesc + + triggersToKeep = + Map.keysSet + . Orville.tableTriggers + $ tableDef + + addTriggerSteps = + concatMap + (mkAddTriggerSteps existingTriggers tableName) + (Orville.tableTriggers tableDef) + + dropTriggerSteps = + concatMap + (mkDropTriggerSteps triggersToKeep tableName) + (PgCatalog.relationTriggers relationDesc) + + commentSteps = mkCommentSteps relationDesc tableDef + tableName = Orville.tableName tableDef in @@ -616,9 +822,11 @@ <> mkConstraintSteps tableName (addConstraintActions <> dropConstraintActions) <> addIndexSteps <> dropIndexSteps + <> addTriggerSteps + <> dropTriggerSteps + <> commentSteps -{- | - Consolidates alter table actions (which should all be related to adding and +{- | Consolidates alter table actions (which should all be related to adding and dropping constraints) into migration steps based on their 'StepType'. Actions with the same 'StepType' will be performed togethir in a single @ALTER TABLE@ statement. @@ -626,7 +834,7 @@ @since 1.0.0.0 -} mkConstraintSteps :: - Expr.Qualified Expr.TableName -> + Expr.QualifiedOrUnqualified Expr.TableName -> [(StepType, Expr.AlterTableAction)] -> [MigrationStepWithType] mkConstraintSteps tableName actions = @@ -635,24 +843,23 @@ (StepType, Expr.AlterTableAction) -> (StepType, NonEmpty Expr.AlterTableAction) mkMapEntry (keyType, action) = - (keyType, (action :| [])) + (keyType, action :| []) addStep stepType actionExprs steps = mkMigrationStepWithType stepType (Expr.alterTableExpr tableName actionExprs) : steps in Map.foldrWithKey addStep [] . Map.fromListWith (<>) - . map mkMapEntry + . fmap mkMapEntry $ actions -{- | - If there are any alter table actions for adding or removing columns, creates a migration +{- | If there are any alter table actions for adding or removing columns, creates a migration step to perform them. Otherwise returns an empty list. @since 1.0.0.0 -} mkAlterColumnSteps :: - Expr.Qualified Expr.TableName -> + Expr.QualifiedOrUnqualified Expr.TableName -> [Expr.AlterTableAction] -> [MigrationStepWithType] mkAlterColumnSteps tableName actionExprs = @@ -662,8 +869,7 @@ Just nonEmptyActionExprs -> [mkMigrationStepWithType AddRemoveTablesAndColumns (Expr.alterTableExpr tableName nonEmptyActionExprs)] -{- | - Builds 'Expr.AlterTableAction' expressions to bring the database schema in +{- | Builds 'Expr.AlterTableAction' expressions to bring the database schema in line with the given 'Orville.FieldDefinition', or none if no change is required. @@ -690,7 +896,7 @@ || (Orville.sqlTypeMaximumLength sqlType /= PgCatalog.pgAttributeMaxLength attr) columnName = - Orville.fieldColumnName fieldDef + Orville.fieldNameToColumnName $ Orville.fieldName fieldDef dataType = Orville.sqlTypeExpr sqlType @@ -709,7 +915,7 @@ alterNullability = do guard nullabilityIsChanged - [Expr.alterColumnNullability (Orville.fieldColumnName fieldDef) nullabilityAction] + [Expr.alterColumnNullability columnName nullabilityAction] maybeExistingDefault = PgCatalog.lookupAttributeDefault attr relationDesc @@ -749,8 +955,28 @@ ( Just (Expr.alterColumnDropDefault columnName) , Just (Expr.alterColumnSetDefault columnName newDefault) ) + + alterIdentity = + case (Marshall.fieldIdentityGeneration fieldDef, PgCatalog.pgAttributeIdentity attr) of + (Nothing, Nothing) -> mempty + (Just Marshall.GeneratedAlways, Just Marshall.GeneratedAlways) -> mempty + (Just Marshall.GeneratedByDefault, Just Marshall.GeneratedByDefault) -> mempty + (Nothing, Just _) -> + pure $ Expr.alterColumnDropIdentity columnName Nothing + (Just Marshall.GeneratedAlways, Nothing) -> + pure $ Expr.alterColumnAddIdentity columnName Expr.alwaysColumnIdentityGeneration + (Just Marshall.GeneratedAlways, Just _existing) -> + [Expr.alterColumnDropIdentity columnName Nothing, Expr.alterColumnAddIdentity columnName Expr.alwaysColumnIdentityGeneration] + (Just Marshall.GeneratedByDefault, Nothing) -> + pure $ Expr.alterColumnAddIdentity columnName Expr.byDefaultColumnIdentityGeneration + (Just Marshall.GeneratedByDefault, Just _existing) -> + [Expr.alterColumnDropIdentity columnName Nothing, Expr.alterColumnAddIdentity columnName Expr.byDefaultColumnIdentityGeneration] in - Maybe.maybeToList dropDefault <> alterType <> Maybe.maybeToList setDefault <> alterNullability + Maybe.maybeToList dropDefault + <> alterType + <> Maybe.maybeToList setDefault + <> alterNullability + <> alterIdentity _ -> -- Either the column doesn't exist in the table _OR_ it's a system -- column. If it's a system column, attempting to add it will result @@ -762,8 +988,7 @@ -- attributes. [Expr.addColumn (Orville.fieldColumnDefinition fieldDef)] -{- | - Builds 'Expr.AlterTableAction' expressions for the given attribute to make +{- | Builds 'Expr.AlterTableAction' expressions for the given attribute to make the database schema match the given 'Orville.TableDefinition'. This function is only responsible for handling cases where the attribute does not have a correspending 'Orville.FieldDefinition'. See 'mkAlterTableSteps' for those @@ -784,8 +1009,7 @@ [Expr.dropColumn $ Expr.columnName attrName] -{- | - Sets the schema name on a constraint to the given namespace when the +{- | Sets the schema name on a constraint to the given namespace when the constraint has no namespace explicitly given. This is important for Orville to discover whether a constraint from a table definition matches a constraint found to already exist in the database because constraints in the database @@ -814,8 +1038,7 @@ Just _ -> constraintKey -{- | - Builds 'Expr.AlterTableAction' expressions to create the given table +{- | Builds 'Expr.AlterTableAction' expressions to create the given table constraint if it does not exist. @since 1.0.0.0 @@ -840,8 +1063,7 @@ then [] else [(stepType, Expr.addConstraint (Orville.constraintSqlExpr constraintDef))] -{- | - Builds 'Expr.AlterTableAction' expressions to drop the given table +{- | Builds 'Expr.AlterTableAction' expressions to drop the given table constraint if it should not exist. @since 1.0.0.0 @@ -873,8 +1095,7 @@ in [(stepType, Expr.dropConstraint constraintName)] -{- | - Builds the orville migration key for a description of an existing constraint +{- | Builds the orville migration key for a description of an existing constraint so that it can be compared with constraints found in a table definition. Constraint keys built this way always have a schema name populated, so it's important to set the schema names for the constraints found in the table @@ -899,8 +1120,9 @@ constraint = PgCatalog.constraintRecord constraintDesc + pgAttributeNamesToFieldNames :: [PgCatalog.PgAttribute] -> [Orville.FieldName] pgAttributeNamesToFieldNames = - map (Orville.stringToFieldName . PgCatalog.attributeNameToString . PgCatalog.pgAttributeName) + fmap (Orville.stringToFieldName . PgCatalog.attributeNameToString . PgCatalog.pgAttributeName) foreignRelationTableId :: PgCatalog.ForeignRelationDescription -> Orville.TableIdentifier foreignRelationTableId foreignRelationDesc = @@ -941,14 +1163,13 @@ PgCatalog.pgConstraintForeignKeyOnDeleteType $ PgCatalog.constraintRecord constraintDesc } -{- | - Builds migration steps to create an index if it does not exist. +{- | Builds migration steps to create an index if it does not exist. @since 1.0.0.0 -} mkAddIndexSteps :: Set.Set IndexDefinition.IndexMigrationKey -> - Expr.Qualified Expr.TableName -> + Expr.QualifiedOrUnqualified Expr.TableName -> Orville.IndexDefinition -> [MigrationStepWithType] mkAddIndexSteps existingIndexes tableName indexDef = @@ -965,17 +1186,17 @@ then [] else [mkMigrationStepWithType indexStep (Orville.indexCreateExpr indexDef tableName)] -{- | - Builds migration steps to drop an index if it should not exist. +{- | Builds migration steps to drop an index if it should not exist. @since 1.0.0.0 -} mkDropIndexSteps :: Set.Set IndexDefinition.IndexMigrationKey -> Set.Set LibPQ.Oid -> + Maybe Expr.SchemaName -> PgCatalog.IndexDescription -> [MigrationStepWithType] -mkDropIndexSteps indexesToKeep systemIndexOids indexDesc = +mkDropIndexSteps indexesToKeep systemIndexOids mSchema indexDesc = case pgIndexMigrationKeys indexDesc of [] -> [] @@ -990,16 +1211,122 @@ . PgCatalog.pgClassRelationName $ pgClass + qualifiedIndexName = case mSchema of + Just schema -> Expr.untrackQualified $ Expr.qualifyIndex schema indexName + Nothing -> Expr.unqualified indexName + indexOid = PgCatalog.pgClassOid pgClass in if any (flip Set.member indexesToKeep) indexKeys || Set.member indexOid systemIndexOids then [] - else [mkMigrationStepWithType DropIndexes (Expr.dropIndexExpr indexName)] + else [mkMigrationStepWithType DropIndexes (Expr.dropIndexExpr qualifiedIndexName)] -{- | - Primary Key, Unique, and Exclusion constraints automatically create indexes +{- | Builds migration steps to create a trigger if it does not exist. + +@since 1.1.0.0 +-} +mkAddTriggerSteps :: + Set.Set Schema.TriggerMigrationKey -> + Expr.QualifiedOrUnqualified Expr.TableName -> + Orville.TriggerDefinition -> + [MigrationStepWithType] +mkAddTriggerSteps existingTriggers tableName triggerDef = + let + triggerKey = + Schema.triggerMigrationKey triggerDef + in + if Set.member triggerKey existingTriggers + then [] + else [mkMigrationStepWithType AddTriggers (Orville.mkCreateTriggerExpr triggerDef Nothing tableName)] + +{- | Builds migration steps to drop an trigger if it should not exist. + +@since 1.1.0.0 +-} +mkDropTriggerSteps :: + Set.Set Schema.TriggerMigrationKey -> + Expr.QualifiedOrUnqualified Expr.TableName -> + PgCatalog.PgTrigger -> + [MigrationStepWithType] +mkDropTriggerSteps triggersToKeep tableName pgTrigger = + let + migrationKey = + pgTriggerMigrationKey pgTrigger + + triggerName = + Expr.triggerName + . PgCatalog.triggerNameToString + . PgCatalog.pgTriggerName + $ pgTrigger + in + if Set.member migrationKey triggersToKeep || PgCatalog.pgTriggerIsInternal pgTrigger + then [] + else [mkMigrationStepWithType DropTriggers (Expr.dropTrigger Nothing triggerName tableName)] + +mkCommentSteps :: + PgCatalog.RelationDescription -> + Orville.TableDefinition key writeEntity readEntity -> + [MigrationStepWithType] +mkCommentSteps relationDesc tableDef = + let + tableName = Orville.tableName tableDef + + commentTableStep = + if PgCatalog.relationComment relationDesc == Schema.tableComment tableDef + then [] + else + [ mkMigrationStepWithType + SetComments + ( Expr.commentTableExpr + tableName + (fmap Expr.commentText (Schema.tableComment tableDef)) + ) + ] + + commentColumnsSteps = + Maybe.catMaybes $ + Orville.foldMarshallerFields + (Orville.unannotatedSqlMarshaller $ Orville.tableMarshaller tableDef) + [] + ( Orville.collectFromField + Orville.IncludeReadOnlyColumns + (const . mkCommentColumnStep relationDesc $ Orville.tableIdentifier tableDef) + ) + in + commentTableStep <> commentColumnsSteps + +mkCommentColumnStep :: + PgCatalog.RelationDescription -> + Schema.TableIdentifier -> + Orville.FieldDefinition n a -> + Maybe MigrationStepWithType +mkCommentColumnStep relationDesc tableId fieldDef = + let + fieldAttributeName = + String.fromString (Orville.fieldNameToString $ Orville.fieldName fieldDef) + + currentFieldComment = + PgCatalog.lookupAttributeComment fieldAttributeName relationDesc + + targetFieldComment = + fmap T.pack (Orville.fieldDescription fieldDef) + in + if currentFieldComment == targetFieldComment + then Nothing + else + Just $ + mkMigrationStepWithType + SetComments + ( Expr.commentColumnExpr + (Schema.tableIdSchemaName tableId) + (Schema.tableIdUnqualifiedName tableId) + (Orville.fieldNameToColumnName $ Orville.fieldName fieldDef) + (fmap Expr.commentText targetFieldComment) + ) + +{- | Primary Key, Unique, and Exclusion constraints automatically create indexes that we don't want orville to consider for the purposes of migrations. This function checks the constraint type and returns the OID of the supporting index if the constraint is one of these types. @@ -1026,8 +1353,7 @@ PgCatalog.ConstraintTrigger -> Nothing -{- | - Builds the orville migration keys given a description of an existing index +{- | Builds the orville migration keys given a description of an existing index so that it can be compared with indexs found in a table definition. If the description includes expressions as members of the index rather than @@ -1053,7 +1379,7 @@ Nothing -> [] in - [mkNamedIndexKey] ++ mkAttributeBasedIndexKey + mkNamedIndexKey : mkAttributeBasedIndexKey pgAttributeBasedIndexMigrationKey :: PgCatalog.IndexDescription -> @@ -1079,21 +1405,102 @@ , IndexDefinition.indexKeyColumns = fieldNames } +{- | Builds the orville migration key given a description of an existing trigger + so that it can be compared with triggers found in a table definition. + + If the description includes expressions as members of the trigger rather than + simple attributes, 'Nothing' is returned. + +@since 1.1.0.0 +-} +pgTriggerMigrationKey :: + PgCatalog.PgTrigger -> + Schema.TriggerMigrationKey +pgTriggerMigrationKey = + Schema.NamedTriggerKey + . PgCatalog.triggerNameToString + . PgCatalog.pgTriggerName + +{- | Retrieves from a 'SchemaItem' the relation (if any) that the schema item relates to + so that the migration infrastructure can look up data about it in the PostgreSQL + catalog for planning migration steps. +-} schemaItemPgCatalogRelation :: PgCatalog.NamespaceName -> SchemaItem -> - (PgCatalog.NamespaceName, PgCatalog.RelationName) + Maybe (PgCatalog.NamespaceName, PgCatalog.RelationName) schemaItemPgCatalogRelation currentNamespace item = case item of SchemaTable tableDef -> - tableIdToPgCatalogNames currentNamespace (Orville.tableIdentifier tableDef) + Just $ tableIdToPgCatalogNames currentNamespace (Orville.tableIdentifier tableDef) SchemaDropTable tableId -> - tableIdToPgCatalogNames currentNamespace tableId + Just $ tableIdToPgCatalogNames currentNamespace tableId SchemaSequence sequenceDef -> - sequenceIdToPgCatalogNames currentNamespace (Orville.sequenceIdentifier sequenceDef) + Just $ sequenceIdToPgCatalogNames currentNamespace (Orville.sequenceIdentifier sequenceDef) SchemaDropSequence sequenceId -> - sequenceIdToPgCatalogNames currentNamespace sequenceId + Just $ sequenceIdToPgCatalogNames currentNamespace sequenceId + SchemaFunction _functionDef -> + Nothing + SchemaDropFunction _functionId -> + Nothing + SchemaExtension _extension -> + Nothing + SchemaDropExtension _extension -> + Nothing +{- | Retrieves from a 'SchemaItem' the function (if any) that the schema item relates to + so that the migration infrastructure can look up data about it in the PostgreSQL + catalog for planning migration steps. +-} +schemaItemPgCatalogFunction :: + PgCatalog.NamespaceName -> + SchemaItem -> + Maybe (PgCatalog.NamespaceName, PgCatalog.ProcName) +schemaItemPgCatalogFunction currentNamespace item = + case item of + SchemaTable _tableDef -> + Nothing + SchemaDropTable _tableId -> + Nothing + SchemaSequence _sequenceDef -> + Nothing + SchemaDropSequence _sequenceId -> + Nothing + SchemaFunction functionDef -> + Just $ functionIdToPgCatalogNames currentNamespace (Orville.functionIdentifier functionDef) + SchemaDropFunction functionId -> + Just $ functionIdToPgCatalogNames currentNamespace functionId + SchemaExtension _extension -> + Nothing + SchemaDropExtension _extension -> + Nothing + +{- | Retrieves from a 'SchemaItem' the extension (if any) that the schema item relates to + so that the migration infrastructure can look up data about it in the PostgreSQL + catalog for planning migration steps. +-} +schemaItemPgCatalogExtension :: + SchemaItem -> + Maybe PgCatalog.ExtensionName +schemaItemPgCatalogExtension item = + case item of + SchemaTable _tableDef -> + Nothing + SchemaDropTable _tableId -> + Nothing + SchemaSequence _sequenceDef -> + Nothing + SchemaDropSequence _sequenceId -> + Nothing + SchemaFunction _functionDef -> + Nothing + SchemaDropFunction _functionId -> + Nothing + SchemaExtension extension -> + Just $ extensionIdToPgCatalogName extension + SchemaDropExtension extension -> + Just $ extensionIdToPgCatalogName extension + tableIdToPgCatalogNames :: PgCatalog.NamespaceName -> Orville.TableIdentifier -> @@ -1112,6 +1519,30 @@ in (actualNamespace, relationName) +functionIdToPgCatalogNames :: + PgCatalog.NamespaceName -> + Orville.FunctionIdentifier -> + (PgCatalog.NamespaceName, PgCatalog.ProcName) +functionIdToPgCatalogNames currentNamespace functionId = + let + actualNamespace = + maybe currentNamespace String.fromString + . Orville.functionIdSchemaNameString + $ functionId + + relationName = + String.fromString + . Orville.functionIdUnqualifiedNameString + $ functionId + in + (actualNamespace, relationName) + +extensionIdToPgCatalogName :: + Orville.ExtensionIdentifier -> + PgCatalog.ExtensionName +extensionIdToPgCatalogName = + String.fromString . Orville.extensionIdToString + mkAlterSequenceSteps :: Orville.SequenceDefinition -> PgCatalog.PgSequence -> @@ -1192,7 +1623,7 @@ -- put it in quotes it tries to treat it as a regular column name, -- which then can't be found as a column in the query. (RawSql.unsafeSqlExpression "current_schema") - (Orville.fieldColumnName PgCatalog.namespaceNameField) + (Orville.fieldNameToColumnName $ Orville.fieldName PgCatalog.namespaceNameField) ] ) Nothing diff --git a/src/Orville/PostgreSQL/ErrorDetailLevel.hs b/src/Orville/PostgreSQL/ErrorDetailLevel.hs --- a/src/Orville/PostgreSQL/ErrorDetailLevel.hs +++ b/src/Orville/PostgreSQL/ErrorDetailLevel.hs @@ -17,8 +17,7 @@ ) where -{- | - 'ErrorDetailLevel' provides a means to configure what elements of information +{- | 'ErrorDetailLevel' provides a means to configure what elements of information are included in error messages that originate from decoding rows queried from the database. This can be specified either by manually rendering the error message and providing the desired configuration, or by setting the @@ -40,8 +39,7 @@ Show ) -{- | - A minimal 'ErrorDetailLevel' where all information (including any +{- | A minimal 'ErrorDetailLevel' where all information (including any situationally-specific error messages!) is redacted from error messages. @since 1.0.0.0 @@ -55,8 +53,7 @@ , includeNonIdentifierValues = False } -{- | - A default 'ErrorDetailLevel' that strikes a balance of including all "Generic" +{- | A default 'ErrorDetailLevel' that strikes a balance of including all "Generic" information such as the error message, schema names and row identifiers, but avoids unintentionally leaking non-identifier values from the database by redacting them. @@ -72,8 +69,7 @@ , includeNonIdentifierValues = False } -{- | - A maximal 'ErrorDetailLevel' that redacts no information from the error +{- | A maximal 'ErrorDetailLevel' that redacts no information from the error messages. Error messages will include values from the database for any columns that are involved in a decoding failure, including some which you may not have intended to expose through error messages. Use with caution. @@ -89,8 +85,7 @@ , includeNonIdentifierValues = True } -{- | - Redacts given the error message string if the 'ErrorDetailLevel' indicates +{- | Redacts given the error message string if the 'ErrorDetailLevel' indicates that error messages should be redacted. @since 1.0.0.0 @@ -101,8 +96,7 @@ then message else redactedValue -{- | - Redacts given the schema name string if the 'ErrorDetailLevel' indicates +{- | Redacts given the schema name string if the 'ErrorDetailLevel' indicates that schema names should be redacted. @since 1.0.0.0 @@ -113,8 +107,7 @@ then schemaName else redactedValue -{- | - Redacts given the identifier value string if the 'ErrorDetailLevel' indicates +{- | Redacts given the identifier value string if the 'ErrorDetailLevel' indicates that identifier values should be redacted. @since 1.0.0.0 @@ -125,11 +118,10 @@ then idValue else redactedValue -{- | - Redacts given the non-identifier value string if the 'ErrorDetailLevel' indicates +{- | Redacts given the non-identifier value string if the 'ErrorDetailLevel' indicates that non-identifier values should be redacted. -@since 1.0.0.0 + @since 1.0.0.0 -} redactNonIdentifierValue :: ErrorDetailLevel -> String -> String redactNonIdentifierValue detailLevel nonIdValue = diff --git a/src/Orville/PostgreSQL/Execution/Cursor.hs b/src/Orville/PostgreSQL/Execution/Cursor.hs --- a/src/Orville/PostgreSQL/Execution/Cursor.hs +++ b/src/Orville/PostgreSQL/Execution/Cursor.hs @@ -51,8 +51,7 @@ import Orville.PostgreSQL.Marshall (AnnotatedSqlMarshaller) import qualified Orville.PostgreSQL.Monad as Monad -{- | - A 'Cursor' allows you to fetch rows incrementally from PostgreSQL. Using +{- | A 'Cursor' allows you to fetch rows incrementally from PostgreSQL. Using a cursor will allow you to execute a query that returns a very large result set without the entire result set being loaded in memory in your application and instead pulling rows as you're able to process them. @@ -68,8 +67,7 @@ Expr.CursorName -> Cursor readEntity -{- | - Declares a @CURSOR@ in PostgreSQL that is available for the duration of the +{- | Declares a @CURSOR@ in PostgreSQL that is available for the duration of the action passed to 'withCursor' and closes the cursor when that action completes (or raises an exception). @@ -90,14 +88,12 @@ Select readEntity -> (Cursor readEntity -> m a) -> m a -withCursor scrollExpr holdExpr select useCursor = +withCursor scrollExpr holdExpr select = Bracket.bracketWithResult (declareCursor scrollExpr holdExpr select) (\cursor _bracketResult -> closeCursor cursor) - useCursor -{- | - Declares a @CURSOR@ in PostgreSQL and returns it for you to use. The cursor +{- | Declares a @CURSOR@ in PostgreSQL and returns it for you to use. The cursor must be closed via 'closeCursor' (or another means) when you are done using it. Generally you should use 'withCursor' instead of 'declareCursor' to ensure that the cursor gets closed properly. @@ -125,8 +121,7 @@ _ <- Execute.executeVoid QueryType.CursorQuery declareExpr pure (Cursor marshaller cursorName) -{- | - Closes a @CURSOR@ in PostgreSQL that was previously declared. +{- | Closes a @CURSOR@ in PostgreSQL that was previously declared. This should be used to close any cursors you open via 'declareCursor', though we recommend you use 'withCursor' instead to ensure that any opened cursors are closed in the event of an exception. @@ -143,8 +138,7 @@ . Right $ cursorName -{- | - Fetch rows from a cursor according to the 'Expr.CursorDirection' given. See +{- | Fetch rows from a cursor according to the 'Expr.CursorDirection' given. See @https://www.postgresql.org/docs/current/sql-fetch.html@ for details about the effects of fetch and the meanings of cursor directions to PostgreSQL. @@ -161,8 +155,7 @@ (Expr.fetch direction cursorName) marshaller -{- | - Moves a cursor according to the 'Expr.CursorDirection' given. See +{- | Moves a cursor according to the 'Expr.CursorDirection' given. See @https://www.postgresql.org/docs/current/sql-fetch.html@ for details about the effect of move and the meanings of cursor directions to PostgreSQL. @@ -178,8 +171,7 @@ QueryType.CursorQuery (Expr.move direction cursorName) -{- | - INTERNAL - Generates a unique (or very nearly guaranteed to be) cursor name. +{- | INTERNAL - Generates a unique (or very nearly guaranteed to be) cursor name. Cursor names only need to be unique among the currently-open cursors on the current connection, so using POSIX time plus a 32-bit random tag should be more than sufficient to ensure conflicts are not seen in practice. diff --git a/src/Orville/PostgreSQL/Execution/Delete.hs b/src/Orville/PostgreSQL/Execution/Delete.hs --- a/src/Orville/PostgreSQL/Execution/Delete.hs +++ b/src/Orville/PostgreSQL/Execution/Delete.hs @@ -35,8 +35,7 @@ import qualified Orville.PostgreSQL.Monad as Monad import Orville.PostgreSQL.Schema (TableDefinition, mkTableReturningClause, tableMarshaller, tableName) -{- | -Represents a @DELETE@ statement that can be executed against a database. A +{- | Represents a @DELETE@ statement that can be executed against a database. A 'Delete' has a 'Orville.PostgreSQL.SqlMarshaller' bound to it that, when the delete returns data from the database, will be used to decode the database result set when it is executed. @@ -49,8 +48,7 @@ Delete readEntity NoReturningClause DeleteReturning :: AnnotatedSqlMarshaller writeEntity readEntity -> Expr.DeleteExpr -> Delete readEntity ReturningClause -{- | - Extracts the query that will be run when the delete is executed. Normally you +{- | Extracts the query that will be run when the delete is executed. Normally you don't want to extract the query and run it yourself, but this function is useful to view the query for debugging or query explanation. @@ -60,8 +58,7 @@ deleteFromDeleteExpr (Delete expr) = expr deleteFromDeleteExpr (DeleteReturning _ expr) = expr -{- | - Executes the database query for the 'Delete' and returns the number of +{- | Executes the database query for the 'Delete' and returns the number of rows affected by the query. @since 1.0.0.0 @@ -73,8 +70,7 @@ executeDelete (Delete expr) = Execute.executeAndReturnAffectedRows QueryType.DeleteQuery expr -{- | -Executes the database query for the 'Delete' and uses its +{- | Executes the database query for the 'Delete' and uses its 'Orville.PostgreSQL.SqlMarshaller' to decode the rows (that were just deleted) as returned via a RETURNING clause. @@ -87,8 +83,7 @@ executeDeleteReturnEntities (DeleteReturning marshaller expr) = Execute.executeAndDecode QueryType.DeleteQuery expr marshaller -{- | - Builds a 'Delete' that will delete all of the writable columns described in the +{- | Builds a 'Delete' that will delete all of the writable columns described in the 'TableDefinition' without returning the data as seen by the database. @since 1.0.0.0 @@ -100,8 +95,7 @@ deleteFromTable = deleteTable WithoutReturning -{- | - Builds a 'Delete' that will delete all of the writable columns described in the +{- | Builds a 'Delete' that will delete all of the writable columns described in the 'TableDefinition' and return the data as seen by the database. This is useful for getting database-managed columns such as auto-incrementing identifiers and sequences. @@ -130,8 +124,7 @@ in rawDeleteExpr returningOption (tableMarshaller tableDef) deleteExpr -{- | - Builds a 'Delete' that will execute the specified query and use the given +{- | Builds a 'Delete' that will execute the specified query and use the given 'Orville.PostgreSQL.SqlMarshaller' to decode it. It is up to the caller to ensure that the given 'Expr.DeleteExpr' makes sense and returns a result that the 'Orville.PostgreSQL.SqlMarshaller' can decode. diff --git a/src/Orville/PostgreSQL/Execution/EntityOperations.hs b/src/Orville/PostgreSQL/Execution/EntityOperations.hs --- a/src/Orville/PostgreSQL/Execution/EntityOperations.hs +++ b/src/Orville/PostgreSQL/Execution/EntityOperations.hs @@ -51,8 +51,7 @@ import qualified Orville.PostgreSQL.Monad as Monad import qualified Orville.PostgreSQL.Schema as Schema -{- | - Inserts an entity into the specified table. +{- | Inserts an entity into the specified table. @since 1.0.0.0 -} @@ -64,8 +63,7 @@ insertEntity entityTable = Monad.void . insertEntityAndReturnRowCount entityTable -{- | - Inserts an entity into the specified table. Returns the number of rows +{- | Inserts an entity into the specified table. Returns the number of rows affected by the query. @since 1.0.0.0 @@ -78,8 +76,7 @@ insertEntityAndReturnRowCount entityTable entity = insertEntitiesAndReturnRowCount entityTable (entity :| []) -{- | - Inserts an entity into the specified table, returning the data inserted into +{- | Inserts an entity into the specified table, returning the data inserted into the database. You can use this function to obtain any column values filled in by the @@ -99,8 +96,7 @@ "insertAndReturnEntity RETURNING clause" returnedEntities -{- | - Inserts a non-empty list of entities into the specified table. +{- | Inserts a non-empty list of entities into the specified table. @since 1.0.0.0 -} @@ -112,8 +108,7 @@ insertEntities tableDef = Monad.void . insertEntitiesAndReturnRowCount tableDef -{- | - Inserts a non-empty list of entities into the specified table. Returns the +{- | Inserts a non-empty list of entities into the specified table. Returns the number of rows affected by the query. @since 1.0.0.0 @@ -126,8 +121,7 @@ insertEntitiesAndReturnRowCount tableDef = Insert.executeInsert . Insert.insertToTable tableDef -{- | - Inserts a non-empty list of entities into the specified table, returning the data that +{- | Inserts a non-empty list of entities into the specified table, returning the data that was inserted into the database. You can use this function to obtain any column values filled in by the @@ -143,8 +137,7 @@ insertAndReturnEntities tableDef = Insert.executeInsertReturnEntities . Insert.insertToTableReturning tableDef -{- | - Updates the row with the given key with the data given by @writeEntity@. +{- | Updates the row with the given key with the data given by @writeEntity@. @since 1.0.0.0 -} @@ -157,8 +150,7 @@ updateEntity tableDef key = Monad.void . updateEntityAndReturnRowCount tableDef key -{- | - Updates the row with the given key with the data given by @writeEntity@. +{- | Updates the row with the given key with the data given by @writeEntity@. Returns the number of rows affected by the query. @since 1.0.0.0 @@ -176,8 +168,7 @@ Just update -> Update.executeUpdate update -{- | - Updates the row with the given key with the data given by @writeEntity@, +{- | Updates the row with the given key with the data given by @writeEntity@, returning the updated row from the database. If no row matches the given key, 'Nothing' will be returned. @@ -202,8 +193,7 @@ "updateAndReturnEntity RETURNING clause" returnedEntities -{- | - Applies the given 'Expr.SetClause's to the rows in the table that match the +{- | Applies the given 'Expr.SetClause's to the rows in the table that match the given where condition. The easiest way to construct a 'Expr.SetClause' is via the 'Orville.Postgresql.setField' function (also exported as @.:=@). @@ -218,8 +208,7 @@ updateFields tableDef setClauses = Monad.void . updateFieldsAndReturnRowCount tableDef setClauses -{- | - Applies the given 'Expr.SetClause's to the rows in the table that match the +{- | Applies the given 'Expr.SetClause's to the rows in the table that match the given where condition. The easiest way to construct a 'Expr.SetClause' is via the 'Orville.Postgresql.setField' function (also exported as @.:=@). Returns the number of rows affected by the query. @@ -236,8 +225,7 @@ Update.executeUpdate $ Update.updateToTableFields tableDef setClauses mbWhereCondition -{- | - Like 'updateFields', but uses a @RETURNING@ clause to return the updated +{- | Like 'updateFields', but uses a @RETURNING@ clause to return the updated version of any rows that were affected by the update. @since 1.0.0.0 @@ -252,8 +240,7 @@ Update.executeUpdateReturnEntities $ Update.updateToTableFieldsReturning tableDef setClauses mbWhereCondition -{- | - Deletes the row with the given key. +{- | Deletes the row with the given key. @since 1.0.0.0 -} @@ -265,8 +252,7 @@ deleteEntity entityTable = Monad.void . deleteEntityAndReturnRowCount entityTable -{- | - Deletes the row with the given key. Returns the number of rows affected +{- | Deletes the row with the given key. Returns the number of rows affected by the query. @since 1.0.0.0 @@ -286,8 +272,7 @@ Delete.executeDelete $ Delete.deleteFromTable entityTable (Just primaryKeyCondition) -{- | - Deletes the row with the given key, returning the row that was deleted. +{- | Deletes the row with the given key, returning the row that was deleted. If no row matches the given key, 'Nothing' is returned. @since 1.0.0.0 @@ -310,8 +295,7 @@ "deleteAndReturnEntity RETURNING clause" returnedEntities -{- | - Deletes all rows in the given table that match the where condition. +{- | Deletes all rows in the given table that match the where condition. @since 1.0.0.0 -} @@ -323,8 +307,7 @@ deleteEntities entityTable = Monad.void . deleteEntitiesAndReturnRowCount entityTable -{- | - Deletes all rows in the given table that match the where condition. Returns +{- | Deletes all rows in the given table that match the where condition. Returns the number of rows affected by the query. @since 1.0.0.0 @@ -338,8 +321,7 @@ Delete.executeDelete $ Delete.deleteFromTable entityTable whereCondition -{- | - Deletes all rows in the given table that match the where condition, returning +{- | Deletes all rows in the given table that match the where condition, returning the rows that were deleted. @since 1.0.0.0 @@ -353,8 +335,7 @@ Delete.executeDeleteReturnEntities $ Delete.deleteFromTableReturning entityTable whereCondition -{- | - Finds all the entities in the given table according to the specified +{- | Finds all the entities in the given table according to the specified 'SelectOptions.SelectOptions', which may include where conditions to match, ordering specifications, etc. @@ -369,8 +350,7 @@ Select.executeSelect $ Select.selectTable entityTable selectOptions -{- | - Like 'findEntitiesBy', but adds a 'LIMIT 1' to the query and then returns +{- | Like 'findEntitiesBy', but adds a 'LIMIT 1' to the query and then returns the first item from the list. Usually when you use this you will want to provide an order by clause in the 'SelectOptions.SelectOptions' because the database will not guarantee ordering. @@ -386,8 +366,7 @@ listToMaybe <$> findEntitiesBy entityTable (SelectOptions.limit 1 <> selectOptions) -{- | - Finds a single entity by the table's primary key value. +{- | Finds a single entity by the table's primary key value. @since 1.0.0.0 -} @@ -405,8 +384,7 @@ in findFirstEntityBy entityTable (SelectOptions.where_ primaryKeyCondition) -{- | - Finds multiple entities by the table's primary key. +{- | Finds multiple entities by the table's primary key. @since 1.0.0.0 -} @@ -424,8 +402,7 @@ in findEntitiesBy entityTable (SelectOptions.where_ primaryKeyCondition) -{- | - Thrown by 'updateFields' and 'updateFieldsAndReturnEntities' if the +{- | Thrown by 'updateFields' and 'updateFieldsAndReturnEntities' if the 'Schema.TableDefinition' they are given has no columns to update. @since 1.0.0.0 diff --git a/src/Orville/PostgreSQL/Execution/Execute.hs b/src/Orville/PostgreSQL/Execution/Execute.hs --- a/src/Orville/PostgreSQL/Execution/Execute.hs +++ b/src/Orville/PostgreSQL/Execution/Execute.hs @@ -32,8 +32,7 @@ import qualified Orville.PostgreSQL.Raw.SqlCommenter as SqlCommenter import qualified Orville.PostgreSQL.Raw.SqlValue as SqlValue -{- | - Executes a SQL query and decodes the result set using the provided +{- | Executes a SQL query and decodes the result set using the provided marshaller. Any SQL Execution callbacks that have been added to the 'OrvilleState' will be called. @@ -52,8 +51,7 @@ orvilleState <- askOrvilleState withConnection (liftIO . executeAndDecodeIO queryType sql marshaller orvilleState) -{- | - Executes a SQL query and returns the number of rows affected by the query. +{- | Executes a SQL query and returns the number of rows affected by the query. Any SQL Execution callbacks that have been added to the 'OrvilleState' will be called. @@ -76,8 +74,7 @@ orvilleState <- askOrvilleState withConnection (liftIO . executeAndReturnAffectedRowsIO queryType sql orvilleState) -{- | - Executes a SQL query and ignores the result. Any SQL Execution callbacks +{- | Executes a SQL query and ignores the result. Any SQL Execution callbacks that have been added to the 'OrvilleState' will be called. If the query fails an exception will be raised. @@ -93,8 +90,7 @@ orvilleState <- askOrvilleState withConnection (liftIO . executeVoidIO queryType sql orvilleState) -{- | - Executes a SQL query and decodes the result set using the provided +{- | Executes a SQL query and decodes the result set using the provided marshaller. Any SQL Execution callbacks that have been added to the 'OrvilleState' will be called. @@ -129,8 +125,7 @@ Right entities -> pure entities -{- | - Executes a SQL query and returns the number of rows affected by the query. +{- | Executes a SQL query and returns the number of rows affected by the query. Any SQL Execution callbacks that have been added to the 'OrvilleState' will be called. @@ -166,8 +161,7 @@ Right n -> pure n -{- | - Executes a SQL query and ignores the result. Any SQL Execution callbacks +{- | Executes a SQL query and ignores the result. Any SQL Execution callbacks that have been added to the 'OrvilleState' will be called. If the query fails, an exception will be raised. @@ -206,8 +200,7 @@ rawSql (RawSql.execute conn rawSql) -{- | - Thrown by 'executeAndReturnAffectedRows' and 'executeAndReturnAffectedRowsIO' +{- | Thrown by 'executeAndReturnAffectedRows' and 'executeAndReturnAffectedRowsIO' if the number of affected rows cannot be successfully read from the LibPQ command result. diff --git a/src/Orville/PostgreSQL/Execution/ExecutionResult.hs b/src/Orville/PostgreSQL/Execution/ExecutionResult.hs --- a/src/Orville/PostgreSQL/Execution/ExecutionResult.hs +++ b/src/Orville/PostgreSQL/Execution/ExecutionResult.hs @@ -1,7 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {- | -Copyright : Flipstone Technology Partners 2023 +Copyright : Flipstone Technology Partners 2023-2025 License : MIT Stability : Stable @@ -25,8 +25,7 @@ import Orville.PostgreSQL.Raw.SqlValue (SqlValue) import qualified Orville.PostgreSQL.Raw.SqlValue as SqlValue -{- | - A trivial wrapper for `Int` to help keep track of column vs row number. +{- | A trivial wrapper for `Int` to help keep track of column vs row number. @since 1.0.0.0 -} @@ -43,8 +42,7 @@ Num ) -{- | - A trivial wrapper for `Int` to help keep track of column vs row number. +{- | A trivial wrapper for `Int` to help keep track of column vs row number. @since 1.0.0.0 -} @@ -61,8 +59,7 @@ Num ) -{- | - 'ExecutionResult' is a common interface for types that represent a result set +{- | 'ExecutionResult' is a common interface for types that represent a result set returned from the database. For real, live database interactions, the concrete type will be a 'LibPQ.Result', but the 'FakeLibPQResult' may be useful as well if you are writing custom code for decoding result sets and @@ -76,8 +73,7 @@ columnName :: result -> Column -> IO (Maybe BS.ByteString) getValue :: result -> Row -> Column -> IO SqlValue -{- | - Reads the rows of an 'ExecutionResult' as a list of column name, 'SqlValue' +{- | Reads the rows of an 'ExecutionResult' as a list of column name, 'SqlValue' pairs. You're almost always better off using a 'Orville.PostgreSQL.SqlMarshaller' instead, but this function is provided for cases where you really want to decode the rows yourself but don't want to use @@ -107,7 +103,7 @@ readValue rowIndex columnIndex = do name <- columnName res columnIndex value <- getValue res rowIndex columnIndex - pure $ (name, value) + pure (name, value) readRow rowIndex = traverse (readValue rowIndex) columnIndices @@ -140,8 +136,7 @@ SqlValue.fromRawBytesNullable <$> LibPQ.getvalue' result (LibPQ.toRow row) (LibPQ.toColumn column) -{- | - `FakeLibPQResult` provides a fake, in-memory implementation of +{- | `FakeLibPQResult` provides a fake, in-memory implementation of `ExecutionResult`. This is mostly useful for writing automated tests that can assume a result set has been loaded and you just need to test decoding the results. @@ -160,8 +155,7 @@ columnName result = pure . fakeLibPQColumnName result getValue result column = pure . fakeLibPQGetValue result column -{- | - Constructs a `FakeLibPQResult`. The column names given are associated with +{- | Constructs a `FakeLibPQResult`. The column names given are associated with the values for each row by their position in-list. Any missing values (e.g. because a row is shorter than the header list) are treated as a SQL Null value. @@ -197,7 +191,7 @@ fakeLibPQMaxColumn result = let maxColumnsByRow = - map fst + fmap fst . Maybe.mapMaybe Map.lookupMax . Map.elems . fakeLibPQRows @@ -209,7 +203,7 @@ _ -> Just (maximum maxColumnsByRow) -fakeLibPQColumnName :: FakeLibPQResult -> Column -> (Maybe BS.ByteString) +fakeLibPQColumnName :: FakeLibPQResult -> Column -> Maybe BS.ByteString fakeLibPQColumnName result column = Map.lookup column (fakeLibPQColumns result) diff --git a/src/Orville/PostgreSQL/Execution/Insert.hs b/src/Orville/PostgreSQL/Execution/Insert.hs --- a/src/Orville/PostgreSQL/Execution/Insert.hs +++ b/src/Orville/PostgreSQL/Execution/Insert.hs @@ -38,8 +38,7 @@ import qualified Orville.PostgreSQL.Monad as Monad import Orville.PostgreSQL.Schema (TableDefinition, mkInsertExpr, tableMarshaller) -{- | -Represents an @INSERT@ statement that can be executed against a database. An +{- | Represents an @INSERT@ statement that can be executed against a database. An 'Insert' has a 'Orville.PostgreSQL.SqlMarshaller' bound to it that, when the insert returns data from the database, will be used to decode the database result set when it is executed. @@ -53,8 +52,7 @@ Insert readEntity NoReturningClause InsertReturning :: AnnotatedSqlMarshaller writeEntity readEntity -> Expr.InsertExpr -> Insert readEntity ReturningClause -{- | - Extracts the query that will be run when the insert is executed. Normally you +{- | Extracts the query that will be run when the insert is executed. Normally you don't want to extract the query and run it yourself, but this function is useful to view the query for debugging or query explanation. @@ -64,8 +62,7 @@ insertToInsertExpr (Insert _ expr) = expr insertToInsertExpr (InsertReturning _ expr) = expr -{- | - Executes the database query for the 'Insert' and returns the number of rows +{- | Executes the database query for the 'Insert' and returns the number of rows affected by the query. @since 1.0.0.0 @@ -77,8 +74,7 @@ executeInsert (Insert _ expr) = Execute.executeAndReturnAffectedRows QueryType.InsertQuery expr -{- | -Executes the database query for the 'Insert' and uses its +{- | Executes the database query for the 'Insert' and uses its 'Orville.PostgreSQL.SqlMarshaller' to decode the rows (that were just inserted) as returned via a RETURNING clause. @@ -91,8 +87,7 @@ executeInsertReturnEntities (InsertReturning marshaller expr) = Execute.executeAndDecode QueryType.InsertQuery expr marshaller -{- | - Builds an 'Insert' that will insert all of the writable columns described in the +{- | Builds an 'Insert' that will insert all of the writable columns described in the 'TableDefinition' without returning the data as seen by the database. @since 1.0.0.0 @@ -104,8 +99,7 @@ insertToTable = insertTable WithoutReturning -{- | - Builds an 'Insert' that will insert all of the writable columns described in the +{- | Builds an 'Insert' that will insert all of the writable columns described in the 'TableDefinition' and return the data as seen by the database. This is useful for getting database-managed columns such as auto-incrementing identifiers and sequences. @@ -125,10 +119,9 @@ NonEmpty writeEntity -> Insert readEntity returningClause insertTable returningOption tableDef entities = - rawInsertExpr returningOption (tableMarshaller tableDef) (mkInsertExpr returningOption tableDef entities) + rawInsertExpr returningOption (tableMarshaller tableDef) (mkInsertExpr returningOption tableDef Nothing entities) -{- | - Builds an 'Insert' that will execute the specified query and use the given +{- | Builds an 'Insert' that will execute the specified query and use the given 'Orville.PostgreSQL.SqlMarshaller' to decode it. It is up to the caller to ensure that the given 'Expr.InsertExpr' makes sense and produces a value that can be stored, as well as returning a result that the diff --git a/src/Orville/PostgreSQL/Execution/QueryType.hs b/src/Orville/PostgreSQL/Execution/QueryType.hs --- a/src/Orville/PostgreSQL/Execution/QueryType.hs +++ b/src/Orville/PostgreSQL/Execution/QueryType.hs @@ -10,8 +10,7 @@ ) where -{- | - A simple categorization of SQL queries that is used to provide a hint to +{- | A simple categorization of SQL queries that is used to provide a hint to user callbacks about what kind of query is being run. See 'Orville.PostgreSQL.addSqlExecutionCallback' diff --git a/src/Orville/PostgreSQL/Execution/ReturningOption.hs b/src/Orville/PostgreSQL/Execution/ReturningOption.hs --- a/src/Orville/PostgreSQL/Execution/ReturningOption.hs +++ b/src/Orville/PostgreSQL/Execution/ReturningOption.hs @@ -26,10 +26,10 @@ -} data NoReturningClause -{- | - Specifies whether or not a @RETURNING@ clause should be included when a +{- | Specifies whether or not a @RETURNING@ clause should be included when a query expression is built. This type is found as a parameter on a number of the query-building functions related to 'Orville.PostgreSQL.TableDefinition'. + @since 1.0.0.0 -} data ReturningOption clause where diff --git a/src/Orville/PostgreSQL/Execution/Select.hs b/src/Orville/PostgreSQL/Execution/Select.hs --- a/src/Orville/PostgreSQL/Execution/Select.hs +++ b/src/Orville/PostgreSQL/Execution/Select.hs @@ -2,7 +2,7 @@ {-# LANGUAGE RankNTypes #-} {- | -Copyright : Flipstone Technology Partners 2023 +Copyright : Flipstone Technology Partners 2023-2025 License : MIT Stability : Stable @@ -35,8 +35,7 @@ import qualified Orville.PostgreSQL.Monad as Monad import Orville.PostgreSQL.Schema (TableDefinition, tableMarshaller, tableName) -{- | - Represents a @SELECT@ statement that can be executed against a database. A +{- | Represents a @SELECT@ statement that can be executed against a database. A 'Select' has a 'Orville.PostgreSQL.SqlMarshaller' bound to it that will be used to decode the database result set when it is executed. @@ -45,8 +44,7 @@ data Select readEntity where Select :: AnnotatedSqlMarshaller writeEntity readEntity -> Expr.QueryExpr -> Select readEntity -{- | - Extracts the query that will be run when the select is executed. Normally you +{- | Extracts the query that will be run when the select is executed. Normally you don't want to extract the query and run it yourself, but this function is useful to view the query for debugging or query explanation. @@ -55,8 +53,7 @@ selectToQueryExpr :: Select readEntity -> Expr.QueryExpr selectToQueryExpr (Select _ query) = query -{- | - Executes the database query for the 'Select' and uses its +{- | Executes the database query for the 'Select' and uses its 'Orville.PostgreSQL.SqlMarshaller' to decode the result set. @since 1.0.0.0 @@ -65,8 +62,7 @@ executeSelect = useSelect (Execute.executeAndDecode QueryType.SelectQuery) -{- | - Runs a function allowing it to use the data elements containted within the +{- | Runs a function allowing it to use the data elements containted within the 'Select' it pleases. The marshaller that the function is provided can be use to decode results from the query. @@ -83,8 +79,7 @@ useSelect f (Select marshaller query) = f query marshaller -{- | - Builds a 'Select' that will select all the columns described in the +{- | Builds a 'Select' that will select all the columns described in the 'TableDefinition'. This is the safest way to build a 'Select', because table name and columns are all read from the 'TableDefinition'. If the table is being managed with Orville auto-migrations, this will match the schema in the @@ -99,8 +94,7 @@ selectTable tableDef = selectMarshalledColumns (tableMarshaller tableDef) (tableName tableDef) -{- | - Builds a 'Select' that will select the columns described by the marshaller +{- | Builds a 'Select' that will select the columns described by the marshaller from the specified table. It is up to the caller to ensure that the columns in the marshaller make sense for the table. @@ -111,18 +105,17 @@ -} selectMarshalledColumns :: AnnotatedSqlMarshaller writeEntity readEntity -> - Expr.Qualified Expr.TableName -> + Expr.QualifiedOrUnqualified Expr.TableName -> SelectOptions.SelectOptions -> Select readEntity selectMarshalledColumns marshaller qualifiedTableName selectOptions = rawSelectQueryExpr marshaller $ SelectOptions.selectOptionsQueryExpr (Expr.selectDerivedColumns (marshallerDerivedColumns . unannotatedSqlMarshaller $ marshaller)) - (Expr.referencesTable qualifiedTableName) + (Expr.singleTableReferenceList qualifiedTableName) selectOptions -{- | - Builds a 'Select' that will execute the specified query and use the given +{- | Builds a 'Select' that will execute the specified query and use the given 'Orville.PostgreSQL.SqlMarshaller' to decode it. It is up to the caller to ensure that the given 'Expr.QueryExpr' makes sense and produces a result set that the 'Orville.PostgreSQL.SqlMarshaller' can decode. diff --git a/src/Orville/PostgreSQL/Execution/SelectOptions.hs b/src/Orville/PostgreSQL/Execution/SelectOptions.hs --- a/src/Orville/PostgreSQL/Execution/SelectOptions.hs +++ b/src/Orville/PostgreSQL/Execution/SelectOptions.hs @@ -1,5 +1,5 @@ {- | -Copyright : Flipstone Technology Partners 2023 +Copyright : Flipstone Technology Partners 2023-2025 License : MIT Stability : Stable @@ -15,12 +15,18 @@ , selectGroupByClause , selectLimitExpr , selectOffsetExpr + , selectRowLockingClause + , selectWindowClause + , selectFetchClause , distinct , where_ , orderBy , limit , offset , groupBy + , forRowLock + , window + , fetchRow , selectOptionsQueryExpr ) where @@ -29,8 +35,7 @@ import qualified Orville.PostgreSQL.Expr as Expr -{- | - A 'SelectOptions' is a set of options that can be used to change the way +{- | A 'SelectOptions' is a set of options that can be used to change the way a basic query function works by adding @WHERE@, @ORDER BY@, @GROUP BY@, etc. Functions are provided to construct 'SelectOptions' for individual options, which may then be combined via '<>' (also exposed as 'appendSelectOptions'). @@ -44,6 +49,9 @@ , i_limitExpr :: First Expr.LimitExpr , i_offsetExpr :: First Expr.OffsetExpr , i_groupByExpr :: Maybe Expr.GroupByExpr + , i_rowLockingClause :: First Expr.RowLockingClause + , i_windowExpr :: Maybe Expr.NamedWindowDefinitionExpr + , i_fetchClause :: First Expr.FetchClause } -- | @since 1.0.0.0 @@ -54,8 +62,7 @@ instance Monoid SelectOptions where mempty = emptySelectOptions -{- | - A set of empty 'SelectOptions' that will not change how a query is run. +{- | A set of empty 'SelectOptions' that will not change how a query is run. @since 1.0.0.0 -} @@ -68,10 +75,12 @@ , i_limitExpr = mempty , i_offsetExpr = mempty , i_groupByExpr = mempty + , i_rowLockingClause = mempty + , i_windowExpr = Nothing + , i_fetchClause = mempty } -{- | - Combines multple select options together, unioning the options together where +{- | Combines multple select options together, unioning the options together where possible. For options where this is not possible (e.g. @LIMIT@), the one on the left is preferred. @@ -86,6 +95,9 @@ (i_limitExpr left <> i_limitExpr right) (i_offsetExpr left <> i_offsetExpr right) (i_groupByExpr left <> i_groupByExpr right) + (i_rowLockingClause left <> i_rowLockingClause right) + (i_windowExpr left <> i_windowExpr right) + (i_fetchClause left <> i_fetchClause right) unionMaybeWith :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a unionMaybeWith f mbLeft mbRight = @@ -95,8 +107,7 @@ (Nothing, Just right) -> Just right (Just left, Just right) -> Just (f left right) -{- | - Builds the 'Expr.SelectClause' that should be used to include the +{- | Builds the 'Expr.SelectClause' that should be used to include the 'distinct's from the 'SelectOptions' on a query. @since 1.0.0.0 @@ -107,8 +118,7 @@ First (Just True) -> Expr.selectClause . Expr.selectExpr $ Just Expr.Distinct _ -> Expr.selectClause $ Expr.selectExpr Nothing -{- | - Builds the 'Expr.WhereClause' that should be used to include the +{- | Builds the 'Expr.WhereClause' that should be used to include the 'Expr.BooleanExpr's from the 'SelectOptions' on a query. This will be 'Nothing' when no 'Expr.BooleanExpr's have been specified. @@ -118,8 +128,7 @@ selectWhereClause = fmap Expr.whereClause . i_whereCondition -{- | - Constructs a 'SelectOptions' with just 'distinct' set to 'True'. +{- | Constructs a 'SelectOptions' with just 'distinct' set to 'True'. @since 1.0.0.0 -} @@ -129,8 +138,7 @@ { i_distinct = First $ Just True } -{- | - Builds the 'Expr.OrderByClause' that should be used to include the +{- | Builds the 'Expr.OrderByClause' that should be used to include the 'Expr.OrderByClause's from the 'SelectOptions' on a query. This will be 'Nothing' when no 'Expr.OrderByClause's have been specified. @@ -140,8 +148,7 @@ selectOrderByClause = fmap Expr.orderByClause . i_orderBy -{- | - Builds the 'Expr.GroupByClause' that should be used to include the +{- | Builds the 'Expr.GroupByClause' that should be used to include the 'Expr.GroupByClause's from the 'SelectOptions' on a query. This will be 'Nothing' when no 'Expr.GroupByClause's have been specified. @@ -151,8 +158,7 @@ selectGroupByClause = fmap Expr.groupByClause . i_groupByExpr -{- | - Builds a 'Expr.LimitExpr' that will limit the query results to the +{- | Builds a 'Expr.LimitExpr' that will limit the query results to the number specified in the 'SelectOptions' (if any). @since 1.0.0.0 @@ -161,8 +167,7 @@ selectLimitExpr = getFirst . i_limitExpr -{- | - Builds an 'Expr.OffsetExpr' that will limit the query results to the +{- | Builds an 'Expr.OffsetExpr' that will limit the query results to the number specified in the 'SelectOptions' (if any). @since 1.0.0.0 @@ -171,9 +176,32 @@ selectOffsetExpr = getFirst . i_offsetExpr -{- | - Constructs a 'SelectOptions' with just the given 'Expr.BooleanExpr'. +{- | Builds an 'Expr.RowLockingClause' that will apply the locking rules specified in the 'SelectOptions' (if any). +@since 1.1.0.0 +-} +selectRowLockingClause :: SelectOptions -> Maybe Expr.RowLockingClause +selectRowLockingClause = + getFirst . i_rowLockingClause + +{- | Builds an 'Expr.WindowClause' that will apply the windowing rules specified in the 'SelectOptions' (if any). + +@since 1.1.0.0 +-} +selectWindowClause :: SelectOptions -> Maybe Expr.WindowClause +selectWindowClause = + fmap Expr.windowClause . i_windowExpr + +{- | Builds an 'Expr.FetchClause' that will apply the fetching rules specified in the 'SelectOptions' (if any). + +@since 1.1.0.0 +-} +selectFetchClause :: SelectOptions -> Maybe Expr.FetchClause +selectFetchClause = + getFirst . i_fetchClause + +{- | Constructs a 'SelectOptions' with just the given 'Expr.BooleanExpr'. + @since 1.0.0.0 -} where_ :: Expr.BooleanExpr -> SelectOptions @@ -182,8 +210,7 @@ { i_whereCondition = Just condition } -{- | - Constructs a 'SelectOptions' with just the given 'Expr.OrderByExpr'. +{- | Constructs a 'SelectOptions' with just the given 'Expr.OrderByExpr'. @since 1.0.0.0 -} @@ -193,8 +220,7 @@ { i_orderBy = Just order } -{- | - Constructs a 'SelectOptions' that will apply the given limit. +{- | Constructs a 'SelectOptions' that will apply the given limit. @since 1.0.0.0 -} @@ -204,8 +230,7 @@ { i_limitExpr = First . Just . Expr.limitExpr $ limitValue } -{- | - Constructs a 'SelectOptions' that will apply the given offset. +{- | Constructs a 'SelectOptions' that will apply the given offset. @since 1.0.0.0 -} @@ -215,8 +240,7 @@ { i_offsetExpr = First . Just . Expr.offsetExpr $ offsetValue } -{- | - Constructs a 'SelectOptions' with just the given 'Expr.GroupByClause'. +{- | Constructs a 'SelectOptions' with just the given 'Expr.GroupByExpr'. @since 1.0.0.0 -} @@ -226,8 +250,37 @@ { i_groupByExpr = Just groupByExpr } -{- | - Builds a 'Expr.QueryExpr' that will use the specified 'Expr.SelectList' when +{- | Constructs a 'SelectOptions' with just the given 'Expr.RowLockingClause'. + +@since 1.1.0.0 +-} +forRowLock :: Expr.RowLockingClause -> SelectOptions +forRowLock rowLockingClause = + emptySelectOptions + { i_rowLockingClause = First $ Just rowLockingClause + } + +{- | Constructs a 'SelectOptions' with just the given 'Expr.NamedWindowDefinitionExpr'. + +@since 1.1.0.0 +-} +window :: Expr.NamedWindowDefinitionExpr -> SelectOptions +window namedWindow = + emptySelectOptions + { i_windowExpr = Just namedWindow + } + +{- | Constructs a 'SelectOptions' with just the given 'Expr.FetchClause'. + +@since 1.1.0.0 +-} +fetchRow :: Expr.FetchClause -> SelectOptions +fetchRow fetchClause = + emptySelectOptions + { i_fetchClause = First $ Just fetchClause + } + +{- | Builds a 'Expr.QueryExpr' that will use the specified 'Expr.SelectList' when building the @SELECT@ statement to execute. It is up to the caller to make sure that the 'Expr.SelectList' expression makes sense for the table being queried, and that the names of the columns in the result set match those @@ -260,4 +313,7 @@ (selectOrderByClause selectOptions) (selectLimitExpr selectOptions) (selectOffsetExpr selectOptions) + (selectRowLockingClause selectOptions) + (selectWindowClause selectOptions) + (selectFetchClause selectOptions) ) diff --git a/src/Orville/PostgreSQL/Execution/Sequence.hs b/src/Orville/PostgreSQL/Execution/Sequence.hs --- a/src/Orville/PostgreSQL/Execution/Sequence.hs +++ b/src/Orville/PostgreSQL/Execution/Sequence.hs @@ -26,8 +26,7 @@ import qualified Orville.PostgreSQL.Monad as Monad import Orville.PostgreSQL.Schema (SequenceDefinition, sequenceName) -{- | - Fetches the next value from a sequence via the PostgreSQL @nextval@ function. +{- | Fetches the next value from a sequence via the PostgreSQL @nextval@ function. @since 1.0.0.0 -} @@ -37,8 +36,7 @@ "sequenceNextValue" (Expr.nextVal (sequenceName sequenceDef)) -{- | - Fetches the current value from a sequence via the PostgreSQL @currval@ function. +{- | Fetches the current value from a sequence via the PostgreSQL @currval@ function. @since 1.0.0.0 -} @@ -48,8 +46,7 @@ "sequenceCurrentValue" (Expr.currVal (sequenceName sequenceDef)) -{- | - Sets the current value from a sequence via the PostgreSQL @setval@ function. +{- | Sets the current value from a sequence via the PostgreSQL @setval@ function. @since 1.0.0.0 -} diff --git a/src/Orville/PostgreSQL/Execution/Transaction.hs b/src/Orville/PostgreSQL/Execution/Transaction.hs --- a/src/Orville/PostgreSQL/Execution/Transaction.hs +++ b/src/Orville/PostgreSQL/Execution/Transaction.hs @@ -1,5 +1,5 @@ {- | -Copyright : Flipstone Technology Partners 2023 +Copyright : Flipstone Technology Partners 2023-2025 License : MIT Stability : Stable @@ -10,10 +10,18 @@ -} module Orville.PostgreSQL.Execution.Transaction ( withTransaction + , withTransactionInstruction + , TransactionInstruction (Commit, Rollback) + , inWithTransaction + , InWithTransaction (InOutermostTransaction, InSavepointTransaction) + , UnexpectedTransactionStatusError (..) ) where -import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Exception (Exception, finally, onException, throwIO, try, uninterruptibleMask) +import Control.Monad.IO.Class (liftIO) +import qualified Database.PostgreSQL.LibPQ as LibPQ +import Numeric.Natural (Natural) import qualified Orville.PostgreSQL.Execution.Execute as Execute import qualified Orville.PostgreSQL.Execution.QueryType as QueryType @@ -22,25 +30,57 @@ import qualified Orville.PostgreSQL.Internal.MonadOrville as MonadOrville import qualified Orville.PostgreSQL.Internal.OrvilleState as OrvilleState import qualified Orville.PostgreSQL.Monad as Monad +import qualified Orville.PostgreSQL.Raw.Connection as Connection import qualified Orville.PostgreSQL.Raw.RawSql as RawSql -{- | - Performs an action in an Orville monad within a database transaction. The transaction +{- | Performs an action in an Orville monad within a database transaction. The transaction is begun before the action is called. If the action completes without raising an exception, the transaction will be committed. If the action raises an exception, the transaction will - rollback. + rollback. This is equivalent to calling 'withTransactionInstruction' and always returning + 'Commit' as the 'TransactionInstruction'. This function is safe to call from within another transaction. When called this way, the transaction will establish a new savepoint at the beginning of the nested transaction and either release the savepoint or rollback to it as appropriate. + See also: 'withTransactionInstruction' + Note: Exceptions are handled using the implementations of 'Monad.catch' and 'Monad.mask' provided by the 'Monad.MonadOrvilleControl' instance for @m@. @since 1.0.0.0 -} withTransaction :: Monad.MonadOrville m => m a -> m a -withTransaction action = +withTransaction = + withTransactionInstruction . fmap (\a -> (a, Commit)) + +{- | +Used with 'withTransactionInstruction' to indicate whether the transaction should be +committed or rolled back. + +@since 1.1.0.0 +-} +data TransactionInstruction = Commit | Rollback + +{- | Performs an action in an Orville monad within a database transaction. The transaction + is begun before the action is called. If the action completes without raising an exception, + the transaction will be it will either be commited or rolled back, depending on the + 'TransactionInstruction' returned by the action.. If the action raises an exception, the + transaction will rollback. + + This function is safe to call from within another transaction. When called this way, the + transaction will establish a new savepoint at the beginning of the nested transaction and + either release the savepoint or rollback to it as appropriate. + + See also: 'withTransaction' + + Note: Exceptions are handled using the implementations of 'Monad.catch' and + 'Monad.mask' provided by the 'Monad.MonadOrvilleControl' instance for @m@. + +@since 1.1.0.0 +-} +withTransactionInstruction :: Monad.MonadOrville m => m (a, TransactionInstruction) -> m a +withTransactionInstruction action = MonadOrville.withConnectedState $ \connectedState -> do let conn = OrvilleState.connectedConnection connectedState @@ -61,35 +101,116 @@ callback = OrvilleState.orvilleTransactionCallback state + beginTransaction :: IO () beginTransaction = do - liftIO $ do - let - openEvent = OrvilleState.openTransactionEvent transaction - executeTransactionSql (transactionEventSql state openEvent) - callback openEvent + status <- Connection.transactionStatusOrThrow conn + let + openEvent = OrvilleState.openTransactionEvent transaction + beginAction = do + executeTransactionSql (transactionEventSql state openEvent) + callback openEvent + transactionError = UnexpectedTransactionStatusError status openEvent + case status of + LibPQ.TransIdle -> case openEvent of + OrvilleState.BeginTransaction -> do + let + execRollback :: (IO () -> IO a) -> IO a + execRollback restore = do + executeTransactionSql (transactionEventSql state OrvilleState.RollbackTransaction) + restore $ callback OrvilleState.RollbackTransaction + rollback = uninterruptibleMask $ \restore -> do + postBeginStatus <- Connection.transactionStatusOrThrow conn + case postBeginStatus of + LibPQ.TransInTrans -> execRollback restore + LibPQ.TransInError -> execRollback restore + LibPQ.TransActive -> execRollback restore + LibPQ.TransIdle -> pure () + LibPQ.TransUnknown -> pure () + beginAction `onException` rollback + _ -> + throwIO transactionError + LibPQ.TransInTrans -> case openEvent of + OrvilleState.NewSavepoint _ -> + beginAction + _ -> + throwIO transactionError + LibPQ.TransActive -> + throwIO transactionError + LibPQ.TransInError -> + throwIO transactionError + LibPQ.TransUnknown -> + throwIO transactionError doAction () = Monad.localOrvilleState (OrvilleState.connectState innerConnectedState) action - finishTransaction :: MonadIO m => () -> Bracket.BracketResult -> m () - finishTransaction () result = - liftIO $ - case result of - Bracket.BracketSuccess -> do - let - successEvent = OrvilleState.transactionSuccessEvent transaction - executeTransactionSql (transactionEventSql state successEvent) - callback successEvent - Bracket.BracketError -> do - let - rollbackEvent = OrvilleState.rollbackTransactionEvent transaction - executeTransactionSql (transactionEventSql state rollbackEvent) - callback rollbackEvent + finishTransaction :: Bracket.BracketResult (a, TransactionInstruction) -> IO () + finishTransaction result = uninterruptibleMask $ \restore -> do + status <- Connection.transactionStatusOrThrow conn + let + successEvent = OrvilleState.transactionSuccessEvent transaction + rollbackEvent = OrvilleState.rollbackTransactionEvent transaction + rollback = do + executeTransactionSql (transactionEventSql state rollbackEvent) + restore $ callback rollbackEvent + transactionError = UnexpectedTransactionStatusError status $ case result of + Bracket.BracketSuccess (_, Commit) -> successEvent + Bracket.BracketSuccess (_, Rollback) -> rollbackEvent + Bracket.BracketError -> rollbackEvent + case status of + LibPQ.TransInTrans -> case result of + Bracket.BracketSuccess (_, Commit) -> do + eSuccess <- try $ executeTransactionSql (transactionEventSql state successEvent) + case eSuccess of + Right () -> + restore $ callback successEvent + Left ex -> do + restore (callback rollbackEvent) `finally` throwIO (ex :: Connection.SqlExecutionError) + Bracket.BracketSuccess (_, Rollback) -> do + rollback + Bracket.BracketError -> + rollback + LibPQ.TransInError -> + rollback + LibPQ.TransActive -> + throwIO transactionError + LibPQ.TransIdle -> + throwIO transactionError + LibPQ.TransUnknown -> + throwIO transactionError - Bracket.bracketWithResult beginTransaction finishTransaction doAction + fmap fst $ + Bracket.bracketWithResult + (liftIO beginTransaction) + (const $ liftIO . finishTransaction) + doAction +{- | 'withTransaction' will throw this exception if libpq reports a transaction status on the underlying + connection that is incompatible with the current transaction event. + +@since 1.1.0.0 +-} +data UnexpectedTransactionStatusError = UnexpectedTransactionStatusError + { unexpectedTransactionStatusErrorTransactionStatus :: LibPQ.TransactionStatus + , unexpectedTransactionStatusErrorTransactionEvent :: OrvilleState.TransactionEvent + } + +{- | + +@since 1.1.0.0 +-} +instance Show UnexpectedTransactionStatusError where + show (UnexpectedTransactionStatusError status event) = + "Unexpected transaction status during event " <> show event <> ": " <> show status + +{- | + +@since 1.1.0.0 +-} +instance Exception UnexpectedTransactionStatusError + transactionEventSql :: OrvilleState.OrvilleState -> OrvilleState.TransactionEvent -> @@ -101,16 +222,15 @@ OrvilleState.NewSavepoint savepoint -> RawSql.toRawSql $ Expr.savepoint (savepointName savepoint) OrvilleState.RollbackTransaction -> - RawSql.toRawSql $ Expr.rollback + RawSql.toRawSql Expr.rollback OrvilleState.RollbackToSavepoint savepoint -> RawSql.toRawSql $ Expr.rollbackTo (savepointName savepoint) OrvilleState.CommitTransaction -> - RawSql.toRawSql $ Expr.commit + RawSql.toRawSql Expr.commit OrvilleState.ReleaseSavepoint savepoint -> RawSql.toRawSql $ Expr.releaseSavepoint (savepointName savepoint) -{- | - INTERNAL: Constructs a savepoint name based on the current nesting level of +{- | INTERNAL: Constructs a savepoint name based on the current nesting level of transactions, as tracked by the `OrvilleState.Savepoint` type. Strictly speaking this is not necessary for PostgreSQL because it supports shadowing savepoint names. The SQL standard doesn't allow for savepoint name shadowing, @@ -127,3 +247,43 @@ n = OrvilleState.savepointNestingLevel savepoint in Expr.savepointName ("orville_savepoint_level_" <> show n) + +{- | Information about the current transaction state of an action passed to 'withTransaction'. + +@since 1.1.0.0 +-} +data InWithTransaction + = InOutermostTransaction + | -- | The 'Natural' indicates the savepoint depth, where @1@ is the first savepoint. + InSavepointTransaction Natural + deriving + ( -- | @since 1.1.0.0 + Eq + , -- | @since 1.1.0.0 + Ord + , -- | @since 1.1.0.0 + Show + ) + +{- | Returns 'Just' an 'InWithTransaction' value when called inside of the action passed to + 'withTransaction', and 'Nothing' otherwise. + +@since 1.1.0.0 +-} +inWithTransaction :: MonadOrville.MonadOrville m => m (Maybe InWithTransaction) +inWithTransaction = + fmap + ( \state -> case OrvilleState.orvilleConnectionState state of + OrvilleState.Connected connectedState -> + fmap + ( \transactionState -> case transactionState of + OrvilleState.OutermostTransaction -> + InOutermostTransaction + OrvilleState.SavepointTransaction i -> + InSavepointTransaction . fromIntegral $ OrvilleState.savepointNestingLevel i + ) + (OrvilleState.connectedTransaction connectedState) + OrvilleState.NotConnected -> + Nothing + ) + Monad.askOrvilleState diff --git a/src/Orville/PostgreSQL/Execution/Update.hs b/src/Orville/PostgreSQL/Execution/Update.hs --- a/src/Orville/PostgreSQL/Execution/Update.hs +++ b/src/Orville/PostgreSQL/Execution/Update.hs @@ -39,8 +39,7 @@ import qualified Orville.PostgreSQL.Monad as Monad import Orville.PostgreSQL.Schema (HasKey, TableDefinition, mkTableReturningClause, primaryKeyEquals, tableMarshaller, tableName, tablePrimaryKey) -{- | - Represents an @UPDATE@ statement that can be executed against a database. An +{- | Represents an @UPDATE@ statement that can be executed against a database. An 'Update' has a 'Orville.PostgreSQL.SqlMarshaller' bound to it that, when the update returns data from the database, will be used to decode the database result set when it is executed. @@ -51,8 +50,7 @@ UpdateNoReturning :: Expr.UpdateExpr -> Update readEntity NoReturningClause UpdateReturning :: AnnotatedSqlMarshaller writeEntity readEntity -> Expr.UpdateExpr -> Update readEntity ReturningClause -{- | - Extracts the query that will be run when the update is executed. Normally you +{- | Extracts the query that will be run when the update is executed. Normally you don't want to extract the query and run it yourself, but this function is useful to view the query for debugging or query explanation. @@ -62,8 +60,7 @@ updateToUpdateExpr (UpdateNoReturning expr) = expr updateToUpdateExpr (UpdateReturning _ expr) = expr -{- | - Executes the database query for the 'Update' and returns the number of +{- | Executes the database query for the 'Update' and returns the number of affected rows. @since 1.0.0.0 @@ -72,8 +69,7 @@ executeUpdate = Execute.executeAndReturnAffectedRows QueryType.UpdateQuery . updateToUpdateExpr -{- | - Executes the database query for the 'Update' and uses its +{- | Executes the database query for the 'Update' and uses its 'AnnotatedSqlMarshaller' to decode any rows that were just updated, as returned via a RETURNING clause. @@ -83,8 +79,7 @@ executeUpdateReturnEntities (UpdateReturning marshaller expr) = Execute.executeAndDecode QueryType.UpdateQuery expr marshaller -{- | - Builds an 'Update' that will update all of the writable columns described in +{- | Builds an 'Update' that will update all of the writable columns described in the 'TableDefinition' without returning the data as seen by the database. This function returns 'Nothing' if the 'TableDefinition' has no columns, @@ -100,8 +95,7 @@ updateToTable = updateTable WithoutReturning -{- | - Builds an 'Update' that will update all of the writable columns described in +{- | Builds an 'Update' that will update all of the writable columns described in the 'TableDefinition' and return the data as seen by the database. This is useful for getting database-managed columns such as auto-incrementing identifiers and sequences. @@ -119,8 +113,7 @@ updateToTableReturning = updateTable WithReturning -{- | - Builds an 'Update' that will apply the specified column set clauses to rows +{- | Builds an 'Update' that will apply the specified column set clauses to rows within the specified table without returning the data as seen by the database. @since 1.0.0.0 @@ -133,8 +126,7 @@ updateToTableFields = updateFields WithoutReturning -{- | - Builds an 'Update' that will apply the specified column set clauses to rows +{- | Builds an 'Update' that will apply the specified column set clauses to rows within the specified table and return the updated version of any rows affected by the update state by using a @RETURNING@ clause. @@ -148,8 +140,7 @@ updateToTableFieldsReturning = updateFields WithReturning -{- | - Builds an 'Update' that will execute the specified query and use the given 'AnnotatedSqlMarshaller' to +{- | Builds an 'Update' that will execute the specified query and use the given 'AnnotatedSqlMarshaller' to decode it. It is up to the caller to ensure that the given 'Expr.UpdateExpr' makes sense and produces a value that can be stored, as well as returning a result that the 'AnnotatedSqlMarshaller' can decode. @@ -208,6 +199,8 @@ rawUpdateExpr returingOption (tableMarshaller tableDef) $ Expr.updateExpr (tableName tableDef) + Nothing (Expr.setClauseList setClauses) + Nothing whereClause (mkTableReturningClause returingOption tableDef) diff --git a/src/Orville/PostgreSQL/Expr.hs b/src/Orville/PostgreSQL/Expr.hs --- a/src/Orville/PostgreSQL/Expr.hs +++ b/src/Orville/PostgreSQL/Expr.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -Wno-missing-import-lists #-} {- | -Copyright : Flipstone Technology Partners 2023 +Copyright : Flipstone Technology Partners 2023-2025 License : MIT Stability : Stable @@ -37,14 +37,19 @@ module Orville.PostgreSQL.Expr ( module Orville.PostgreSQL.Expr.BinaryOperator , module Orville.PostgreSQL.Expr.ColumnDefinition + , module Orville.PostgreSQL.Expr.Comment , module Orville.PostgreSQL.Expr.Count , module Orville.PostgreSQL.Expr.Cursor , module Orville.PostgreSQL.Expr.DataType , module Orville.PostgreSQL.Expr.Delete , module Orville.PostgreSQL.Expr.GroupBy + , module Orville.PostgreSQL.Expr.TableReferenceList , module Orville.PostgreSQL.Expr.IfExists + , module Orville.PostgreSQL.Expr.IfNotExists , module Orville.PostgreSQL.Expr.Index , module Orville.PostgreSQL.Expr.Insert + , module Orville.PostgreSQL.Expr.OnConflict + , module Orville.PostgreSQL.Expr.Join , module Orville.PostgreSQL.Expr.LimitExpr , module Orville.PostgreSQL.Expr.Math , module Orville.PostgreSQL.Expr.Name @@ -56,42 +61,71 @@ , module Orville.PostgreSQL.Expr.SequenceDefinition , module Orville.PostgreSQL.Expr.TableConstraint , module Orville.PostgreSQL.Expr.TableDefinition - , module Orville.PostgreSQL.Expr.TableReferenceList , module Orville.PostgreSQL.Expr.Time , module Orville.PostgreSQL.Expr.Transaction , module Orville.PostgreSQL.Expr.Update , module Orville.PostgreSQL.Expr.ValueExpression , module Orville.PostgreSQL.Expr.WhereClause + , module Orville.PostgreSQL.Expr.Trigger + , module Orville.PostgreSQL.Expr.Function + , module Orville.PostgreSQL.Expr.OrReplace + , module Orville.PostgreSQL.Expr.ConditionalExpr + , module Orville.PostgreSQL.Expr.Window + , module Orville.PostgreSQL.Expr.Vacuum + , module Orville.PostgreSQL.Expr.Extension + , module Orville.PostgreSQL.Expr.RowLocking + , module Orville.PostgreSQL.Expr.Aggregate + , module Orville.PostgreSQL.Expr.Filter + , module Orville.PostgreSQL.Expr.FetchClause + , module Orville.PostgreSQL.Expr.Values + , module Orville.PostgreSQL.Expr.TextSearch ) where -- Note: we list the re-exports explicity above to control the order that they -- appear in the generated haddock documentation. +import Orville.PostgreSQL.Expr.Aggregate import Orville.PostgreSQL.Expr.BinaryOperator import Orville.PostgreSQL.Expr.ColumnDefinition +import Orville.PostgreSQL.Expr.Comment +import Orville.PostgreSQL.Expr.ConditionalExpr import Orville.PostgreSQL.Expr.Count import Orville.PostgreSQL.Expr.Cursor import Orville.PostgreSQL.Expr.DataType import Orville.PostgreSQL.Expr.Delete +import Orville.PostgreSQL.Expr.Extension +import Orville.PostgreSQL.Expr.FetchClause +import Orville.PostgreSQL.Expr.Filter +import Orville.PostgreSQL.Expr.Function import Orville.PostgreSQL.Expr.GroupBy import Orville.PostgreSQL.Expr.IfExists +import Orville.PostgreSQL.Expr.IfNotExists import Orville.PostgreSQL.Expr.Index import Orville.PostgreSQL.Expr.Insert +import Orville.PostgreSQL.Expr.Join import Orville.PostgreSQL.Expr.LimitExpr import Orville.PostgreSQL.Expr.Math import Orville.PostgreSQL.Expr.Name import Orville.PostgreSQL.Expr.OffsetExpr +import Orville.PostgreSQL.Expr.OnConflict +import Orville.PostgreSQL.Expr.OrReplace import Orville.PostgreSQL.Expr.OrderBy import Orville.PostgreSQL.Expr.Query import Orville.PostgreSQL.Expr.ReturningExpr +import Orville.PostgreSQL.Expr.RowLocking import Orville.PostgreSQL.Expr.Select import Orville.PostgreSQL.Expr.SequenceDefinition import Orville.PostgreSQL.Expr.TableConstraint import Orville.PostgreSQL.Expr.TableDefinition import Orville.PostgreSQL.Expr.TableReferenceList +import Orville.PostgreSQL.Expr.TextSearch import Orville.PostgreSQL.Expr.Time import Orville.PostgreSQL.Expr.Transaction +import Orville.PostgreSQL.Expr.Trigger import Orville.PostgreSQL.Expr.Update +import Orville.PostgreSQL.Expr.Vacuum import Orville.PostgreSQL.Expr.ValueExpression +import Orville.PostgreSQL.Expr.Values import Orville.PostgreSQL.Expr.WhereClause +import Orville.PostgreSQL.Expr.Window diff --git a/src/Orville/PostgreSQL/Expr/Aggregate.hs b/src/Orville/PostgreSQL/Expr/Aggregate.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/Aggregate.hs @@ -0,0 +1,502 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{- | +Copyright : Flipstone Technology Partners 2024-2025 +License : MIT +Stability : Stable + +@since 1.1.0.0 +-} +module Orville.PostgreSQL.Expr.Aggregate + ( AggregateOptionExpr + , aggregateExpression + , aggregateStarExpression + , aggregateWithinGroupExpression + , arrayAggAggregateFunction + , avgAggregateFunction + , bitAndAggregateFunction + , bitOrAggregateFunction + , bitXorAggregateFunction + , boolAndAggregateFunction + , boolOrAggregateFunction + , countExprAggregateFunction + , count1AggregateFunction + , countColumnAggregateFunction + , countAggregateFunction + , everyAggregateFunction + , jsonAggAggregateFunction + , jsonObjectAggAggregateFunction + , jsonbAggAggregateFunction + , jsonbObjectAggAggregateFunction + , maxAggregateFunction + , minAggregateFunction + , stringAggAggregateFunction + , sumAggregateFunction + , corAggregateFunction + , covarPopAggregateFunction + , covarSampAggregateFunction + , stddevPopAggregateFunction + , stddevSampAggregateFunction + , varPopAggregateFunction + , varSampAggregateFunction + ) +where + +import qualified Data.List.NonEmpty as NEL + +import qualified Orville.PostgreSQL.Expr.Filter as Filter +import Orville.PostgreSQL.Expr.Name (FunctionName) +import qualified Orville.PostgreSQL.Expr.Name as Name +import qualified Orville.PostgreSQL.Expr.OrderBy as OrderBy +import qualified Orville.PostgreSQL.Expr.ValueExpression as ValueExpression +import qualified Orville.PostgreSQL.Raw.RawSql as RawSql + +{- | 'AggregateOptionExpr' represents the options to aggregate functions. E.G. + +> ALL + +or + +> DISTINCT + +'AggregateOptionExpr' provides a 'RawSql.SqlExpression' instance. See +'RawSql.unsafeSqlExpression' for how to construct a value with your own custom +SQL. + +@since 1.1.0.0 +-} +newtype AggregateOptionExpr = AggregateOptionExpr RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | Builds an aggregate expression. Note that it is up to the caller to ensure the validity of all of the arguments and that the resulting 'ValueExpression.ValueExpression' is used in an appropriate manner. + +@since 1.1.0.0 +-} +aggregateExpression :: FunctionName -> Maybe AggregateOptionExpr -> NEL.NonEmpty ValueExpression.ValueExpression -> Maybe OrderBy.OrderByClause -> Maybe Filter.FilterExpr -> ValueExpression.ValueExpression +aggregateExpression function mbAggOption parameters mbOrderByClause mbFilter = + let + fnCall = + RawSql.toRawSql function + <> RawSql.parenthesized + ( ( case mbAggOption of + Nothing -> mempty + Just aggOption -> + RawSql.toRawSql aggOption + <> RawSql.space + ) + <> RawSql.intercalate RawSql.comma parameters + <> maybe mempty RawSql.toRawSql mbOrderByClause + ) + + filtering = + case mbFilter of + Nothing -> mempty + Just filterExpr -> RawSql.space <> RawSql.toRawSql filterExpr + in + RawSql.unsafeFromRawSql $ + fnCall + <> filtering + +{- | Builds an aggregate expression with a * as the function argument. Note that it is up to the caller to ensure the validity of all of the arguments and that the resulting 'ValueExpression.ValueExpression' is used in an appropriate manner. + +@since 1.1.0.0 +-} +aggregateStarExpression :: FunctionName -> Maybe Filter.FilterExpr -> ValueExpression.ValueExpression +aggregateStarExpression function mbFilter = + let + parameters :: [ValueExpression.ValueExpression] + parameters = pure . RawSql.unsafeFromRawSql $ RawSql.fromString "*" + filtering = + case mbFilter of + Nothing -> mempty + Just filterExpr -> RawSql.space <> RawSql.toRawSql filterExpr + in + RawSql.unsafeFromRawSql $ + RawSql.toRawSql (ValueExpression.functionCall function parameters) + <> filtering + +{- | Builds an orderd-set aggregate expression. These have the 'OrderBy.OrderByClause' as an argument to the aggregating function. Note that it is up to the caller to ensure the validity of all of the arguments and that the resulting 'ValueExpression.ValueExpression' is used in an appropriate manner. + +@since 1.1.0.0 +-} +aggregateWithinGroupExpression :: FunctionName -> [ValueExpression.ValueExpression] -> OrderBy.OrderByClause -> Maybe Filter.FilterExpr -> ValueExpression.ValueExpression +aggregateWithinGroupExpression function parameters orderByClause mbFilter = + let + within = + RawSql.fromString " WITHIN GROUP " + <> RawSql.parenthesized (RawSql.toRawSql orderByClause) + filtering = + case mbFilter of + Nothing -> mempty + Just filterExpr -> RawSql.space <> RawSql.toRawSql filterExpr + in + RawSql.unsafeFromRawSql $ + RawSql.toRawSql (ValueExpression.functionCall function parameters) + <> within + <> filtering + +{- | The SQL @array_agg@ aggregate function. + +@since 1.1.0.0 +-} +arrayAggAggregateFunction :: + Maybe AggregateOptionExpr -> + ValueExpression.ValueExpression -> + Maybe OrderBy.OrderByClause -> + Maybe Filter.FilterExpr -> + ValueExpression.ValueExpression +arrayAggAggregateFunction = + singleParameterAggregateFunction Name.arrayAggFunctionName + +{- | The SQL @avg@ aggregate function. + +@since 1.1.0.0 +-} +avgAggregateFunction :: + Maybe AggregateOptionExpr -> + ValueExpression.ValueExpression -> + Maybe OrderBy.OrderByClause -> + Maybe Filter.FilterExpr -> + ValueExpression.ValueExpression +avgAggregateFunction = + singleParameterAggregateFunction Name.avgFunctionName + +{- | The SQL @bit_and@ aggregate function. + +@since 1.1.0.0 +-} +bitAndAggregateFunction :: + Maybe AggregateOptionExpr -> + ValueExpression.ValueExpression -> + Maybe OrderBy.OrderByClause -> + Maybe Filter.FilterExpr -> + ValueExpression.ValueExpression +bitAndAggregateFunction = + singleParameterAggregateFunction Name.bitAndFunctionName + +{- | The SQL @bit_or@ aggregate function. + +@since 1.1.0.0 +-} +bitOrAggregateFunction :: + Maybe AggregateOptionExpr -> + ValueExpression.ValueExpression -> + Maybe OrderBy.OrderByClause -> + Maybe Filter.FilterExpr -> + ValueExpression.ValueExpression +bitOrAggregateFunction = + singleParameterAggregateFunction Name.bitOrFunctionName + +{- | The SQL @bit_xor@ aggregate function. + +@since 1.1.0.0 +-} +bitXorAggregateFunction :: + Maybe AggregateOptionExpr -> + ValueExpression.ValueExpression -> + Maybe OrderBy.OrderByClause -> + Maybe Filter.FilterExpr -> + ValueExpression.ValueExpression +bitXorAggregateFunction = + singleParameterAggregateFunction Name.bitXorFunctionName + +{- | The SQL @bool_and@ aggregate function. + +@since 1.1.0.0 +-} +boolAndAggregateFunction :: + Maybe AggregateOptionExpr -> + ValueExpression.ValueExpression -> + Maybe OrderBy.OrderByClause -> + Maybe Filter.FilterExpr -> + ValueExpression.ValueExpression +boolAndAggregateFunction = + singleParameterAggregateFunction Name.boolAndFunctionName + +{- | The SQL @bool_or@ aggregate function. + +@since 1.1.0.0 +-} +boolOrAggregateFunction :: + Maybe AggregateOptionExpr -> + ValueExpression.ValueExpression -> + Maybe OrderBy.OrderByClause -> + Maybe Filter.FilterExpr -> + ValueExpression.ValueExpression +boolOrAggregateFunction = + singleParameterAggregateFunction Name.boolOrFunctionName + +{- | A simplified version of 'countAggregateFunction' for the SQL @count@ of a + 'ValueExpression.ValueExpression' + +@since 1.1.0.0 +-} +countExprAggregateFunction :: + ValueExpression.ValueExpression -> + ValueExpression.ValueExpression +countExprAggregateFunction valExpr = + singleParameterAggregateFunction Name.countFunctionName Nothing valExpr Nothing Nothing + +{- | A simplified version of 'countAggregateFunction' for the SQL @count(1)@ + +@since 1.1.0.0 +-} +count1AggregateFunction :: + ValueExpression.ValueExpression +count1AggregateFunction = + countExprAggregateFunction (RawSql.unsafeFromRawSql . RawSql.intDecLiteral $ 1) + +{- | A simplified version of 'countAggregateFunction' for the SQL @count@ of a column + +@since 1.1.0.0 +-} +countColumnAggregateFunction :: + Name.QualifiedOrUnqualified Name.ColumnName -> + ValueExpression.ValueExpression +countColumnAggregateFunction = + countExprAggregateFunction . ValueExpression.columnReference + +{- | The SQL @count@ aggregate function. + +@since 1.1.0.0 +-} +countAggregateFunction :: + Maybe AggregateOptionExpr -> + ValueExpression.ValueExpression -> + Maybe OrderBy.OrderByClause -> + Maybe Filter.FilterExpr -> + ValueExpression.ValueExpression +countAggregateFunction = + singleParameterAggregateFunction Name.countFunctionName + +{- | The SQL @every@ aggregate function. + +@since 1.1.0.0 +-} +everyAggregateFunction :: + Maybe AggregateOptionExpr -> + ValueExpression.ValueExpression -> + Maybe OrderBy.OrderByClause -> + Maybe Filter.FilterExpr -> + ValueExpression.ValueExpression +everyAggregateFunction = + singleParameterAggregateFunction Name.everyFunctionName + +{- | The SQL @json_agg@ aggregate function. + +@since 1.1.0.0 +-} +jsonAggAggregateFunction :: + Maybe AggregateOptionExpr -> + ValueExpression.ValueExpression -> + Maybe OrderBy.OrderByClause -> + Maybe Filter.FilterExpr -> + ValueExpression.ValueExpression +jsonAggAggregateFunction = + singleParameterAggregateFunction Name.jsonAggFunctionName + +{- | The SQL @json_object_agg@ aggregate function. + +@since 1.1.0.0 +-} +jsonObjectAggAggregateFunction :: + Maybe AggregateOptionExpr -> + ValueExpression.ValueExpression -> + ValueExpression.ValueExpression -> + Maybe OrderBy.OrderByClause -> + Maybe Filter.FilterExpr -> + ValueExpression.ValueExpression +jsonObjectAggAggregateFunction mbAggOption param1 param2 = + aggregateExpression Name.jsonObjectAggFunctionName mbAggOption (param1 NEL.:| pure param2) + +{- | The SQL @jsonb_agg@ aggregate function. + +@since 1.1.0.0 +-} +jsonbAggAggregateFunction :: + Maybe AggregateOptionExpr -> + ValueExpression.ValueExpression -> + Maybe OrderBy.OrderByClause -> + Maybe Filter.FilterExpr -> + ValueExpression.ValueExpression +jsonbAggAggregateFunction = + singleParameterAggregateFunction Name.jsonbAggFunctionName + +{- | The SQL @jsonb_object_agg@ aggregate function. + +@since 1.1.0.0 +-} +jsonbObjectAggAggregateFunction :: + Maybe AggregateOptionExpr -> + ValueExpression.ValueExpression -> + ValueExpression.ValueExpression -> + Maybe OrderBy.OrderByClause -> + Maybe Filter.FilterExpr -> + ValueExpression.ValueExpression +jsonbObjectAggAggregateFunction mbAggOption param1 param2 = + aggregateExpression Name.jsonbObjectAggFunctionName mbAggOption (param1 NEL.:| pure param2) + +{- | The SQL @max@ aggregate function. + +@since 1.1.0.0 +-} +maxAggregateFunction :: + Maybe AggregateOptionExpr -> + ValueExpression.ValueExpression -> + Maybe OrderBy.OrderByClause -> + Maybe Filter.FilterExpr -> + ValueExpression.ValueExpression +maxAggregateFunction = + singleParameterAggregateFunction Name.maxFunctionName + +{- | The SQL @min@ aggregate function. + +@since 1.1.0.0 +-} +minAggregateFunction :: + Maybe AggregateOptionExpr -> + ValueExpression.ValueExpression -> + Maybe OrderBy.OrderByClause -> + Maybe Filter.FilterExpr -> + ValueExpression.ValueExpression +minAggregateFunction = + singleParameterAggregateFunction Name.minFunctionName + +{- | The SQL @string_agg@ aggregate function. + +@since 1.1.0.0 +-} +stringAggAggregateFunction :: + Maybe AggregateOptionExpr -> + ValueExpression.ValueExpression -> + ValueExpression.ValueExpression -> + Maybe OrderBy.OrderByClause -> + Maybe Filter.FilterExpr -> + ValueExpression.ValueExpression +stringAggAggregateFunction mbAggOption param1 param2 = + aggregateExpression Name.stringAggFunctionName mbAggOption (param1 NEL.:| pure param2) + +{- | The SQL @sum@ aggregate function. + +@since 1.1.0.0 +-} +sumAggregateFunction :: + Maybe AggregateOptionExpr -> + ValueExpression.ValueExpression -> + Maybe OrderBy.OrderByClause -> + Maybe Filter.FilterExpr -> + ValueExpression.ValueExpression +sumAggregateFunction = + singleParameterAggregateFunction Name.sumFunctionName + +{- | The SQL @cor@ aggregate function. + +@since 1.1.0.0 +-} +corAggregateFunction :: + Maybe AggregateOptionExpr -> + ValueExpression.ValueExpression -> + ValueExpression.ValueExpression -> + Maybe OrderBy.OrderByClause -> + Maybe Filter.FilterExpr -> + ValueExpression.ValueExpression +corAggregateFunction mbAggOption param1 param2 = + aggregateExpression Name.corFunctionName mbAggOption (param1 NEL.:| pure param2) + +{- | The SQL @covar_pop@ aggregate function. + +@since 1.1.0.0 +-} +covarPopAggregateFunction :: + Maybe AggregateOptionExpr -> + ValueExpression.ValueExpression -> + ValueExpression.ValueExpression -> + Maybe OrderBy.OrderByClause -> + Maybe Filter.FilterExpr -> + ValueExpression.ValueExpression +covarPopAggregateFunction mbAggOption param1 param2 = + aggregateExpression Name.covarPopFunctionName mbAggOption (param1 NEL.:| pure param2) + +{- | The SQL @covar_samp@ aggregate function. + +@since 1.1.0.0 +-} +covarSampAggregateFunction :: + Maybe AggregateOptionExpr -> + ValueExpression.ValueExpression -> + ValueExpression.ValueExpression -> + Maybe OrderBy.OrderByClause -> + Maybe Filter.FilterExpr -> + ValueExpression.ValueExpression +covarSampAggregateFunction mbAggOption param1 param2 = + aggregateExpression Name.covarSampFunctionName mbAggOption (param1 NEL.:| pure param2) + +{- | The SQL @stddev_pop@ aggregate function. + +@since 1.1.0.0 +-} +stddevPopAggregateFunction :: + Maybe AggregateOptionExpr -> + ValueExpression.ValueExpression -> + ValueExpression.ValueExpression -> + Maybe OrderBy.OrderByClause -> + Maybe Filter.FilterExpr -> + ValueExpression.ValueExpression +stddevPopAggregateFunction mbAggOption param1 param2 = + aggregateExpression Name.stddevPopFunctionName mbAggOption (param1 NEL.:| pure param2) + +{- | The SQL @stddev_samp@ aggregate function. + +@since 1.1.0.0 +-} +stddevSampAggregateFunction :: + Maybe AggregateOptionExpr -> + ValueExpression.ValueExpression -> + ValueExpression.ValueExpression -> + Maybe OrderBy.OrderByClause -> + Maybe Filter.FilterExpr -> + ValueExpression.ValueExpression +stddevSampAggregateFunction mbAggOption param1 param2 = + aggregateExpression Name.stddevSampFunctionName mbAggOption (param1 NEL.:| pure param2) + +{- | The SQL @var_pop@ aggregate function. + +@since 1.1.0.0 +-} +varPopAggregateFunction :: + Maybe AggregateOptionExpr -> + ValueExpression.ValueExpression -> + ValueExpression.ValueExpression -> + Maybe OrderBy.OrderByClause -> + Maybe Filter.FilterExpr -> + ValueExpression.ValueExpression +varPopAggregateFunction mbAggOption param1 param2 = + aggregateExpression Name.varPopFunctionName mbAggOption (param1 NEL.:| pure param2) + +{- | The SQL @var_samp@ aggregate function. + +@since 1.1.0.0 +-} +varSampAggregateFunction :: + Maybe AggregateOptionExpr -> + ValueExpression.ValueExpression -> + ValueExpression.ValueExpression -> + Maybe OrderBy.OrderByClause -> + Maybe Filter.FilterExpr -> + ValueExpression.ValueExpression +varSampAggregateFunction mbAggOption param1 param2 = + aggregateExpression Name.varSampFunctionName mbAggOption (param1 NEL.:| pure param2) + +-- internal helper to make building up the aggregates that only take a single parameter. +singleParameterAggregateFunction :: + FunctionName -> + Maybe AggregateOptionExpr -> + ValueExpression.ValueExpression -> + Maybe OrderBy.OrderByClause -> + Maybe Filter.FilterExpr -> + ValueExpression.ValueExpression +singleParameterAggregateFunction function mbAggOption parameter = + aggregateExpression function mbAggOption (pure parameter) diff --git a/src/Orville/PostgreSQL/Expr/BinaryOperator.hs b/src/Orville/PostgreSQL/Expr/BinaryOperator.hs --- a/src/Orville/PostgreSQL/Expr/BinaryOperator.hs +++ b/src/Orville/PostgreSQL/Expr/BinaryOperator.hs @@ -15,6 +15,8 @@ , binaryOperator , binaryOpExpression , equalsOp + , isDistinctFromOp + , isNotDistinctFromOp , notEqualsOp , greaterThanOp , lessThanOp @@ -41,8 +43,7 @@ import Orville.PostgreSQL.Expr.ValueExpression (ValueExpression) import qualified Orville.PostgreSQL.Raw.RawSql as RawSql -{- | -Type to represent any SQL operator of two arguments. E.G. +{- | Type to represent any SQL operator of two arguments. E.G. > AND @@ -85,6 +86,20 @@ notEqualsOp = binaryOperator "<>" +{- | The SQL 'IS DISTINCT FROM' binary 'operator'. + +@since 1.1.0.0 +-} +isDistinctFromOp :: BinaryOperator +isDistinctFromOp = binaryOperator "IS DISTINCT FROM" + +{- | The SQL 'IS NOT DISTINCT FROM' binary 'operator'. + +@since 1.1.0.0 +-} +isNotDistinctFromOp :: BinaryOperator +isNotDistinctFromOp = binaryOperator "IS NOT DISTINCT FROM" + {- | The SQL strictly greater than binary operator. @since 1.0.0.0 @@ -253,8 +268,8 @@ binaryOpExpression op left right = binaryOpExpressionUnparenthenizedArguments op - (RawSql.unsafeFromRawSql (RawSql.leftParen <> RawSql.toRawSql left <> RawSql.rightParen)) - (RawSql.unsafeFromRawSql (RawSql.leftParen <> RawSql.toRawSql right <> RawSql.rightParen)) + (RawSql.unsafeFromRawSql (RawSql.parenthesized left)) + (RawSql.unsafeFromRawSql (RawSql.parenthesized right)) -- internal helper function binaryOpExpressionUnparenthenizedArguments :: diff --git a/src/Orville/PostgreSQL/Expr/ColumnDefinition.hs b/src/Orville/PostgreSQL/Expr/ColumnDefinition.hs --- a/src/Orville/PostgreSQL/Expr/ColumnDefinition.hs +++ b/src/Orville/PostgreSQL/Expr/ColumnDefinition.hs @@ -1,7 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {- | -Copyright : Flipstone Technology Partners 2023 +Copyright : Flipstone Technology Partners 2023-2025 License : MIT Stability : Stable @@ -15,18 +15,19 @@ , nullConstraint , ColumnDefault , columnDefault + , identityColumnConstraint + , ColumnIdentityGeneration + , alwaysColumnIdentityGeneration + , byDefaultColumnIdentityGeneration ) where -import qualified Data.Maybe as Maybe - import Orville.PostgreSQL.Expr.DataType (DataType) import Orville.PostgreSQL.Expr.Name (ColumnName) import Orville.PostgreSQL.Expr.ValueExpression (ValueExpression) import qualified Orville.PostgreSQL.Raw.RawSql as RawSql -{- | -Represent a complete definition of a column. E.G. +{- | Represent a complete definition of a column. E.G. > foo INTEGER @@ -52,23 +53,28 @@ ColumnName -> -- | The SQL type of the column. DataType -> - -- | The constraint on the column, if any. - Maybe ColumnConstraint -> + -- | The constraints on the column, if any. + [ColumnConstraint] -> -- | The default value for the column, if any. Maybe ColumnDefault -> ColumnDefinition -columnDefinition columnName dataType maybeColumnConstraint maybeColumnDefault = - ColumnDefinition - . RawSql.intercalate RawSql.space - $ Maybe.catMaybes - [ Just $ RawSql.toRawSql columnName - , Just $ RawSql.toRawSql dataType - , fmap RawSql.toRawSql maybeColumnConstraint - , fmap RawSql.toRawSql maybeColumnDefault - ] +columnDefinition columnName dataType columnConstraints maybeColumnDefault = + let + constraintRawSql = + RawSql.intercalate RawSql.space columnConstraints + in + ColumnDefinition $ + RawSql.toRawSql columnName + <> RawSql.space + <> RawSql.toRawSql dataType + <> RawSql.space + <> constraintRawSql + <> case maybeColumnDefault of + Nothing -> mempty + Just colDefault -> + RawSql.space <> RawSql.toRawSql colDefault -{- | -Represent constraints, such as nullability, on a column. E.G. +{- | Represent constraints, such as nullability, on a column. E.G. > NOT NULL @@ -101,8 +107,51 @@ nullConstraint = ColumnConstraint (RawSql.fromString "NULL") -{- | -Represents the default value of a column. E.G. +{- | Represent the generation definition of an identity column. E.G. + +> ALWAYS + +'ColumnIdentityGeneration' provides a 'RawSql.SqlExpression' instance. See +'RawSql.unsafeSqlExpression' for how to construct a value with your own custom +SQL. + +@since 1.1.0.0 +-} +newtype ColumnIdentityGeneration + = ColumnIdentityGeneration RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | Express that a column is an identity column. + +@since 1.1.0.0 +-} +identityColumnConstraint :: + ColumnIdentityGeneration -> + ColumnConstraint +identityColumnConstraint identityGeneration = + ColumnConstraint $ + RawSql.fromString "GENERATED " + <> RawSql.toRawSql identityGeneration + <> RawSql.fromString " AS IDENTITY" + +{- | The @ALWAYS@ generation for an identity column + +@since 1.1.0.0 +-} +alwaysColumnIdentityGeneration :: ColumnIdentityGeneration +alwaysColumnIdentityGeneration = ColumnIdentityGeneration $ RawSql.fromString "ALWAYS" + +{- | The @BY DEFAULT@ generation for an identity column + +@since 1.1.0.0 +-} +byDefaultColumnIdentityGeneration :: ColumnIdentityGeneration +byDefaultColumnIdentityGeneration = ColumnIdentityGeneration $ RawSql.fromString "BY DEFAULT" + +{- | Represents the default value of a column. E.G. > now() diff --git a/src/Orville/PostgreSQL/Expr/Comment.hs b/src/Orville/PostgreSQL/Expr/Comment.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/Comment.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{- | +Copyright : Flipstone Technology Partners 2024 +License : MIT +Stability : Stable + +@since 1.1.0.0 +-} +module Orville.PostgreSQL.Expr.Comment + ( Comment + , commentText + , CommentExpr + , commentTableExpr + , commentColumnExpr + ) where + +import qualified Data.Text as T +import qualified Data.Text.Encoding as TEnc + +import Orville.PostgreSQL.Expr.Name (ColumnName, QualifiedOrUnqualified, SchemaName, TableName, qualifyColumn) +import qualified Orville.PostgreSQL.Raw.RawSql as RawSql + +{- | Type to represent a PostgreSQL comment string literal. + +@since 1.1.0.0 +-} +newtype Comment = Comment RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | Construct a 'Comment' from a 'T.Text' value. The value will be escaped and quoted. + +@since 1.1.0.0 +-} +commentText :: T.Text -> Comment +commentText = Comment . RawSql.stringLiteral . TEnc.encodeUtf8 + +{- | Type to represent a PostgreSQL @COMMENT@ statement. + +@since 1.1.0.0 +-} +newtype CommentExpr = CommentExpr RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | Construct a 'CommentExpr' for a @COMMENT ON TABLE@ statement. + +@since 1.1.0.0 +-} +commentTableExpr :: QualifiedOrUnqualified TableName -> Maybe Comment -> CommentExpr +commentTableExpr tableName mbComment = + CommentExpr $ + RawSql.intercalate + RawSql.space + [ RawSql.fromString "COMMENT ON TABLE" + , RawSql.toRawSql tableName + , RawSql.fromString "IS" + , maybe RawSql.nullLiteral RawSql.toRawSql mbComment + ] + +{- | Construct a 'CommentExpr' for a @COMMENT ON COLUMN@ statement. + +@since 1.1.0.0 +-} +commentColumnExpr :: Maybe SchemaName -> TableName -> ColumnName -> Maybe Comment -> CommentExpr +commentColumnExpr mbSchema tableName colName mbComment = + CommentExpr $ + RawSql.intercalate + RawSql.space + [ RawSql.fromString "COMMENT ON COLUMN" + , RawSql.toRawSql $ qualifyColumn mbSchema tableName colName + , RawSql.fromString "IS" + , maybe RawSql.nullLiteral RawSql.toRawSql mbComment + ] diff --git a/src/Orville/PostgreSQL/Expr/ConditionalExpr.hs b/src/Orville/PostgreSQL/Expr/ConditionalExpr.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/ConditionalExpr.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{- | +Copyright : Flipstone Technology Partners 2024 +License : MIT +Stability : Stable + +@since 1.1.0.0 +-} +module Orville.PostgreSQL.Expr.ConditionalExpr + ( coalesce + , WhenExpr + , whenExpr + , caseExpr + , nullIf + , greatest + , least + ) where + +import qualified Data.List.NonEmpty as NE + +import Orville.PostgreSQL.Expr.ValueExpression (ValueExpression) +import Orville.PostgreSQL.Expr.WhereClause (BooleanExpr) +import qualified Orville.PostgreSQL.Raw.RawSql as RawSql + +{- | Creates a 'ValueExpression' corresponding to the SQL @COALESE@. + +@since 1.1.0.0 +-} +coalesce :: NE.NonEmpty ValueExpression -> ValueExpression +coalesce valExprs = + RawSql.unsafeFromRawSql $ + RawSql.fromString "COALESCE" + <> RawSql.leftParen + <> RawSql.intercalate RawSql.comma (fmap RawSql.toRawSql valExprs) + <> RawSql.rightParen + +{- | Type to represent the @WHEN@ portion of a SQL @CASE@ expressions. +E.G. + +> WHEN condition THEN result + +'WhenExpr' provides a 'RawSql.SqlExpression' instance. See +'RawSql.unsafeSqlExpression' for how to construct a value with your own custom +SQL. + +@since 1.1.0.0 +-} +newtype WhenExpr = WhenExpr RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | Builds a 'WhenExpr' that will apply when the given 'BooleanExpr' evaluates to @TRUE@, resulting in the 'ValueExpression' + +@since 1.1.0.0 +-} +whenExpr :: BooleanExpr -> ValueExpression -> WhenExpr +whenExpr boolExpr resultExpr = + WhenExpr $ + RawSql.fromString "WHEN" + <> RawSql.space + <> RawSql.toRawSql boolExpr + <> RawSql.space + <> RawSql.fromString "THEN" + <> RawSql.space + <> RawSql.toRawSql resultExpr + +{- | Builds a 'ValueExpression' corresponding to a SQL @CASE@ using the given 'WhenExpr' as the tested value with results and an optional 'ValueExpression' that corresponds to the @ELSE@ portion of the @CASE@. + +@since 1.1.0.0 +-} +caseExpr :: + NE.NonEmpty WhenExpr -> + Maybe ValueExpression -> + ValueExpression +caseExpr whens mbElse = + RawSql.unsafeFromRawSql $ + RawSql.fromString "CASE" + <> RawSql.space + <> RawSql.intercalate RawSql.space (fmap RawSql.toRawSql whens) + <> RawSql.space + <> case mbElse of + Nothing -> + RawSql.fromString "END" + Just elseVal -> + RawSql.fromString "ELSE" + <> RawSql.space + <> RawSql.toRawSql elseVal + <> RawSql.space + <> RawSql.fromString "END" + +{- | Creates a 'ValueExpression' corresponding to the SQL @NULLIF@. + +@since 1.1.0.0 +-} +nullIf :: ValueExpression -> ValueExpression -> ValueExpression +nullIf leftVal rightVal = + RawSql.unsafeFromRawSql $ + RawSql.fromString "NULLIF" + <> RawSql.leftParen + <> RawSql.toRawSql leftVal + <> RawSql.commaSpace + <> RawSql.toRawSql rightVal + <> RawSql.rightParen + +{- | Creates a 'ValueExpression' corresponding to the SQL @GREATEST@. + +@since 1.1.0.0 +-} +greatest :: NE.NonEmpty ValueExpression -> ValueExpression +greatest valExprs = + RawSql.unsafeFromRawSql $ + RawSql.fromString "GREATEST" + <> RawSql.leftParen + <> RawSql.intercalate RawSql.comma (fmap RawSql.toRawSql valExprs) + <> RawSql.rightParen + +{- | Creates a 'ValueExpression' corresponding to the SQL @LEAST@. + +@since 1.1.0.0 +-} +least :: NE.NonEmpty ValueExpression -> ValueExpression +least valExprs = + RawSql.unsafeFromRawSql $ + RawSql.fromString "LEAST" + <> RawSql.leftParen + <> RawSql.intercalate RawSql.comma (fmap RawSql.toRawSql valExprs) + <> RawSql.rightParen diff --git a/src/Orville/PostgreSQL/Expr/Count.hs b/src/Orville/PostgreSQL/Expr/Count.hs --- a/src/Orville/PostgreSQL/Expr/Count.hs +++ b/src/Orville/PostgreSQL/Expr/Count.hs @@ -1,5 +1,5 @@ {- | -Copyright : Flipstone Technology Partners 2023 +Copyright : Flipstone Technology Partners 2023-2024 License : MIT Stability : Stable @@ -13,10 +13,12 @@ ) where -import Orville.PostgreSQL.Expr.Name (ColumnName, FunctionName, functionName) +import Orville.PostgreSQL.Expr.Name (ColumnName, FunctionName, QualifiedOrUnqualified, functionName) import Orville.PostgreSQL.Expr.ValueExpression (ValueExpression, columnReference, functionCall) import qualified Orville.PostgreSQL.Raw.RawSql as RawSql +{-# DEPRECATED countFunction "Use Orville.PostgreSQL.Expr.countFunctionName" #-} + {- | The SQL @count@ function. @since 1.0.0.0 @@ -24,6 +26,8 @@ countFunction :: FunctionName countFunction = functionName "count" +{-# DEPRECATED count "Use Orville.PostgreSQL.Expr.countExprAggregateFunction" #-} + {- | Given a 'ValueExpression', use it as the argument to the SQL @count@. @since 1.0.0.0 @@ -32,6 +36,8 @@ count value = functionCall countFunction [value] +{-# DEPRECATED count1 "Use Orville.PostgreSQL.Expr.count1AggregateFunction" #-} + {- | The SQL @count(1)@. @since 1.0.0.0 @@ -40,10 +46,12 @@ count1 = count . RawSql.unsafeFromRawSql . RawSql.intDecLiteral $ 1 +{-# DEPRECATED countColumn "Use Orville.PostgreSQL.Expr.countColumnAggregateFunction" #-} + {- | Use a given column as the argument to the SQL @count@. @since 1.0.0.0 -} -countColumn :: ColumnName -> ValueExpression +countColumn :: QualifiedOrUnqualified ColumnName -> ValueExpression countColumn = count . columnReference diff --git a/src/Orville/PostgreSQL/Expr/Cursor.hs b/src/Orville/PostgreSQL/Expr/Cursor.hs --- a/src/Orville/PostgreSQL/Expr/Cursor.hs +++ b/src/Orville/PostgreSQL/Expr/Cursor.hs @@ -49,8 +49,7 @@ import Orville.PostgreSQL.Expr.Query (QueryExpr) import qualified Orville.PostgreSQL.Raw.RawSql as RawSql -{- | -'DeclareExpr' corresponds to the SQL DECLARE statement, for declaring and +{- | 'DeclareExpr' corresponds to the SQL DECLARE statement, for declaring and opening cursors. E.G. > DECLARE FOO CURSOR FOR SELECT * FROM BAR @@ -84,20 +83,19 @@ QueryExpr -> DeclareExpr declare cursorName maybeScrollExpr maybeHoldExpr queryExpr = - DeclareExpr $ - RawSql.intercalate RawSql.space $ - catMaybes - [ Just $ RawSql.fromString "DECLARE" - , Just $ RawSql.toRawSql cursorName - , fmap RawSql.toRawSql maybeScrollExpr - , Just $ RawSql.fromString "CURSOR" - , fmap RawSql.toRawSql maybeHoldExpr - , Just $ RawSql.fromString "FOR" - , Just $ RawSql.toRawSql queryExpr - ] + DeclareExpr + . RawSql.intercalate RawSql.space + $ catMaybes + [ Just $ RawSql.fromString "DECLARE" + , Just $ RawSql.toRawSql cursorName + , fmap RawSql.toRawSql maybeScrollExpr + , Just $ RawSql.fromString "CURSOR" + , fmap RawSql.toRawSql maybeHoldExpr + , Just $ RawSql.fromString "FOR" + , Just $ RawSql.toRawSql queryExpr + ] -{- | -'ScrollExpr' is used to determine if a cursor should be able to fetch +{- | 'ScrollExpr' is used to determine if a cursor should be able to fetch nonsequentially. E.G. > NO SCROLL @@ -137,8 +135,7 @@ noScroll = ScrollExpr . RawSql.fromString $ "NO SCROLL" -{- | -'HoldExpr' is used to determine if a cursor should be available for use after +{- | 'HoldExpr' is used to determine if a cursor should be available for use after the transaction that created it has been committed. E.G. > WITH HOLD @@ -175,8 +172,7 @@ withoutHold = HoldExpr . RawSql.fromString $ "WITHOUT HOLD" -{- | -'CloseExpr' corresponds to the SQL CLOSE statement. E.G. +{- | 'CloseExpr' corresponds to the SQL CLOSE statement. E.G. > CLOSE ALL @@ -207,8 +203,7 @@ RawSql.fromString "CLOSE " <> either RawSql.toRawSql RawSql.toRawSql allOrCursorName -{- | -'AllCursors' corresponds to the ALL keyword in a CLOSE statement. E.G. +{- | 'AllCursors' corresponds to the ALL keyword in a CLOSE statement. E.G. > ALL @@ -233,8 +228,7 @@ allCursors = AllCursors . RawSql.fromString $ "ALL" -{- | -'FetchExpr' corresponds to the SQL FETCH statement, for retrieving rows from a +{- | 'FetchExpr' corresponds to the SQL FETCH statement, for retrieving rows from a previously-created cursor. E.G. > FETCH NEXT FOO @@ -262,16 +256,15 @@ -} fetch :: Maybe CursorDirection -> CursorName -> FetchExpr fetch maybeDirection cursorName = - FetchExpr $ - RawSql.intercalate RawSql.space $ - catMaybes - [ Just $ RawSql.fromString "FETCH" - , fmap RawSql.toRawSql maybeDirection - , Just $ RawSql.toRawSql cursorName - ] + FetchExpr + . RawSql.intercalate RawSql.space + $ catMaybes + [ Just $ RawSql.fromString "FETCH" + , fmap RawSql.toRawSql maybeDirection + , Just $ RawSql.toRawSql cursorName + ] -{- | -'MoveExpr' corresponds to the SQL MOVE statement, for positioning a previously +{- | 'MoveExpr' corresponds to the SQL MOVE statement, for positioning a previously created cursor, /without/ retrieving any rows. E.G. > MOVE NEXT FOO @@ -303,8 +296,7 @@ , Just $ RawSql.toRawSql cursorName ] -{- | -'CursorDirection' corresponds to the direction argument to the SQL FETCH and +{- | 'CursorDirection' corresponds to the direction argument to the SQL FETCH and MOVE statements. E.G. > BACKWARD diff --git a/src/Orville/PostgreSQL/Expr/DataType.hs b/src/Orville/PostgreSQL/Expr/DataType.hs --- a/src/Orville/PostgreSQL/Expr/DataType.hs +++ b/src/Orville/PostgreSQL/Expr/DataType.hs @@ -33,8 +33,7 @@ import qualified Orville.PostgreSQL.Raw.RawSql as RawSql -{- | -Type to represent any SQL data type expression. E.G. +{- | Type to represent any SQL data type expression. E.G. > INTEGER @@ -237,8 +236,7 @@ smallint = DataType (RawSql.fromString "SMALLINT") -{- | - A 'DataType' that represents the PostgreSQL "JSONB" data type. +{- | A 'DataType' that represents the PostgreSQL "JSONB" data type. See [postgresql documentation](https://www.postgresql.org/docs/current/datatype-json.html) for more information. diff --git a/src/Orville/PostgreSQL/Expr/Delete.hs b/src/Orville/PostgreSQL/Expr/Delete.hs --- a/src/Orville/PostgreSQL/Expr/Delete.hs +++ b/src/Orville/PostgreSQL/Expr/Delete.hs @@ -17,13 +17,12 @@ import Data.Maybe (catMaybes) -import Orville.PostgreSQL.Expr.Name (Qualified, TableName) +import Orville.PostgreSQL.Expr.Name (QualifiedOrUnqualified, TableName) import Orville.PostgreSQL.Expr.ReturningExpr (ReturningExpr) import Orville.PostgreSQL.Expr.WhereClause (WhereClause) import qualified Orville.PostgreSQL.Raw.RawSql as RawSql -{- | -Type to represent a SQL delete statement. E.G. +{- | Type to represent a SQL delete statement. E.G. > DELETE FROM foo WHERE id < 10 @@ -40,24 +39,22 @@ RawSql.SqlExpression ) -{- | - -Construct a SQL DELETE from a table, optionally limiting with a 'WhereClause' and optionally +{- | Construct a SQL DELETE from a table, optionally limiting with a 'WhereClause' and optionally returning a 'ReturningExpr'. @since 1.0.0.0 -} deleteExpr :: - Qualified TableName -> + QualifiedOrUnqualified TableName -> Maybe WhereClause -> Maybe ReturningExpr -> DeleteExpr deleteExpr tableName maybeWhereClause maybeReturningExpr = - DeleteExpr $ - RawSql.intercalate RawSql.space $ - catMaybes - [ Just $ RawSql.fromString "DELETE FROM" - , Just $ RawSql.toRawSql tableName - , fmap RawSql.toRawSql maybeWhereClause - , fmap RawSql.toRawSql maybeReturningExpr - ] + DeleteExpr + . RawSql.intercalate RawSql.space + $ catMaybes + [ Just $ RawSql.fromString "DELETE FROM" + , Just $ RawSql.toRawSql tableName + , fmap RawSql.toRawSql maybeWhereClause + , fmap RawSql.toRawSql maybeReturningExpr + ] diff --git a/src/Orville/PostgreSQL/Expr/Extension.hs b/src/Orville/PostgreSQL/Expr/Extension.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/Extension.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{- | +Copyright : Flipstone Technology Partners 2024 +License : MIT +Stability : Stable + +Types and functionality related to loading PostgreSQL extensions. This does not contain features +related to any specific extension, but serves as the basis for loading some extension. + +@since 1.1.0.0 +-} +module Orville.PostgreSQL.Expr.Extension + ( CreateExtensionExpr + , createExtensionExpr + , DropExtensionExpr + , dropExtensionExpr + , ExtensionActionExpr + , extensionCascadeExpr + , extensionRestrictExpr + ) where + +import Orville.PostgreSQL.Expr.IfExists (IfExists) +import Orville.PostgreSQL.Expr.IfNotExists (IfNotExists) +import Orville.PostgreSQL.Expr.Name (ExtensionName) +import qualified Orville.PostgreSQL.Raw.RawSql as RawSql + +{- | Type to represent a SQL "CREATE EXTENSION" statement. E.G. + +> CREATE EXTENSION foo + +'CreateIndexExpr' provides a 'RawSql.SqlExpression' instance. See +'RawSql.unsafeSqlExpression' for how to construct a value with your own custom +SQL. + +@since 1.1.0.0 +-} +newtype CreateExtensionExpr = CreateExtensionExpr RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | Construct a SQL CREATE EXTENSION statement from the extension name and if the statement should +not fail on loading an extension with the same name as an already loaded one. + +@since 1.1.0.0 +-} +createExtensionExpr :: ExtensionName -> Maybe IfNotExists -> Maybe ExtensionActionExpr -> CreateExtensionExpr +createExtensionExpr extension mbIfNotExists mbAction = + CreateExtensionExpr $ + RawSql.fromString "CREATE EXTENSION " + <> maybe mempty ((<> RawSql.space) . RawSql.toRawSql) mbIfNotExists + <> RawSql.toRawSql extension + <> maybe mempty ((<> RawSql.space) . RawSql.toRawSql) mbAction + +{- | Type to represent a SQL "DROP EXTENSION" statement. E.G. + +> DROP EXTENSION foo + +'DropIndexExpr' provides a 'RawSql.SqlExpression' instance. See +'RawSql.unsafeSqlExpression' for how to construct a value with your own custom +SQL. + +@since 1.1.0.0 +-} +newtype DropExtensionExpr = DropExtensionExpr RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | Construct a SQL DROP EXTENSION statement from the extension name and if the statement should +not fail on loading an extension with the same name as an already loaded one. + +@since 1.1.0.0 +-} +dropExtensionExpr :: ExtensionName -> Maybe IfExists -> Maybe ExtensionActionExpr -> DropExtensionExpr +dropExtensionExpr extension mbIfExists mbAction = + DropExtensionExpr $ + RawSql.fromString "DROP EXTENSION " + <> maybe mempty ((<> RawSql.space) . RawSql.toRawSql) mbIfExists + <> RawSql.toRawSql extension + <> maybe mempty ((<> RawSql.space) . RawSql.toRawSql) mbAction + +{- | Type to represent a extension action on a @EXTENSION@. E.G. +the @CASCADE@ in + +> CREATE EXTENSION foo CASCADE + +'ExtensionActionExpr' provides a 'RawSql.SqlExpression' instance. See +'RawSql.unsafeSqlExpression' for how to construct a value with your own custom +SQL. + +@since 1.1.0.0 +-} +newtype ExtensionActionExpr + = ExtensionActionExpr RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | The extension action @RESTRICT@. + + @since 1.1.0.0 +-} +extensionRestrictExpr :: ExtensionActionExpr +extensionRestrictExpr = ExtensionActionExpr $ RawSql.fromString "RESTRICT" + +{- | The extension action @CASCADE@. + + @since 1.1.0.0 +-} +extensionCascadeExpr :: ExtensionActionExpr +extensionCascadeExpr = ExtensionActionExpr $ RawSql.fromString "CASCADE" diff --git a/src/Orville/PostgreSQL/Expr/FetchClause.hs b/src/Orville/PostgreSQL/Expr/FetchClause.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/FetchClause.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{- | +Copyright : Flipstone Technology Partners 2024 +License : MIT +Stability : Stable + +@since 1.1.0.0 +-} +module Orville.PostgreSQL.Expr.FetchClause + ( FetchClause + , fetchClauseInt + , FetchClauseModifier + , withTiesFetchClauseModifier + , onlyFetchClauseModifier + ) +where + +import qualified Orville.PostgreSQL.Raw.RawSql as RawSql +import qualified Orville.PostgreSQL.Raw.SqlValue as SqlValue + +{- | Type to represent a SQL FETCH clause. E.G. + +> FETCH FIRST 2 ROWS ONLY + +'FetchClause' provides a 'RawSql.SqlExpression' instance. See +'RawSql.unsafeSqlExpression' for how to construct a value with your own custom +SQL. + +@since 1.1.0.0 +-} +newtype FetchClause + = FetchClause RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | Build a SQL FETCH clause for a given number of rows and 'FetchClauseModifier'. + +@since 1.1.0.0 +-} +fetchClauseInt :: Int -> FetchClauseModifier -> FetchClause +fetchClauseInt fetchNumber = + internal_fetchRaw (RawSql.parameter (SqlValue.fromInt fetchNumber)) + +-- Internal helper for FETCH. Note this allows illegal expressions to be put together. However many +-- potentially interesting expressions are valid. Such as: +-- +-- `VALUES (1, 'o'), (2, 't'), (3, 'th') order by column2 fetch first (select 2) ROW with ties;` +-- +-- How to best expose these is not clear at this moment as we do not generally allow any raw sql to +-- be injected, but we do not have a good expression to capture the allowed values here. Finally, it +-- would _appear_ that the same restrictions here would also apply to expressions allowed for +-- LIMIT. Which as of this writing, we do not have a helper for creation. +-- +-- Finally note that NEXT and ROW are as PostgreSQL docs call them, noise words, they do not impact +-- the meaning. See https://www.postgresql.org/docs/13/sql-select.html. 'NEXT' and 'ROW' are chosen +-- over 'FIRST' and 'ROWS' respecitvely because they are shorter and thus result in a smaller +-- bytestring being sent over the wire. +internal_fetchRaw :: RawSql.RawSql -> FetchClauseModifier -> FetchClause +internal_fetchRaw countingRawSql modifier = + FetchClause $ + RawSql.fromString "FETCH NEXT " + <> RawSql.parenthesized countingRawSql + <> RawSql.fromString " ROW " + <> RawSql.toRawSql modifier + +{- | Type to represent the treatment of ties in a SQL FETCH expression. E.G. + +> WITH TIES + +'FetchClauseModifier' provides a 'RawSql.SqlExpression' instance. See +'RawSql.unsafeSqlExpression' for how to construct a value with your own custom +SQL. + +@since 1.1.0.0 +-} +newtype FetchClauseModifier + = FetchClauseModifier RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | Allow a FETCH clause to have ties. + +@since 1.1.0.0 +-} +withTiesFetchClauseModifier :: FetchClauseModifier +withTiesFetchClauseModifier = + FetchClauseModifier (RawSql.fromString "WITH TIES") + +{- | Disallow a FETCH clause to have ties. + +@since 1.1.0.0 +-} +onlyFetchClauseModifier :: FetchClauseModifier +onlyFetchClauseModifier = + FetchClauseModifier (RawSql.fromString "ONLY") diff --git a/src/Orville/PostgreSQL/Expr/Filter.hs b/src/Orville/PostgreSQL/Expr/Filter.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/Filter.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{- | +Copyright : Flipstone Technology Partners 2024 +License : MIT +Stability : Stable + +@since 1.1.0.0 +-} +module Orville.PostgreSQL.Expr.Filter + ( FilterExpr + , filterExpr + ) where + +import qualified Orville.PostgreSQL.Expr.WhereClause as WhereClause +import qualified Orville.PostgreSQL.Raw.RawSql as RawSql + +{- | 'FilterExpr' represents the @FILTER@ subexpression E.G. + +> FILTER (WHERE some_boolean_expr) + + +'FilterExpr' provides a 'RawSql.SqlExpression' instance. See +'RawSql.unsafeSqlExpression' for how to construct a value with your own custom +SQL. + +@since 1.1.0.0 +-} +newtype FilterExpr = FilterExpr RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | Builds a 'FilterExpr' with the given 'WhereClause.WhereClause' + +@since 1.1.0.0 +-} +filterExpr :: WhereClause.WhereClause -> FilterExpr +filterExpr whereClause = + FilterExpr $ + RawSql.fromString "FILTER" + <> RawSql.parenthesized (RawSql.toRawSql whereClause) diff --git a/src/Orville/PostgreSQL/Expr/Function.hs b/src/Orville/PostgreSQL/Expr/Function.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/Function.hs @@ -0,0 +1,247 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{- | +Copyright : Flipstone Technology Partners 2024 +License : MIT +Stability : Stable + +@since 1.1.0.0 +-} +module Orville.PostgreSQL.Expr.Function + ( DropFunctionExpr + , dropFunction + , CreateFunctionExpr + , createFunction + , FunctionReturns + , returns + , ReturnType + , returnTypeTrigger + , FunctionLanguage + , language + , LanguageName + , plpgsql + , FunctionDefinition + , asDefinition + ) where + +import qualified Data.ByteString.Char8 as BS8 +import Data.Maybe (catMaybes) + +import Orville.PostgreSQL.Expr.IfExists (IfExists) +import Orville.PostgreSQL.Expr.Name (FunctionName, QualifiedOrUnqualified) +import Orville.PostgreSQL.Expr.OrReplace (OrReplace) +import qualified Orville.PostgreSQL.Raw.RawSql as RawSql + +{- | Type to represent a SQL "DROP FUNCTION" statement. E.G. + +> DROP FUNCTION my_function + +'DropFunctionExpr' provides a 'RawSql.SqlExpression' instance. See +'RawSql.unsafeSqlExpression' for how to construct a value with your own custom +SQL. + +@since 1.1.0.0 +-} +newtype DropFunctionExpr + = DropFunctionExpr RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | Constructs a SQL @DROP FUNCTION@ statement from a function name. + +@since 1.1.0.0 +-} +dropFunction :: Maybe IfExists -> QualifiedOrUnqualified FunctionName -> DropFunctionExpr +dropFunction maybeIfExists name = + DropFunctionExpr $ + RawSql.intercalate + RawSql.space + ( catMaybes + [ Just (RawSql.fromString "DROP FUNCTION") + , fmap RawSql.toRawSql maybeIfExists + , Just (RawSql.toRawSql name) + ] + ) + +{- | Type to represent a SQL "CREATE FUNCTION" statement. E.G. + +> CREATE FUNCTION my_function RETURNS trigger AS '' + +'CreateFunctionExpr' provides a 'RawSql.SqlExpression' instance. See +'RawSql.unsafeSqlExpression' for how to construct a value with your own custom +SQL. + +@since 1.1.0.0 +-} +newtype CreateFunctionExpr + = CreateFunctionExpr RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | Constructs a SQL @CREATE FUNCTION@ statement from a function name, return type, +language and definiton. + +Note: Orville does not currently support creating functions with arguments. + +@since 1.1.0.0 +-} +createFunction :: + Maybe OrReplace -> + QualifiedOrUnqualified FunctionName -> + FunctionReturns -> + FunctionLanguage -> + FunctionDefinition -> + CreateFunctionExpr +createFunction maybeOrReplace name functionReturns functionLanguage definition = + CreateFunctionExpr $ + RawSql.intercalate + RawSql.space + ( catMaybes + [ Just $ RawSql.fromString "CREATE" + , fmap RawSql.toRawSql maybeOrReplace + , Just $ RawSql.fromString "FUNCTION" + , Just $ RawSql.toRawSql name + , Just $ RawSql.fromString "()" -- currently we don't support specifying arguments + , Just $ RawSql.toRawSql functionReturns + , Just $ RawSql.toRawSql functionLanguage + , Just $ RawSql.toRawSql definition + ] + ) + +{- | Type to represent the return specifier given as part of a SQL "CREATE +FUNCTION" statement. E.G. the @RETURNS trigger@ in + +> CREATE FUNCTION my_function RETURNS trigger + +'FunctionReturns' provides a 'RawSql.SqlExpression' instance. See +'RawSql.unsafeSqlExpression' for how to construct a value with your own custom +SQL. + +@since 1.1.0.0 +-} +newtype FunctionReturns + = FunctionReturns RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | Constructs a @RETURNS@ specifier for a @CREATE FUNCTION@ statement with the + given return type. + +@since 1.1.0.0 +-} +returns :: ReturnType -> FunctionReturns +returns returnType = + FunctionReturns $ RawSql.fromString "RETURNS " <> RawSql.toRawSql returnType + +{- | Type to represent the return type given as part of a SQL "CREATE +FUNCTION" statement. E.G. the @trigger@ in + +> CREATE FUNCTION my_function RETURNS trigger + +'ReturnType' provides a 'RawSql.SqlExpression' instance. See +'RawSql.unsafeSqlExpression' for how to construct a value with your own custom +SQL. + +@since 1.1.0.0 +-} +newtype ReturnType + = ReturnType RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | The @trigger@ return type. + +@since 1.1.0.0 +-} +returnTypeTrigger :: ReturnType +returnTypeTrigger = + ReturnType (RawSql.fromString "trigger") + +{- | Type to represent the language specifier given as part of a SQL "CREATE +FUNCTION" statement. E.G. the @LANGUAGE plpgsql@ in + +> CREATE FUNCTION my_function LANGUAGE plpgsql + +'FunctionLanguage' provides a 'RawSql.SqlExpression' instance. See +'RawSql.unsafeSqlExpression' for how to construct a value with your own custom +SQL. + +@since 1.1.0.0 +-} +newtype FunctionLanguage + = FunctionLanguage RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | Constructs a @LANGUAGE@ specifier for a @CREATE FUNCTION@ statement with the + given language name as the language. + +@since 1.1.0.0 +-} +language :: LanguageName -> FunctionLanguage +language name = + FunctionLanguage $ RawSql.fromString "LANGUAGE " <> RawSql.toRawSql name + +{- | Type to represent the language that the function definition is given in as part +of a SQL "CREATE FUNCTION" statement. E.G. the @plpgsql@ in + +> CREATE FUNCTION my_function LANGUAGE plpgsql + +'LanguageName' provides a 'RawSql.SqlExpression' instance. See +'RawSql.unsafeSqlExpression' for how to construct a value with your own custom +SQL. + +@since 1.1.0.0 +-} +newtype LanguageName + = LanguageName RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | The @plpgsql@ language. + +@since 1.1.0.0 +-} +plpgsql :: LanguageName +plpgsql = + LanguageName (RawSql.fromString "plpgsql") + +{- | Type to represent the definition body of a a SQL "CREATE FUNCTION" statement. E.G. the +@AS @ in + +> CREATE FUNCTION my_function AS + +'FunctionDefinition' provides a 'RawSql.SqlExpression' instance. See +'RawSql.unsafeSqlExpression' for how to construct a value with your own custom +SQL. + +@since 1.1.0.0 +-} +newtype FunctionDefinition + = FunctionDefinition RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | Constructs a 'FunctionDefinition' from a 'String', which will be passed as an + escaped string literal to PosgreSQL. + +@since 1.1.0.0 +-} +asDefinition :: String -> FunctionDefinition +asDefinition body = + FunctionDefinition $ + RawSql.fromString "AS " <> RawSql.stringLiteral (BS8.pack body) diff --git a/src/Orville/PostgreSQL/Expr/GroupBy.hs b/src/Orville/PostgreSQL/Expr/GroupBy.hs --- a/src/Orville/PostgreSQL/Expr/GroupBy.hs +++ b/src/Orville/PostgreSQL/Expr/GroupBy.hs @@ -1,7 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {- | -Copyright : Flipstone Technology Partners 2023 +Copyright : Flipstone Technology Partners 2023-2024 License : MIT Stability : Stable @@ -18,11 +18,10 @@ import Data.List.NonEmpty (NonEmpty) -import Orville.PostgreSQL.Expr.Name (ColumnName) +import Orville.PostgreSQL.Expr.Name (ColumnName, QualifiedOrUnqualified) import qualified Orville.PostgreSQL.Raw.RawSql as RawSql -{- | -Type to represent a SQL group by clause. E.G. +{- | Type to represent a SQL group by clause. E.G. > GROUP BY team_name @@ -46,8 +45,7 @@ groupByClause :: GroupByExpr -> GroupByClause groupByClause expr = GroupByClause (RawSql.fromString "GROUP BY " <> RawSql.toRawSql expr) -{- | -Type to represent a SQL group by expression (the part that follows the +{- | Type to represent a SQL group by expression (the part that follows the @GROUP BY@ in SQL). E.G. > team_name @@ -83,6 +81,6 @@ @since 1.0.0.0 -} -groupByColumnsExpr :: NonEmpty ColumnName -> GroupByExpr +groupByColumnsExpr :: NonEmpty (QualifiedOrUnqualified ColumnName) -> GroupByExpr groupByColumnsExpr = GroupByExpr . RawSql.intercalate RawSql.commaSpace diff --git a/src/Orville/PostgreSQL/Expr/IfExists.hs b/src/Orville/PostgreSQL/Expr/IfExists.hs --- a/src/Orville/PostgreSQL/Expr/IfExists.hs +++ b/src/Orville/PostgreSQL/Expr/IfExists.hs @@ -15,8 +15,7 @@ import qualified Orville.PostgreSQL.Raw.RawSql as RawSql -{- | -Type to represent a SQL "IF EXISTS" expression. E.G. +{- | Type to represent a SQL "IF EXISTS" expression. E.G. > IF EXISTS @@ -33,8 +32,7 @@ RawSql.SqlExpression ) -{- | -A value of the SQL "IF EXISTS". +{- | A value of the SQL "IF EXISTS". @since 1.0.0.0 -} diff --git a/src/Orville/PostgreSQL/Expr/IfNotExists.hs b/src/Orville/PostgreSQL/Expr/IfNotExists.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/IfNotExists.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{- | +Copyright : Flipstone Technology Partners 2024 +License : MIT +Stability : Stable + +@since 1.1.0.0 +-} +module Orville.PostgreSQL.Expr.IfNotExists + ( IfNotExists + , ifNotExists + ) +where + +import qualified Orville.PostgreSQL.Raw.RawSql as RawSql + +{- | Type to represent a SQL "IF NOT EXISTS" expression. E.G. + +> IF NOT EXISTS + +It is notable that 'IfNotExists' and 'Orville.PostgreSQL.Expr.IfExists' are not usable in all the +same places. + +'IfNotExists' provides a 'RawSql.SqlExpression' instance. See +'RawSql.unsafeSqlExpression' for how to construct a value with your own custom +SQL. + +@since 1.1.0.0 +-} +newtype IfNotExists + = IfNotExists RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | A value of the SQL "IF NOT EXISTS". + +@since 1.1.0.0 +-} +ifNotExists :: IfNotExists +ifNotExists = + IfNotExists $ RawSql.fromString "IF NOT EXISTS" diff --git a/src/Orville/PostgreSQL/Expr/Index.hs b/src/Orville/PostgreSQL/Expr/Index.hs --- a/src/Orville/PostgreSQL/Expr/Index.hs +++ b/src/Orville/PostgreSQL/Expr/Index.hs @@ -23,11 +23,10 @@ import Data.List.NonEmpty (NonEmpty) -import Orville.PostgreSQL.Expr.Name (ColumnName, IndexName, Qualified, TableName) +import Orville.PostgreSQL.Expr.Name (ColumnName, IndexName, QualifiedOrUnqualified, TableName) import qualified Orville.PostgreSQL.Raw.RawSql as RawSql -{- | -Type to represent a SQL "CREATE INDEX" statement. E.G. +{- | Type to represent a SQL "CREATE INDEX" statement. E.G. > CREATE INDEX ON table (foo, bar, baz) @@ -44,8 +43,7 @@ RawSql.SqlExpression ) -{- | -Construct a SQL CREATE INDEX from an indicator of if the index should be +{- | Construct a SQL CREATE INDEX from an indicator of if the index should be unique, a table, and corresponding collection of 'ColumnName's. @since 1.0.0.0 @@ -53,7 +51,7 @@ createIndexExpr :: IndexUniqueness -> Maybe ConcurrentlyExpr -> - Qualified TableName -> + QualifiedOrUnqualified TableName -> NonEmpty ColumnName -> CreateIndexExpr createIndexExpr uniqueness mbConcurrently tableName columns = @@ -61,14 +59,13 @@ RawSql.fromString "CREATE " <> uniquenessToSql uniqueness <> RawSql.fromString "INDEX " - <> maybe mempty (<> RawSql.space) (fmap RawSql.toRawSql mbConcurrently) + <> maybe mempty ((<> RawSql.space) . RawSql.toRawSql) mbConcurrently <> RawSql.fromString "ON " <> RawSql.toRawSql tableName <> RawSql.space <> RawSql.toRawSql (indexBodyColumns columns) -{- | -Construct a SQL CREATE INDEX from an indicator of if the index should be +{- | Construct a SQL CREATE INDEX from an indicator of if the index should be unique, a table, a name for the index, and some SQL representing the rest of the index creation. @@ -77,7 +74,7 @@ createNamedIndexExpr :: IndexUniqueness -> Maybe ConcurrentlyExpr -> - Qualified TableName -> + QualifiedOrUnqualified TableName -> IndexName -> IndexBodyExpr -> CreateIndexExpr @@ -86,15 +83,14 @@ RawSql.fromString "CREATE " <> uniquenessToSql uniqueness <> RawSql.fromString "INDEX " - <> maybe mempty (<> RawSql.space) (fmap RawSql.toRawSql mbConcurrently) + <> maybe mempty ((<> RawSql.space) . RawSql.toRawSql) mbConcurrently <> RawSql.toRawSql indexName <> RawSql.fromString " ON " <> RawSql.toRawSql tableName <> RawSql.space <> RawSql.toRawSql bodyExpr -{- | -Type to represent the @CONCURRENTLY@ keyword for index creation. E.G. +{- | Type to represent the @CONCURRENTLY@ keyword for index creation. E.G. > CONCURRENTLY @@ -111,8 +107,7 @@ RawSql.SqlExpression ) -{- | -The @CONCURRENTLY@ keyword indicates to PostgreSQL that an index should be +{- | The @CONCURRENTLY@ keyword indicates to PostgreSQL that an index should be created concurrently. @since 1.0.0.0 @@ -121,8 +116,7 @@ concurrently = RawSql.unsafeSqlExpression "CONCURRENTLY" -{- | -Type to represent the body of an index definition E.G. +{- | Type to represent the body of an index definition E.G. > (foo, bar) @@ -143,8 +137,7 @@ RawSql.SqlExpression ) -{- | -Creates an 'IndexBodyExpr' for the given column names. The resulting +{- | Creates an 'IndexBodyExpr' for the given column names. The resulting SQL looks like @(column1, column2, ...)@. @since 1.0.0.0 @@ -158,8 +151,7 @@ <> RawSql.intercalate RawSql.comma columns <> RawSql.rightParen -{- | -Type to represent if an index should be unique. +{- | Type to represent if an index should be unique. @since 1.0.0.0 -} @@ -182,8 +174,7 @@ UniqueIndex -> RawSql.fromString "UNIQUE " NonUniqueIndex -> mempty -{- | -Type to represent a SQL "DROP INDEX" statement. E.G. +{- | Type to represent a SQL "DROP INDEX" statement. E.G. > DROP INDEX foo @@ -200,12 +191,11 @@ RawSql.SqlExpression ) -{- | -Construct a SQL DROP INDEX for a given 'IndexName'. +{- | Construct a SQL DROP INDEX for a given 'IndexName'. @since 1.0.0.0 -} -dropIndexExpr :: IndexName -> DropIndexExpr +dropIndexExpr :: QualifiedOrUnqualified IndexName -> DropIndexExpr dropIndexExpr indexName = DropIndexExpr $ RawSql.fromString "DROP INDEX " <> RawSql.toRawSql indexName diff --git a/src/Orville/PostgreSQL/Expr/Insert.hs b/src/Orville/PostgreSQL/Expr/Insert.hs --- a/src/Orville/PostgreSQL/Expr/Insert.hs +++ b/src/Orville/PostgreSQL/Expr/Insert.hs @@ -1,7 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {- | -Copyright : Flipstone Technology Partners 2023 +Copyright : Flipstone Technology Partners 2023-2024 License : MIT Stability : Stable @@ -16,18 +16,21 @@ , insertSqlValues , RowValues , rowValues + , valuesExprInsertSource ) where import Data.Maybe (catMaybes) -import Orville.PostgreSQL.Expr.Name (ColumnName, Qualified, TableName) +import qualified Data.List.NonEmpty as NE +import Orville.PostgreSQL.Expr.Name (ColumnName, QualifiedOrUnqualified, TableName) +import Orville.PostgreSQL.Expr.OnConflict (OnConflictExpr) import Orville.PostgreSQL.Expr.ReturningExpr (ReturningExpr) +import Orville.PostgreSQL.Expr.Values (ValuesExpr) import qualified Orville.PostgreSQL.Raw.RawSql as RawSql import Orville.PostgreSQL.Raw.SqlValue (SqlValue) -{- | -Type to represent a SQL "INSERT" statement. E.G. +{- | Type to represent a SQL "INSERT" statement. E.G. > INSERT INTO foo (id) VALUES (1),(3),(3) @@ -52,12 +55,13 @@ @since 1.0.0.0 -} insertExpr :: - Qualified TableName -> + QualifiedOrUnqualified TableName -> Maybe InsertColumnList -> InsertSource -> + Maybe OnConflictExpr -> Maybe ReturningExpr -> InsertExpr -insertExpr target maybeInsertColumns source maybeReturning = +insertExpr target maybeInsertColumns source maybeOnConflict maybeReturning = InsertExpr . RawSql.intercalate RawSql.space $ catMaybes @@ -65,11 +69,11 @@ , Just $ RawSql.toRawSql target , fmap RawSql.toRawSql maybeInsertColumns , Just $ RawSql.toRawSql source + , fmap RawSql.toRawSql maybeOnConflict , fmap RawSql.toRawSql maybeReturning ] -{- | -Type to represent the SQL columns list for an insert statement. E.G. +{- | Type to represent the SQL columns list for an insert statement. E.G. > (foo,bar,baz) @@ -91,15 +95,15 @@ @since 1.0.0.0 -} -insertColumnList :: [ColumnName] -> InsertColumnList +insertColumnList :: [QualifiedOrUnqualified ColumnName] -> InsertColumnList insertColumnList columnNames = InsertColumnList $ - RawSql.leftParen - <> RawSql.intercalate RawSql.comma (fmap RawSql.toRawSql columnNames) - <> RawSql.rightParen + maybe + mempty + (RawSql.parenthesized . RawSql.intercalate RawSql.comma . fmap RawSql.toRawSql) + (NE.nonEmpty columnNames) -{- | -Type to represent the SQL for the source of data for an insert statement. E.G. +{- | Type to represent the SQL for the source of data for an insert statement. E.G. > VALUES ('Bob',32),('Cindy',33) @@ -116,6 +120,15 @@ RawSql.SqlExpression ) +{- | Use a 'ValuesExpr' as an 'InsertSource'. + +@since 1.1.0.0 +-} +valuesExprInsertSource :: ValuesExpr -> InsertSource +valuesExprInsertSource = InsertSource . RawSql.toRawSql + +{-# DEPRECATED insertRowValues "Use Orville.PostgreSQL.Expr.valuesExpr and Orville.PostgreSQL.Expr.valuesExprInsertSource" #-} + {- | Create an 'InsertSource' for the given 'RowValues'. This ensures that all input values are used as parameters and comma-separated in the generated SQL. @@ -127,6 +140,8 @@ RawSql.fromString "VALUES " <> RawSql.intercalate RawSql.comma (fmap RawSql.toRawSql rows) +{-# DEPRECATED insertSqlValues "Use Orville.PostgreSQL.Expr.ValuesExpr and Orivlle.PostgreSQL.Expr.valuesExprInsertSource" #-} + {- | Create an 'InsertSource' for the given 'SqlValue's. This ensures that all input values are used as parameters and comma-separated in the generated SQL. @@ -136,8 +151,7 @@ insertSqlValues = insertRowValues . fmap rowValues -{- | -Type to represent a SQL row literal. For example, a single row to insert +{- | Type to represent a SQL row literal. For example, a single row to insert in a @VALUES@ clause. E.G. > ('Cindy',33) diff --git a/src/Orville/PostgreSQL/Expr/Internal/Name/Alias.hs b/src/Orville/PostgreSQL/Expr/Internal/Name/Alias.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/Internal/Name/Alias.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{- | +Copyright : Flipstone Technology Partners 2024-2205 +License : MIT +Stability : Stable + +@since 1.1.0.0 +-} +module Orville.PostgreSQL.Expr.Internal.Name.Alias + ( AliasExpr + , stringToAliasExpr + ) +where + +import Orville.PostgreSQL.Expr.Internal.Name.Identifier (Identifier, IdentifierExpression, identifier) +import qualified Orville.PostgreSQL.Raw.RawSql as RawSql + +{- | Type to represent a SQL alias. 'AliasExpr' values constructed +via the 'alias' function will be properly escaped as part of the +generated SQL. E.G. + +> "some_alias" + +'AliasExpr' provides a 'RawSql.SqlExpression' instance. See +'RawSql.unsafeSqlExpression' for how to construct a value with your own custom +SQL. + +@since 1.1.0.0 +-} +newtype AliasExpr + = AliasExpr Identifier + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + , -- | @since 1.1.0.0 + IdentifierExpression + ) + +{- | Construct an 'AliasExpr' from a 'String' with proper escaping as part of the generated SQL. + +@since 1.1.0.0 +-} +stringToAliasExpr :: String -> AliasExpr +stringToAliasExpr = + AliasExpr . identifier diff --git a/src/Orville/PostgreSQL/Expr/Internal/Name/ColumnName.hs b/src/Orville/PostgreSQL/Expr/Internal/Name/ColumnName.hs --- a/src/Orville/PostgreSQL/Expr/Internal/Name/ColumnName.hs +++ b/src/Orville/PostgreSQL/Expr/Internal/Name/ColumnName.hs @@ -16,8 +16,7 @@ import Orville.PostgreSQL.Expr.Internal.Name.Identifier (Identifier, IdentifierExpression, identifier) import qualified Orville.PostgreSQL.Raw.RawSql as RawSql -{- | -Type to represent a SQL column name. 'ColumnName' values constructed via the +{- | Type to represent a SQL column name. 'ColumnName' values constructed via the 'columnName' function will be properly escaped as part of the generated SQL. E.G. > "some_column_name" @@ -37,8 +36,7 @@ IdentifierExpression ) -{- | -Construct a 'ColumnName' from a 'String' with proper escaping as part of the generated SQL. +{- | Construct a 'ColumnName' from a 'String' with proper escaping as part of the generated SQL. @since 1.0.0.0 -} diff --git a/src/Orville/PostgreSQL/Expr/Internal/Name/ConstraintName.hs b/src/Orville/PostgreSQL/Expr/Internal/Name/ConstraintName.hs --- a/src/Orville/PostgreSQL/Expr/Internal/Name/ConstraintName.hs +++ b/src/Orville/PostgreSQL/Expr/Internal/Name/ConstraintName.hs @@ -16,8 +16,7 @@ import Orville.PostgreSQL.Expr.Internal.Name.Identifier (Identifier, IdentifierExpression, identifier) import qualified Orville.PostgreSQL.Raw.RawSql as RawSql -{- | -Type to represent a SQL constraint name. 'ConstraintName' values constructed +{- | Type to represent a SQL constraint name. 'ConstraintName' values constructed via the 'constraintName' function will be properly escaped as part of the generated SQL. E.G. @@ -38,8 +37,7 @@ IdentifierExpression ) -{- | -Construct a 'ConstraintName' from a 'String' with proper escaping as part of the generated SQL. +{- | Construct a 'ConstraintName' from a 'String' with proper escaping as part of the generated SQL. @since 1.0.0.0 -} diff --git a/src/Orville/PostgreSQL/Expr/Internal/Name/CursorName.hs b/src/Orville/PostgreSQL/Expr/Internal/Name/CursorName.hs --- a/src/Orville/PostgreSQL/Expr/Internal/Name/CursorName.hs +++ b/src/Orville/PostgreSQL/Expr/Internal/Name/CursorName.hs @@ -16,8 +16,7 @@ import Orville.PostgreSQL.Expr.Internal.Name.Identifier (Identifier, IdentifierExpression, identifier) import qualified Orville.PostgreSQL.Raw.RawSql as RawSql -{- | -Type to represent a SQL cursor name. 'CursorName' values constructed +{- | Type to represent a SQL cursor name. 'CursorName' values constructed via the 'cursorName' function will be properly escaped as part of the generated SQL. E.G. @@ -38,8 +37,7 @@ IdentifierExpression ) -{- | -Construct a 'CursorName' from a 'String' with proper escaping as part of the generated SQL. +{- | Construct a 'CursorName' from a 'String' with proper escaping as part of the generated SQL. @since 1.0.0.0 -} diff --git a/src/Orville/PostgreSQL/Expr/Internal/Name/ExtensionName.hs b/src/Orville/PostgreSQL/Expr/Internal/Name/ExtensionName.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/Internal/Name/ExtensionName.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{- | +Copyright : Flipstone Technology Partners 2024 +License : MIT +Stability : Stable + +@since 1.1.0.0 +-} +module Orville.PostgreSQL.Expr.Internal.Name.ExtensionName + ( ExtensionName + , extensionName + ) +where + +import Orville.PostgreSQL.Expr.Internal.Name.Identifier (Identifier, IdentifierExpression, identifier) +import qualified Orville.PostgreSQL.Raw.RawSql as RawSql + +{- | Type to represent a PostgreSQL extension name. 'ExtensionName' values constructed via the +'extensionName' function will be properly escaped as part of the generated SQL. E.G. + +> "some_extension_name" + +'ExtensionName' provides a 'RawSql.SqlExpression' instance. See +'RawSql.unsafeSqlExpression' for how to construct a value with your own custom +SQL. + +@since 1.1.0.0 +-} +newtype ExtensionName + = ExtensionName Identifier + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + , -- | @since 1.1.0.0 + IdentifierExpression + ) + +{- | Construct an 'ExtensionName' from a 'String'. + +@since 1.1.0.0 +-} +extensionName :: String -> ExtensionName +extensionName = ExtensionName . identifier diff --git a/src/Orville/PostgreSQL/Expr/Internal/Name/FunctionName.hs b/src/Orville/PostgreSQL/Expr/Internal/Name/FunctionName.hs --- a/src/Orville/PostgreSQL/Expr/Internal/Name/FunctionName.hs +++ b/src/Orville/PostgreSQL/Expr/Internal/Name/FunctionName.hs @@ -10,14 +10,37 @@ module Orville.PostgreSQL.Expr.Internal.Name.FunctionName ( FunctionName , functionName + , arrayAggFunctionName + , avgFunctionName + , bitAndFunctionName + , bitOrFunctionName + , bitXorFunctionName + , boolAndFunctionName + , boolOrFunctionName + , countFunctionName + , everyFunctionName + , jsonAggFunctionName + , jsonObjectAggFunctionName + , jsonbAggFunctionName + , jsonbObjectAggFunctionName + , maxFunctionName + , minFunctionName + , stringAggFunctionName + , sumFunctionName + , corFunctionName + , covarPopFunctionName + , covarSampFunctionName + , stddevPopFunctionName + , stddevSampFunctionName + , varPopFunctionName + , varSampFunctionName ) where import Orville.PostgreSQL.Expr.Internal.Name.Identifier (Identifier, IdentifierExpression, identifier) import qualified Orville.PostgreSQL.Raw.RawSql as RawSql -{- | -Type to represent a SQL function name. 'FunctionName' values constructed +{- | Type to represent a SQL function name. 'FunctionName' values constructed via the 'functionName' function will be properly escaped as part of the generated SQL. E.G. @@ -38,11 +61,178 @@ IdentifierExpression ) -{- | -Construct a 'FunctionName' from a 'String' with proper escaping as part of the generated SQL. +{- | Construct a 'FunctionName' from a 'String' with proper escaping as part of the generated SQL. @since 1.0.0.0 -} functionName :: String -> FunctionName functionName = FunctionName . identifier + +{- | The @array_agg@ window function name + +@since 1.1.0.0 +-} +arrayAggFunctionName :: FunctionName +arrayAggFunctionName = functionName "array_agg" + +{- | The @avg@ window function name + +@since 1.1.0.0 +-} +avgFunctionName :: FunctionName +avgFunctionName = functionName "avg" + +{- | The @bit_and@ window function name + +@since 1.1.0.0 +-} +bitAndFunctionName :: FunctionName +bitAndFunctionName = functionName "bit_and" + +{- | The @bit_or@ window function name + +@since 1.1.0.0 +-} +bitOrFunctionName :: FunctionName +bitOrFunctionName = functionName "bit_or" + +{- | The @bit_xor@ window function name + +@since 1.1.0.0 +-} +bitXorFunctionName :: FunctionName +bitXorFunctionName = functionName "bit_xor" + +{- | The @bool_and@ window function name + +@since 1.1.0.0 +-} +boolAndFunctionName :: FunctionName +boolAndFunctionName = functionName "bool_and" + +{- | The @bool_or@ window function name + +@since 1.1.0.0 +-} +boolOrFunctionName :: FunctionName +boolOrFunctionName = functionName "bool_or" + +{- | The @count@ window function name + +@since 1.1.0.0 +-} +countFunctionName :: FunctionName +countFunctionName = functionName "count" + +{- | The @every@ window function name + +@since 1.1.0.0 +-} +everyFunctionName :: FunctionName +everyFunctionName = functionName "every" + +{- | The @json_agg@ window function name + +@since 1.1.0.0 +-} +jsonAggFunctionName :: FunctionName +jsonAggFunctionName = functionName "json_agg" + +{- | The @json_object_agg@ window function name + +@since 1.1.0.0 +-} +jsonObjectAggFunctionName :: FunctionName +jsonObjectAggFunctionName = functionName "json_object_agg" + +{- | The @jsonb_agg@ window function name + +@since 1.1.0.0 +-} +jsonbAggFunctionName :: FunctionName +jsonbAggFunctionName = functionName "jsonb_agg" + +{- | The @jsonb_object_agg@ window function name + +@since 1.1.0.0 +-} +jsonbObjectAggFunctionName :: FunctionName +jsonbObjectAggFunctionName = functionName "jsonb_object_agg" + +{- | The @max@ window function name + +@since 1.1.0.0 +-} +maxFunctionName :: FunctionName +maxFunctionName = functionName "max" + +{- | The @min@ window function name + +@since 1.1.0.0 +-} +minFunctionName :: FunctionName +minFunctionName = functionName "min" + +{- | The @string_agg@ window function name + +@since 1.1.0.0 +-} +stringAggFunctionName :: FunctionName +stringAggFunctionName = functionName "string_agg" + +{- | The @sum@ window function name + +@since 1.1.0.0 +-} +sumFunctionName :: FunctionName +sumFunctionName = functionName "sum" + +{- | The @cor@ window function name + +@since 1.1.0.0 +-} +corFunctionName :: FunctionName +corFunctionName = functionName "cor" + +{- | The @covar_pop@ window function name + +@since 1.1.0.0 +-} +covarPopFunctionName :: FunctionName +covarPopFunctionName = functionName "covar_pop" + +{- | The @covar_samp@ window function name + +@since 1.1.0.0 +-} +covarSampFunctionName :: FunctionName +covarSampFunctionName = functionName "covar_samp" + +{- | The @stddev_pop@ window function name + +@since 1.1.0.0 +-} +stddevPopFunctionName :: FunctionName +stddevPopFunctionName = functionName "stddev_pop" + +{- | The @stddev_samp@ window function name + +@since 1.1.0.0 +-} +stddevSampFunctionName :: FunctionName +stddevSampFunctionName = functionName "stddev_samp" + +{- | The @var_pop@ window function name + +@since 1.1.0.0 +-} +varPopFunctionName :: FunctionName +varPopFunctionName = functionName "var_pop" + +{- | The @var_samp@ window function name + +@since 1.1.0.0 +-} +varSampFunctionName :: FunctionName +varSampFunctionName = functionName "var_samp" diff --git a/src/Orville/PostgreSQL/Expr/Internal/Name/Identifier.hs b/src/Orville/PostgreSQL/Expr/Internal/Name/Identifier.hs --- a/src/Orville/PostgreSQL/Expr/Internal/Name/Identifier.hs +++ b/src/Orville/PostgreSQL/Expr/Internal/Name/Identifier.hs @@ -18,8 +18,7 @@ import qualified Data.ByteString.Char8 as B8 import qualified Orville.PostgreSQL.Raw.RawSql as RawSql -{- | -Type to represent a SQL identifier. 'Identifier' values constructed via the +{- | Type to represent a SQL identifier. 'Identifier' values constructed via the 'identifier' function will be properly escaped as part of the generated SQL. E.G. @@ -38,8 +37,7 @@ RawSql.SqlExpression ) -{- | -Construct an 'Identifier' from a 'String' with proper escaping as part of the generated SQL. +{- | Construct an 'Identifier' from a 'String' with proper escaping as part of the generated SQL. @since 1.0.0.0 -} @@ -47,8 +45,7 @@ identifier = identifierFromBytes . B8.pack -{- | -Construct an 'Identifier' from a 'B8.ByteString' with proper escaping as part of the generated SQL. +{- | Construct an 'Identifier' from a 'B8.ByteString' with proper escaping as part of the generated SQL. @since 1.0.0.0 -} diff --git a/src/Orville/PostgreSQL/Expr/Internal/Name/IndexName.hs b/src/Orville/PostgreSQL/Expr/Internal/Name/IndexName.hs --- a/src/Orville/PostgreSQL/Expr/Internal/Name/IndexName.hs +++ b/src/Orville/PostgreSQL/Expr/Internal/Name/IndexName.hs @@ -16,8 +16,7 @@ import Orville.PostgreSQL.Expr.Internal.Name.Identifier (Identifier, IdentifierExpression, identifier) import qualified Orville.PostgreSQL.Raw.RawSql as RawSql -{- | -Type to represent a SQL index name. 'IndexName' values constructed via the +{- | Type to represent a SQL index name. 'IndexName' values constructed via the 'indexName' function will be properly escaped as part of the generated SQL. E.G. > "some_index_name" @@ -37,8 +36,7 @@ IdentifierExpression ) -{- | -Construct an 'IndexName' from a 'String' with proper escaping as part of the generated SQL. +{- | Construct an 'IndexName' from a 'String' with proper escaping as part of the generated SQL. @since 1.0.0.0 -} diff --git a/src/Orville/PostgreSQL/Expr/Internal/Name/Qualified.hs b/src/Orville/PostgreSQL/Expr/Internal/Name/Qualified.hs --- a/src/Orville/PostgreSQL/Expr/Internal/Name/Qualified.hs +++ b/src/Orville/PostgreSQL/Expr/Internal/Name/Qualified.hs @@ -1,7 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {- | -Copyright : Flipstone Technology Partners 2023 +Copyright : Flipstone Technology Partners 2023-2025 License : MIT Stability : Stable @@ -11,22 +11,69 @@ ( Qualified , qualifyTable , qualifySequence + , qualifyFunction + , qualifyIndex , qualifyColumn + , aliasQualifyColumn + , QualifiedOrUnqualified + , untrackQualified + , unqualified ) where +import Orville.PostgreSQL.Expr.Internal.Name.Alias (AliasExpr) import Orville.PostgreSQL.Expr.Internal.Name.ColumnName (ColumnName) +import Orville.PostgreSQL.Expr.Internal.Name.FunctionName (FunctionName) import Orville.PostgreSQL.Expr.Internal.Name.Identifier (IdentifierExpression (toIdentifier)) +import Orville.PostgreSQL.Expr.Internal.Name.IndexName (IndexName) import Orville.PostgreSQL.Expr.Internal.Name.SchemaName (SchemaName) import Orville.PostgreSQL.Expr.Internal.Name.SequenceName (SequenceName) import Orville.PostgreSQL.Expr.Internal.Name.TableName (TableName) import qualified Orville.PostgreSQL.Raw.RawSql as RawSql -{- | -Type to represent a qualified SQL name. E.G. +{- | Type to represent a SQL name that could be qualified or not. E.G. > "some_schema_name"."some_table_name" +or + +> "some_table_name" + +'QualifiedOrUnqualified' provides a 'RawSql.SqlExpression' instance. See +'RawSql.unsafeSqlExpression' for how to construct a value with your own custom +SQL. + +@since 1.1.0.0 +-} +newtype QualifiedOrUnqualified name + = QualifiedOrUnqualified RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | 'untrackQualified' loses the information of the value certainly having a qualification. This is + useful when working with functionality that takes a 'QualifiedOrUnqualifed name'. + +@since 1.1.0.0 +-} +untrackQualified :: Qualified name -> QualifiedOrUnqualified name +untrackQualified = + QualifiedOrUnqualified . RawSql.toRawSql + +{- | 'unqualified' loses the information of the value not having a qualification. This is + useful when working with functionality that takes a 'QualifiedOrUnqualifed name'. + +@since 1.1.0.0 +-} +unqualified :: RawSql.SqlExpression name => name -> QualifiedOrUnqualified name +unqualified = + QualifiedOrUnqualified . RawSql.toRawSql + +{- | Type to represent a qualified SQL name. E.G. + +> "some_schema_name"."some_table_name" + 'Qualified' provides a 'RawSql.SqlExpression' instance. See 'RawSql.unsafeSqlExpression' for how to construct a value with your own custom SQL. @@ -40,8 +87,7 @@ RawSql.SqlExpression ) -{- | -Optionally qualifies a 'TableName' with a 'SchemaName'. +{- | Qualifies a 'TableName' with a 'SchemaName'. Note: If you already have a 'Orville.PostgreSQL.Schema.TableIdentifier' in hand you should probably use @@ -49,13 +95,12 @@ @since 1.0.0.0 -} qualifyTable :: - Maybe SchemaName -> + SchemaName -> TableName -> Qualified TableName qualifyTable = unsafeSchemaQualify -{- | -Optionally qualifies a 'SequenceName' with a 'SchemaName'. +{- | Qualifies a 'SequenceName' with a 'SchemaName'. Note: If you already have a 'Orville.PostgreSQL.Schema.SequenceIdentifier' in hand you should probably use @@ -64,13 +109,35 @@ @since 1.0.0.0 -} qualifySequence :: - Maybe SchemaName -> + SchemaName -> SequenceName -> Qualified SequenceName qualifySequence = unsafeSchemaQualify -{- | -Qualifies a 'ColumnName' with a 'TableName' and, optionally, a 'SchemaName'. +{- | Qualifies a 'FunctionName' with a 'SchemaName'. + +Note: If you already have a 'Orville.PostgreSQL.Schema.FunctionIdentifier' in +hand you should probably use +'Orville.PostgreSQL.Schema.functionIdQualifiedName' instead. + +@since 1.1.0.0 +-} +qualifyFunction :: + SchemaName -> + FunctionName -> + Qualified FunctionName +qualifyFunction = unsafeSchemaQualify + +{- | Qualifies an 'IndexName' with a 'SchemaName'. +@since 1.1.0.0 +-} +qualifyIndex :: + SchemaName -> + IndexName -> + Qualified IndexName +qualifyIndex = unsafeSchemaQualify + +{- | Qualifies a 'ColumnName' with a 'TableName' and, optionally, a 'SchemaName'. This should be used to refer to the column in SQL queries where a qualified reference is appropriate. @@ -78,25 +145,47 @@ -} qualifyColumn :: Maybe SchemaName -> TableName -> ColumnName -> Qualified ColumnName qualifyColumn mbSchemaName tableName unqualifiedName = - unsafeSchemaQualify mbSchemaName - . RawSql.unsafeFromRawSql - $ RawSql.toRawSql (toIdentifier tableName) <> RawSql.dot <> RawSql.toRawSql (toIdentifier unqualifiedName) + let + tableQualifiedColumn = + rawQualify tableName unqualifiedName + in + case mbSchemaName of + Nothing -> + Qualified tableQualifiedColumn + Just schemaName -> + Qualified (rawQualify schemaName tableQualifiedColumn) +{- | Qualifies a 'ColumnName' with an 'AliasExpr'. This should be used to refer to the column +in SQL queries where an aliased reference is appropriate. + +@since 1.1.0.0 +-} +aliasQualifyColumn :: AliasExpr -> ColumnName -> Qualified ColumnName +aliasQualifyColumn aliasName = + Qualified . rawQualify aliasName + -- Note: Not everything actually makes sense to be qualified by _only_ a schema name, such as -- columns, as in 'qualifyColumn'. But this does give us a nice uniform way to provide the -- functionality in those more type restricted scenarios. unsafeSchemaQualify :: IdentifierExpression name => - Maybe SchemaName -> + SchemaName -> name -> Qualified name -unsafeSchemaQualify mbSchemaName unqualifiedName = - case mbSchemaName of - Nothing -> - Qualified . RawSql.toRawSql . toIdentifier $ unqualifiedName - Just schemaName -> - Qualified - ( RawSql.toRawSql schemaName - <> RawSql.dot - <> RawSql.toRawSql (toIdentifier unqualifiedName) - ) +unsafeSchemaQualify schemaName = + Qualified . rawQualify schemaName . toIdentifier + +{- | + An internal helper to qualify any sql expressions as raw sql. The types for this + function do not enforce any relationship between the qualifier and the qualified + name, and the result is 'RawSql' rather than any more specific expression type. +-} +rawQualify :: + (RawSql.SqlExpression qualifier, RawSql.SqlExpression name) => + qualifier -> + name -> + RawSql.RawSql +rawQualify qualifier name = + RawSql.toRawSql qualifier + <> RawSql.dot + <> RawSql.toRawSql name diff --git a/src/Orville/PostgreSQL/Expr/Internal/Name/SavepointName.hs b/src/Orville/PostgreSQL/Expr/Internal/Name/SavepointName.hs --- a/src/Orville/PostgreSQL/Expr/Internal/Name/SavepointName.hs +++ b/src/Orville/PostgreSQL/Expr/Internal/Name/SavepointName.hs @@ -16,8 +16,7 @@ import Orville.PostgreSQL.Expr.Internal.Name.Identifier (Identifier, IdentifierExpression, identifier) import qualified Orville.PostgreSQL.Raw.RawSql as RawSql -{- | -Type to represent a SQL savepoint name. 'SavepointName' values constructed via +{- | Type to represent a SQL savepoint name. 'SavepointName' values constructed via the 'savepointName' function will be properly escaped as part of the generated SQL. E.G. @@ -38,8 +37,7 @@ IdentifierExpression ) -{- | -Construct a 'SavepointName' from a 'String' with proper escaping as part of the generated SQL. +{- | Construct a 'SavepointName' from a 'String' with proper escaping as part of the generated SQL. @since 1.0.0.0 -} diff --git a/src/Orville/PostgreSQL/Expr/Internal/Name/SchemaName.hs b/src/Orville/PostgreSQL/Expr/Internal/Name/SchemaName.hs --- a/src/Orville/PostgreSQL/Expr/Internal/Name/SchemaName.hs +++ b/src/Orville/PostgreSQL/Expr/Internal/Name/SchemaName.hs @@ -16,8 +16,7 @@ import Orville.PostgreSQL.Expr.Internal.Name.Identifier (Identifier, IdentifierExpression, identifier) import qualified Orville.PostgreSQL.Raw.RawSql as RawSql -{- | -Type to represent a SQL schema name. 'SchemaName' values constructed via the +{- | Type to represent a SQL schema name. 'SchemaName' values constructed via the 'schemaName' function will be properly escaped as part of the generated SQL. E.G. @@ -38,8 +37,7 @@ IdentifierExpression ) -{- | -Construct a 'SchemaName' from a 'String' with proper escaping as part of the generated SQL. +{- | Construct a 'SchemaName' from a 'String' with proper escaping as part of the generated SQL. @since 1.0.0.0 -} diff --git a/src/Orville/PostgreSQL/Expr/Internal/Name/SequenceName.hs b/src/Orville/PostgreSQL/Expr/Internal/Name/SequenceName.hs --- a/src/Orville/PostgreSQL/Expr/Internal/Name/SequenceName.hs +++ b/src/Orville/PostgreSQL/Expr/Internal/Name/SequenceName.hs @@ -16,8 +16,7 @@ import Orville.PostgreSQL.Expr.Internal.Name.Identifier (Identifier, IdentifierExpression, identifier) import qualified Orville.PostgreSQL.Raw.RawSql as RawSql -{- | -Type to represent a SQL sequence name. 'SequenceName' values constructed via +{- | Type to represent a SQL sequence name. 'SequenceName' values constructed via the 'sequenceName' function will be properly escaped as part of the generated SQL. E.G. @@ -38,8 +37,7 @@ IdentifierExpression ) -{- | -Construct a 'SequenceName' from a 'String' with proper escaping as part of the generated SQL. +{- | Construct a 'SequenceName' from a 'String' with proper escaping as part of the generated SQL. @since 1.0.0.0 -} diff --git a/src/Orville/PostgreSQL/Expr/Internal/Name/TableName.hs b/src/Orville/PostgreSQL/Expr/Internal/Name/TableName.hs --- a/src/Orville/PostgreSQL/Expr/Internal/Name/TableName.hs +++ b/src/Orville/PostgreSQL/Expr/Internal/Name/TableName.hs @@ -16,8 +16,7 @@ import Orville.PostgreSQL.Expr.Internal.Name.Identifier (Identifier, IdentifierExpression, identifier) import qualified Orville.PostgreSQL.Raw.RawSql as RawSql -{- | -Type to represent a SQL table name. 'TableName' values constructed via the +{- | Type to represent a SQL table name. 'TableName' values constructed via the 'tableName' function will be properly escaped as part of the generated SQL. E.G. @@ -38,8 +37,7 @@ IdentifierExpression ) -{- | -Construct a 'TableName' from a 'String' with proper escaping as part of the generated SQL. +{- | Construct a 'TableName' from a 'String' with proper escaping as part of the generated SQL. @since 1.0.0.0 -} diff --git a/src/Orville/PostgreSQL/Expr/Internal/Name/TriggerName.hs b/src/Orville/PostgreSQL/Expr/Internal/Name/TriggerName.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/Internal/Name/TriggerName.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{- | +Copyright : Flipstone Technology Partners 2024 +License : MIT +Stability : Stable + +@since 1.1.0.0 +-} +module Orville.PostgreSQL.Expr.Internal.Name.TriggerName + ( TriggerName + , triggerName + ) +where + +import Orville.PostgreSQL.Expr.Internal.Name.Identifier (Identifier, IdentifierExpression, identifier) +import qualified Orville.PostgreSQL.Raw.RawSql as RawSql + +{- | Type to represent a SQL trigger name. 'TriggerName' values constructed via the +'triggerName' function will be properly escaped as part of the generated SQL. +E.G. + +> "some_trigger_name" + +'TriggerName' provides a 'RawSql.SqlExpression' instance. See +'RawSql.unsafeSqlExpression' for how to construct a value with your own custom +SQL. + +@since 1.1.0.0 +-} +newtype TriggerName + = TriggerName Identifier + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + , -- | @since 1.1.0.0 + IdentifierExpression + ) + +{- | Construct a 'TriggerName' from a 'String' with proper escaping as part of the generated SQL. + +@since 1.1.0.0 +-} +triggerName :: String -> TriggerName +triggerName = + TriggerName . identifier diff --git a/src/Orville/PostgreSQL/Expr/Internal/Name/WindowName.hs b/src/Orville/PostgreSQL/Expr/Internal/Name/WindowName.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/Internal/Name/WindowName.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{- | +Copyright : Flipstone Technology Partners 2024 +License : MIT +Stability : Stable + +@since 1.1.0.0 +-} +module Orville.PostgreSQL.Expr.Internal.Name.WindowName + ( WindowName + , windowName + ) +where + +import Orville.PostgreSQL.Expr.Internal.Name.Identifier (Identifier, IdentifierExpression, identifier) +import qualified Orville.PostgreSQL.Raw.RawSql as RawSql + +{- | Type to represent a SQL window name. 'WindowName' values constructed +via the 'windowName' window will be properly escaped as part of the +generated SQL. E.G. + +> "some_window_name" + +'WindowName' provides a 'RawSql.SqlExpression' instance. See +'RawSql.unsafeSqlExpression' for how to construct a value with your own custom +SQL. + +@since 1.1.0.0 +-} +newtype WindowName + = WindowName Identifier + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + , -- | @since 1.1.0.0 + IdentifierExpression + ) + +{- | Construct a 'WindowName' from a 'String' with proper escaping as part of the generated SQL. + +@since 1.1.0.0 +-} +windowName :: String -> WindowName +windowName = + WindowName . identifier diff --git a/src/Orville/PostgreSQL/Expr/Join.hs b/src/Orville/PostgreSQL/Expr/Join.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/Join.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{- | +Copyright : Flipstone Technology Partners 2024-2025 +License : MIT +Stability : Stable + +@since 1.1.0.0 +-} +module Orville.PostgreSQL.Expr.Join + ( JoinType + , innerJoinType + , leftJoinType + , rightJoinType + , fullJoinType + , leftLateralJoinType + , innerLateralJoinType + , JoinConstraint + , joinOnConstraint + , joinedTable + , join + , joining + ) where + +import Orville.PostgreSQL.Expr.TableReferenceList (TableReference) +import Orville.PostgreSQL.Expr.WhereClause (BooleanExpr) +import qualified Orville.PostgreSQL.Raw.RawSql as RawSql + +{- | Representation of what kind of 'JOIN' to perform. + + From the documentation at https://www.postgresql.org/docs/15/sql-select.html there are 4 basic + types of join. + + - Inner join + Use 'innerJoinType' for constructing + - Left join + Sometimes called a left "outer" join. Use 'leftJoinType' for construction. + - Right join + Sometimes called a right "outer" join. use 'rightJoinType' for construction. + - Full join + Sometimes called a full "outer" join. Use 'fullJoinType' for construction. + +@since 1.1.0.0 +-} +newtype JoinType = JoinType RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | Constructs a 'JoinType' for an INNER JOIN. + +@since 1.1.0.0 +-} +innerJoinType :: JoinType +innerJoinType = JoinType $ RawSql.fromString "INNER JOIN" + +{- | Constructs a 'JoinType' for a LEFT JOIN. + + Note that the documentation at https://www.postgresql.org/docs/15/sql-select.html describes the + keyword OUTER as optional, and the sql generated from here omits it for brevity of query. + +@since 1.1.0.0 +-} +leftJoinType :: JoinType +leftJoinType = JoinType $ RawSql.fromString "LEFT JOIN" + +{- | Constructs a 'JoinType' for a RIGHT JOIN. + + Note that the documentation at https://www.postgresql.org/docs/15/sql-select.html describes the + keyword OUTER as optional, and the sql generated from here omits it for brevity of query. + +@since 1.1.0.0 +-} +rightJoinType :: JoinType +rightJoinType = JoinType $ RawSql.fromString "RIGHT JOIN" + +{- | Constructs a 'JoinType' for a FULL JOIN. + + Note that the documentation at https://www.postgresql.org/docs/15/sql-select.html describes the + keyword OUTER as optional, and the sql generated from here omits it for brevity of query. + +@since 1.1.0.0 +-} +fullJoinType :: JoinType +fullJoinType = JoinType $ RawSql.fromString "FULL JOIN" + +{- | Constructs a 'JoinType' for a LEFT JOIN LATERAL. + + Note that the documentation at https://www.postgresql.org/docs/15/sql-select.html describes the + keyword OUTER as optional, and the sql generated from here omits it for brevity of query. + +@since 1.1.0.0 +-} +leftLateralJoinType :: JoinType +leftLateralJoinType = JoinType $ RawSql.fromString "LEFT JOIN LATERAL" + +{- | Constructs a 'JoinType' for an INNER JOIN. + +@since 1.1.0.0 +-} +innerLateralJoinType :: JoinType +innerLateralJoinType = JoinType $ RawSql.fromString "JOIN LATERAL" + +{- | Representation of the "ON" part of a JOIN in sql. + +@since 1.1.0.0 +-} +newtype JoinConstraint = JoinConstraint RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | Constructs a 'JoinConstraint' from a given 'BooleanExpr' that specifies which rows in the JOIN are + considering to match. + +@since 1.1.0.0 +-} +joinOnConstraint :: BooleanExpr -> JoinConstraint +joinOnConstraint booleanExpr = + JoinConstraint $ + RawSql.fromString "ON " <> RawSql.toRawSql booleanExpr + +{- | Constructs a 'TableReference' by creating a join expression from two existing table references. + The result is an @n+m@ way join, where @n@ is the number of tables referenced in the first table + reference expression (which itself may be a join) and @m@ is the number of tables referenced by + the second table reference expression. + + See also: 'join', 'joining' + +@since 1.1.0.0 +-} +joinedTable :: + TableReference -> + JoinType -> + TableReference -> + JoinConstraint -> + TableReference +joinedTable tableRefA joinType tableRefB joinOn = + RawSql.unsafeFromRawSql $ + RawSql.toRawSql tableRefA + <> RawSql.space + <> RawSql.toRawSql joinType + <> RawSql.space + <> RawSql.toRawSql tableRefB + <> RawSql.space + <> RawSql.toRawSql joinOn + +{- | A flipped version of 'joinedTable' that allows joined tables to be constructed in a syntax more + similar to SQL. For example: + + @@ + fooTableRef + & join leftJoinType barTableRef someJoinCondition + & join leftJoinType bazTableRef someOtherJoinCondition + @@ + + See also: 'joining', 'joinedTable' + + @since 1.1.0.0 +-} +join :: + JoinType -> + TableReference -> + JoinConstraint -> + TableReference -> + TableReference +join joinType tableRefB joinOn tableRefA = + joinedTable tableRefA joinType tableRefB joinOn + +{- | A convenience function for constructing joins by tracking the tables to be joined in a list + instead of using the '(&)' operator. The tables will be joined in a left associative manner, + matching the associativity of the analogous SQL expression. + + @@ + joining fooTableRef + [ join leftJoinType barTableRef someJoinCondition + , join leftJoinType bazTableRef someOtherJoinCondition + ] + @@ + + See also: 'join', 'joinedTable' + + @since 1.1.0.0 +-} +joining :: TableReference -> [TableReference -> TableReference] -> TableReference +joining tableRef joinList = + foldr (flip (.)) id joinList tableRef diff --git a/src/Orville/PostgreSQL/Expr/LimitExpr.hs b/src/Orville/PostgreSQL/Expr/LimitExpr.hs --- a/src/Orville/PostgreSQL/Expr/LimitExpr.hs +++ b/src/Orville/PostgreSQL/Expr/LimitExpr.hs @@ -16,8 +16,7 @@ import qualified Orville.PostgreSQL.Raw.RawSql as RawSql import qualified Orville.PostgreSQL.Raw.SqlValue as SqlValue -{- | -Type to represent a SQL limit expression. E.G. +{- | Type to represent a SQL limit expression. E.G. > LIMIT 10 diff --git a/src/Orville/PostgreSQL/Expr/Name.hs b/src/Orville/PostgreSQL/Expr/Name.hs --- a/src/Orville/PostgreSQL/Expr/Name.hs +++ b/src/Orville/PostgreSQL/Expr/Name.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -Wno-missing-import-lists #-} {- | -Copyright : Flipstone Technology Partners 2023 +Copyright : Flipstone Technology Partners 2023-2024 License : MIT Stability : Stable @@ -12,9 +12,11 @@ ) where +import Orville.PostgreSQL.Expr.Internal.Name.Alias as Export import Orville.PostgreSQL.Expr.Internal.Name.ColumnName as Export import Orville.PostgreSQL.Expr.Internal.Name.ConstraintName as Export import Orville.PostgreSQL.Expr.Internal.Name.CursorName as Export +import Orville.PostgreSQL.Expr.Internal.Name.ExtensionName as Export import Orville.PostgreSQL.Expr.Internal.Name.FunctionName as Export import Orville.PostgreSQL.Expr.Internal.Name.Identifier as Export import Orville.PostgreSQL.Expr.Internal.Name.IndexName as Export @@ -23,3 +25,5 @@ import Orville.PostgreSQL.Expr.Internal.Name.SchemaName as Export import Orville.PostgreSQL.Expr.Internal.Name.SequenceName as Export import Orville.PostgreSQL.Expr.Internal.Name.TableName as Export +import Orville.PostgreSQL.Expr.Internal.Name.TriggerName as Export +import Orville.PostgreSQL.Expr.Internal.Name.WindowName as Export diff --git a/src/Orville/PostgreSQL/Expr/OffsetExpr.hs b/src/Orville/PostgreSQL/Expr/OffsetExpr.hs --- a/src/Orville/PostgreSQL/Expr/OffsetExpr.hs +++ b/src/Orville/PostgreSQL/Expr/OffsetExpr.hs @@ -16,8 +16,7 @@ import qualified Orville.PostgreSQL.Raw.RawSql as RawSql import qualified Orville.PostgreSQL.Raw.SqlValue as SqlValue -{- | -Type to represent a SQL offset expression. E.G. +{- | Type to represent a SQL offset expression. E.G. > OFFSET 10 diff --git a/src/Orville/PostgreSQL/Expr/OnConflict.hs b/src/Orville/PostgreSQL/Expr/OnConflict.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/OnConflict.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{- | +Copyright : Flipstone Technology Partners 2024 +License : MIT +Stability : Stable + +@since 1.1.0.0 +-} +module Orville.PostgreSQL.Expr.OnConflict + ( OnConflictExpr + , onConflict + , onConflictDoNothing + , onConflictDoUpdate + , ConflictTargetExpr + , conflictTargetForIndexColumn + , conflictTargetForIndexExpr + , conflictTargetForConstraint + , ConflictActionExpr + , ConflictSetItemExpr + , setColumnNameExcluded + ) +where + +import Data.List.NonEmpty (NonEmpty) + +import Orville.PostgreSQL.Expr.Index (IndexBodyExpr) +import Orville.PostgreSQL.Expr.Internal.Name.ConstraintName (ConstraintName) +import Orville.PostgreSQL.Expr.Name (ColumnName, QualifiedOrUnqualified) +import Orville.PostgreSQL.Expr.WhereClause (WhereClause) +import qualified Orville.PostgreSQL.Raw.RawSql as RawSql + +{- | Type to represent the SQL for the 'ON CONFLICT' clause. + +'OnConflict' provides a 'RawSql.SqlExpression' instance. See 'RawSql.unsafeSqlExpression' for how to +construct a value with your own custom SQL. + +@since 1.1.0.0 +-} +newtype OnConflictExpr + = OnConflictExpr RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | Create an 'OnConflict' that performs the specified action to be taken during a conflicting insert. + +@since 1.1.0.0 +-} +onConflict :: Maybe ConflictTargetExpr -> ConflictActionExpr -> OnConflictExpr +onConflict mbTarget action = + OnConflictExpr $ + RawSql.fromString "ON CONFLICT " + <> case mbTarget of + Nothing -> + RawSql.toRawSql action + Just target -> + RawSql.toRawSql target <> RawSql.space <> RawSql.toRawSql action + +{- | A wrapper around 'onConflict' for no specific target and an explicit no action to perform. + +@since 1.1.0.0 +-} +onConflictDoNothing :: OnConflictExpr +onConflictDoNothing = + onConflict Nothing doNothingActionExpr + +{- | A wrapper around 'onConflict' to perform an update, with optional target and where clause. That + will use the given 'ConflictSetItemExpr's as the update body. + +@since 1.1.0.0 +-} +onConflictDoUpdate :: Maybe ConflictTargetExpr -> NonEmpty ConflictSetItemExpr -> Maybe WhereClause -> OnConflictExpr +onConflictDoUpdate mbTarget setItems = + onConflict mbTarget . doUpdateSetActionExpr setItems + +{- | Type to represent the target portion of the SQL 'ON CONFLICT target action' + +@since 1.1.0.0 +-} +newtype ConflictTargetExpr + = ConflictTargetExpr RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | Build a 'ConflictTargetExpr' that would conflict on a single 'ColumnName'. PostgreSQL will use + the column to infer which index to check for conflicts. + +@since 1.1.0.0 +-} +conflictTargetForIndexColumn :: QualifiedOrUnqualified ColumnName -> Maybe WhereClause -> ConflictTargetExpr +conflictTargetForIndexColumn colName mbWhere = + let + parensCol = RawSql.parenthesized $ RawSql.toRawSql colName + in + ConflictTargetExpr $ + case mbWhere of + Nothing -> parensCol + Just whereClause -> parensCol <> RawSql.space <> RawSql.toRawSql whereClause + +{- | Build a 'ConflictTargetExpr' that would conflict on an 'IndexBodyExpr'. This can be used to check + for more than a single column. PostgreSQL will use the expression to infer which index to check for + conflicts. + + Note that this function assumes that the 'IndexBodyExpr' is parenthesized. +@since 1.1.0.0 +-} +conflictTargetForIndexExpr :: IndexBodyExpr -> Maybe WhereClause -> ConflictTargetExpr +conflictTargetForIndexExpr idxBody mbWhere = + let + rawIdxBody = RawSql.toRawSql idxBody + in + ConflictTargetExpr $ + case mbWhere of + Nothing -> rawIdxBody + Just whereClause -> rawIdxBody <> RawSql.space <> RawSql.toRawSql whereClause + +{- | Build a 'ConflictTargetExpr' for conflicting on the given 'ConstraintName'. For conflicing on an + index, see 'conflictTargetForIndexColumn' or 'conflictTargetForIndexExpr' instead. + +@since 1.1.0.0 +-} +conflictTargetForConstraint :: ConstraintName -> ConflictTargetExpr +conflictTargetForConstraint constraintName = + ConflictTargetExpr $ RawSql.fromString "ON CONSTRAINT " <> RawSql.toRawSql constraintName + +{- | Type to represent the action portion of the SQL 'ON CONFLICT target action' + +@since 1.1.0.0 +-} +newtype ConflictActionExpr + = ConflictActionExpr RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | A 'ConflictActionExpr' for the SQL 'DO NOTHING'. + +@since 1.1.0.0 +-} +doNothingActionExpr :: ConflictActionExpr +doNothingActionExpr = + ConflictActionExpr $ RawSql.fromString "DO NOTHING" + +{- | A 'ConflictActionExpr' for the SQL 'DO UPDATE SET', that will use the given 'ConflictSetItemExpr' + to determine which columns to update and the optional 'WhereClause' to peform filtering. + +@since 1.1.0.0 +-} +doUpdateSetActionExpr :: NonEmpty ConflictSetItemExpr -> Maybe WhereClause -> ConflictActionExpr +doUpdateSetActionExpr setItems mbWhere = + let + commaSeparatedItems = RawSql.intercalate RawSql.comma setItems + in + ConflictActionExpr $ + RawSql.fromString "DO UPDATE SET " + <> case mbWhere of + Nothing -> commaSeparatedItems + Just whereClause -> commaSeparatedItems <> RawSql.space <> RawSql.toRawSql whereClause + +{- | Type to represent the item to be set in an 'ON CONFLICT DO UPDATE'. E.G. + +> ON CONFLICT DO UPDATE SET item + +@since 1.1.0.0 +-} +newtype ConflictSetItemExpr + = ConflictSetItemExpr RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | Builds a 'ConflictSetItemExpr' that will set the given 'ColumnName' to the excluded value using +the special pseudo-table 'EXCLUDED'. + +@since 1.1.0.0 +-} +setColumnNameExcluded :: QualifiedOrUnqualified ColumnName -> ConflictSetItemExpr +setColumnNameExcluded colName = + let + rawName = RawSql.toRawSql colName + in + ConflictSetItemExpr $ + rawName + <> RawSql.fromString " = " + <> RawSql.fromString "EXCLUDED" + <> RawSql.dot + <> rawName diff --git a/src/Orville/PostgreSQL/Expr/OrReplace.hs b/src/Orville/PostgreSQL/Expr/OrReplace.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/OrReplace.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{- | +Copyright : Flipstone Technology Partners 2024 +License : MIT +Stability : Stable + +@since 1.1.0.0 +-} +module Orville.PostgreSQL.Expr.OrReplace + ( OrReplace + , orReplace + ) +where + +import qualified Orville.PostgreSQL.Raw.RawSql as RawSql + +{- | Type to represent a SQL "OR REPLACE" expression. E.G. + +> OR REPLACE + +'OrReplace' provides a 'RawSql.SqlExpression' instance. See +'RawSql.unsafeSqlExpression' for how to construct a value with your own custom +SQL. + +@since 1.1.0.0 +-} +newtype OrReplace + = OrReplace RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | A value of the SQL "OR REPLACE". + +@since 1.1.0.0 +-} +orReplace :: OrReplace +orReplace = + OrReplace $ RawSql.fromString "OR REPLACE" diff --git a/src/Orville/PostgreSQL/Expr/OrderBy.hs b/src/Orville/PostgreSQL/Expr/OrderBy.hs --- a/src/Orville/PostgreSQL/Expr/OrderBy.hs +++ b/src/Orville/PostgreSQL/Expr/OrderBy.hs @@ -1,7 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {- | -Copyright : Flipstone Technology Partners 2023 +Copyright : Flipstone Technology Partners 2023-2025 License : MIT Stability : Stable @@ -14,6 +14,7 @@ , appendOrderByExpr , orderByColumnName , orderByColumnsExpr + , orderByValueExpression , OrderByDirection , NullsOrder (NullsFirst, NullsLast) , ascendingOrder @@ -25,11 +26,12 @@ import qualified Data.List.NonEmpty as NEL -import Orville.PostgreSQL.Expr.Name (ColumnName) +import Orville.PostgreSQL.Expr.Name (ColumnName, QualifiedOrUnqualified) +import qualified Orville.PostgreSQL.Expr.ValueExpression as ValueExpression +import qualified Orville.PostgreSQL.Internal.Extra.NonEmpty as ExtraNonEmpty import qualified Orville.PostgreSQL.Raw.RawSql as RawSql -{- | -Type to represent a SQL order by clause. E.G. +{- | Type to represent a SQL order by clause. E.G. > ORDER BY foo, bar @@ -41,13 +43,19 @@ -} newtype OrderByClause = OrderByClause RawSql.RawSql - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) +{- | Builds a full 'OrderByClause' with the given ordering described in the 'OrderByExpr' + +@since 1.0.0.0 +-} orderByClause :: OrderByExpr -> OrderByClause orderByClause expr = OrderByClause (RawSql.fromString "ORDER BY " <> RawSql.toRawSql expr) -{- | -Type to represent a SQL order by expression (the part that follows the @ORDER +{- | Type to represent a SQL order by expression (the part that follows the @ORDER BY@ in SQL). E.G. > foo, bar @@ -64,9 +72,7 @@ RawSql.SqlExpression ) -{- | -@since 1.0.0.0 --} +-- | @since 1.0.0.0 instance Semigroup OrderByExpr where (<>) = appendOrderByExpr @@ -83,26 +89,26 @@ @since 1.0.0.0 -} -orderByColumnsExpr :: NEL.NonEmpty (ColumnName, OrderByDirection) -> OrderByExpr -orderByColumnsExpr = - OrderByExpr . RawSql.intercalate RawSql.commaSpace . fmap columnOrdering - where - columnOrdering :: (ColumnName, OrderByDirection) -> RawSql.RawSql - columnOrdering (columnName, orderByDirection) = - RawSql.toRawSql columnName <> RawSql.space <> RawSql.toRawSql orderByDirection +orderByColumnsExpr :: NEL.NonEmpty (QualifiedOrUnqualified ColumnName, OrderByDirection) -> OrderByExpr +orderByColumnsExpr = ExtraNonEmpty.foldMap1' (uncurry orderByColumnName) -{-- | - Orders a query by the given column name in the given order direction. +{- | Orders a query by the given column name in the given order direction. @since 1.0.0.0 -} -orderByColumnName :: ColumnName -> OrderByDirection -> OrderByExpr -orderByColumnName = - curry (orderByColumnsExpr . pure) +orderByColumnName :: QualifiedOrUnqualified ColumnName -> OrderByDirection -> OrderByExpr +orderByColumnName = orderByValueExpression . ValueExpression.columnReference -{- | -Type to represent a SQL order by direction expression. E.G. +{- | Create an 'OrderByExpr' for the given 'ValueExpression.ValueExpression' and 'OrderByDirection'. The caller must ensure that the 'ValueExpression.ValueExpression' is valid as an order by expression. +@since 1.1.0.0 +-} +orderByValueExpression :: ValueExpression.ValueExpression -> OrderByDirection -> OrderByExpr +orderByValueExpression value direction = + OrderByExpr $ RawSql.toRawSql value <> RawSql.space <> RawSql.toRawSql direction + +{- | Type to represent a SQL order by direction expression. E.G. + > ASC 'OrderByDirection' provides a 'RawSql.SqlExpression' instance. See @@ -112,10 +118,12 @@ @since 1.0.0.0 -} newtype OrderByDirection = OrderByDirection RawSql.RawSql - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) -{- | -Type to represent the ordering of Null, intended to be used with 'OrderByDirection'. +{- | Type to represent the ordering of Null, intended to be used with 'OrderByDirection'. @since 1.0.0.0 -} diff --git a/src/Orville/PostgreSQL/Expr/Query.hs b/src/Orville/PostgreSQL/Expr/Query.hs --- a/src/Orville/PostgreSQL/Expr/Query.hs +++ b/src/Orville/PostgreSQL/Expr/Query.hs @@ -1,7 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {- | -Copyright : Flipstone Technology Partners 2023 +Copyright : Flipstone Technology Partners 2023-2025 License : MIT Stability : Stable @@ -10,6 +10,13 @@ module Orville.PostgreSQL.Expr.Query ( QueryExpr , queryExpr + , existsSubquery + , queryValueExpression + , inSubquery + , notInSubquery + , anySubquery + , allSubquery + , subQueryTableReference , SelectList , selectColumns , DerivedColumn @@ -24,21 +31,24 @@ import Data.Maybe (catMaybes, fromMaybe) +import Orville.PostgreSQL.Expr.BinaryOperator (BinaryOperator) +import Orville.PostgreSQL.Expr.FetchClause (FetchClause) import Orville.PostgreSQL.Expr.GroupBy (GroupByClause) import Orville.PostgreSQL.Expr.LimitExpr (LimitExpr) -import Orville.PostgreSQL.Expr.Name (ColumnName) +import Orville.PostgreSQL.Expr.Name (AliasExpr, ColumnName, QualifiedOrUnqualified) import Orville.PostgreSQL.Expr.OffsetExpr (OffsetExpr) import Orville.PostgreSQL.Expr.OrderBy (OrderByClause) +import Orville.PostgreSQL.Expr.RowLocking (RowLockingClause) import Orville.PostgreSQL.Expr.Select (SelectClause) -import Orville.PostgreSQL.Expr.TableReferenceList (TableReferenceList) +import Orville.PostgreSQL.Expr.TableReferenceList (TableReference, TableReferenceList) import Orville.PostgreSQL.Expr.ValueExpression (ValueExpression, columnReference) -import Orville.PostgreSQL.Expr.WhereClause (WhereClause) +import Orville.PostgreSQL.Expr.WhereClause (BooleanExpr, InValuePredicate, WhereClause, inPredicate, notInPredicate) +import Orville.PostgreSQL.Expr.Window (WindowClause) import qualified Orville.PostgreSQL.Raw.RawSql as RawSql -- This is a rough model of "query specification" see https://jakewheat.github.io/sql-overview/sql-2016-foundation-grammar.html#_7_16_query_specification for more detail than you probably want -{- | -Type to represent a SQL query, E.G. +{- | Type to represent a SQL query, E.G. > SELECT id FROM some_table @@ -50,10 +60,12 @@ -} newtype QueryExpr = QueryExpr RawSql.RawSql - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) -{- | - Builds a 'QueryExpr' from the given 'SelectClause', 'SelectList' and +{- | Builds a 'QueryExpr' from the given 'SelectClause', 'SelectList' and 'TableExpr'. The resulting 'QueryExpr' is suitable for execution via the SQL execution functions in "Orville.PostgreSQL.Execution" and "Orville.PostgreSQL.Raw.RawSql". @@ -74,8 +86,91 @@ , fromMaybe (RawSql.fromString "") maybeFromClause ] -{- | -Type to represent the list of items to be selected in a @SELECT@ clause. +{- | The SQL @EXISTS@ subquery expression. This builds a 'BooleanExpr' that checks if the given + 'QueryExpr' returns at least one row. The resuling SQL will correctly be parenthesized. + +@since 1.1.0.0 +-} +existsSubquery :: QueryExpr -> BooleanExpr +existsSubquery (QueryExpr queryRawSql) = + RawSql.unsafeFromRawSql $ + RawSql.fromString "EXISTS " + <> RawSql.parenthesized queryRawSql + +{- | Treat a 'QueryExpr' as a 'ValueExpression' to make it suitable for use as subquery. + +@since 1.1.0.0 +-} +queryValueExpression :: QueryExpr -> ValueExpression +queryValueExpression = + RawSql.unsafeFromRawSql . RawSql.toRawSql + +-- Internal helper to treat a 'QueryExpr' as an 'InValuePredicate' for building @IN@ and @NOT IN@ +-- subquery expressions. +queryInValuePredicate :: QueryExpr -> InValuePredicate +queryInValuePredicate = + RawSql.unsafeFromRawSql . RawSql.parenthesized . RawSql.toRawSql + +{- | The SQL @IN@ subquery expression. It is up to the caller to ensure that the given 'QueryExpr' + returns exactly one column. + +@since 1.1.0.0 +-} +inSubquery :: ValueExpression -> QueryExpr -> BooleanExpr +inSubquery valExpr = + inPredicate valExpr . queryInValuePredicate + +{- | The SQL @NOT IN@ subquery expression. It is up to the caller to ensure that the given 'QueryExpr' + returns exactly one column. + +@since 1.1.0.0 +-} +notInSubquery :: ValueExpression -> QueryExpr -> BooleanExpr +notInSubquery valExpr = + notInPredicate valExpr . queryInValuePredicate + +{- | The SQL @ANY@ subquery expression. It is up to the caller to ensure that the given 'QueryExpr' + returns exactly one column and that the operator results in a boolean. + +@since 1.1.0.0 +-} +anySubquery :: BinaryOperator -> ValueExpression -> QueryExpr -> BooleanExpr +anySubquery = + operatorSubquery (RawSql.fromString " ANY ") + +{- | The SQL @ALL@ subquery expression. It is up to the caller to ensure that the given 'QueryExpr' + returns exactly one column and that the operator results in a boolean. + +@since 1.1.0.0 +-} +allSubquery :: BinaryOperator -> ValueExpression -> QueryExpr -> BooleanExpr +allSubquery = + operatorSubquery (RawSql.fromString " ALL ") + +-- Internal helper to build any/all subquery +operatorSubquery :: RawSql.RawSql -> BinaryOperator -> ValueExpression -> QueryExpr -> BooleanExpr +operatorSubquery querySpecificRawSql binOp valExpr (QueryExpr queryRawSql) = + RawSql.unsafeFromRawSql $ + RawSql.parenthesized valExpr + <> RawSql.space + <> RawSql.toRawSql binOp + <> querySpecificRawSql + <> RawSql.parenthesized queryRawSql + +{- | Make a 'QueryExpr' into a 'TableReference' using the specified alias. + This is the way to use a 'QueryExpr' as a subquery that can be joined + against and referenced as if it were a table. + +@since 1.1.0.0 +-} +subQueryTableReference :: QueryExpr -> AliasExpr -> TableReference +subQueryTableReference query alias = + RawSql.unsafeFromRawSql $ + RawSql.parenthesized (RawSql.toRawSql query) + <> RawSql.fromString " AS " + <> RawSql.toRawSql alias + +{- | Type to represent the list of items to be selected in a @SELECT@ clause. E.G. the > foo, bar, baz @@ -91,10 +186,17 @@ @since 1.0.0.0 -} newtype SelectList = SelectList RawSql.RawSql - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) -{- | - Constructs a 'SelectList' that will select all colums (i.e. the @*@ in +-- | @since 1.1.0.0 +instance Semigroup SelectList where + SelectList a <> SelectList b = + SelectList $ RawSql.appendWithCommaSpace a b + +{- | Constructs a 'SelectList' that will select all colums (i.e. the @*@ in @SELECT *@"). @since 1.0.0.0 @@ -103,19 +205,17 @@ selectStar = SelectList (RawSql.fromString "*") -{- | - Constructs a 'SelectList' that will select the specified column names. This +{- | Constructs a 'SelectList' that will select the specified column names. This is a special case of 'selectDerivedColumns' where all the items to be selected are simple column references. @since 1.0.0.0 -} -selectColumns :: [ColumnName] -> SelectList +selectColumns :: [QualifiedOrUnqualified ColumnName] -> SelectList selectColumns = - selectDerivedColumns . map (deriveColumn . columnReference) + selectDerivedColumns . fmap (deriveColumn . columnReference) -{- | -Type to represent an individual item in a list of selected items. E.G. +{- | Type to represent an individual item in a list of selected items. E.G. > now() as current_time @@ -126,10 +226,12 @@ @since 1.0.0.0 -} newtype DerivedColumn = DerivedColumn RawSql.RawSql - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) -{- | - Constructs a 'SelectList' that will select the specified items, which may be +{- | Constructs a 'SelectList' that will select the specified items, which may be column references or other expressions as allowed by 'DerivedColumn'. See also 'selectColumns' the simpler case of selecting a list of column names. @@ -139,8 +241,7 @@ selectDerivedColumns = SelectList . RawSql.intercalate RawSql.comma -{- | - Constructs a 'DerivedColumn' that will select the given value. No name will +{- | Constructs a 'DerivedColumn' that will select the given value. No name will be given to the value in the result set. See 'deriveColumnAs' to give the value a name in the result set. @@ -150,8 +251,7 @@ deriveColumn = DerivedColumn . RawSql.toRawSql -{- | - Constructs a 'DerivedColumn' that will select the given value and give it +{- | Constructs a 'DerivedColumn' that will select the given value and give it the specified column name in the result set. @since 1.0.0.0 @@ -164,8 +264,7 @@ <> RawSql.toRawSql asColumn ) -{- | -Type to represent a table expression (including its associated options) in a +{- | Type to represent a table expression (including its associated options) in a @SELECT@. This is the part that would appear *after* the word @FROM@. E.G. > foo @@ -182,15 +281,17 @@ -} newtype TableExpr = TableExpr RawSql.RawSql - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) -{- | - Constructs a 'TableExpr' with the given options. +{- | Constructs a 'TableExpr' with the given options. @since 1.0.0.0 -} tableExpr :: - -- | The list of tables to query from. + -- | The item(s) to query from. TableReferenceList -> -- | An optional @WHERE@ clause to limit the results returned. Maybe WhereClause -> @@ -202,6 +303,12 @@ Maybe LimitExpr -> -- | An optional @OFFSET@ to apply to the result set. Maybe OffsetExpr -> + -- | An optional locking clause to apply to the result set. + Maybe RowLockingClause -> + -- | An optional @WINDOW@ clause to apply to the result set. + Maybe WindowClause -> + -- | An optional @FETCH@ clause to apply to the result set. + Maybe FetchClause -> TableExpr tableExpr tableReferenceList @@ -209,14 +316,20 @@ maybeGroupByClause maybeOrderByClause maybeLimitExpr - maybeOffsetExpr = + maybeOffsetExpr + maybeRowLockingClause + maybeWindowClause + maybeFetchClause = TableExpr . RawSql.intercalate RawSql.space $ RawSql.toRawSql tableReferenceList : catMaybes [ RawSql.toRawSql <$> maybeWhereClause , RawSql.toRawSql <$> maybeGroupByClause + , RawSql.toRawSql <$> maybeWindowClause , RawSql.toRawSql <$> maybeOrderByClause , RawSql.toRawSql <$> maybeLimitExpr , RawSql.toRawSql <$> maybeOffsetExpr + , RawSql.toRawSql <$> maybeFetchClause + , RawSql.toRawSql <$> maybeRowLockingClause ] diff --git a/src/Orville/PostgreSQL/Expr/ReturningExpr.hs b/src/Orville/PostgreSQL/Expr/ReturningExpr.hs --- a/src/Orville/PostgreSQL/Expr/ReturningExpr.hs +++ b/src/Orville/PostgreSQL/Expr/ReturningExpr.hs @@ -16,8 +16,7 @@ import Orville.PostgreSQL.Expr.Query (SelectList) import qualified Orville.PostgreSQL.Raw.RawSql as RawSql -{- | -Type to represent a @RETURNING@ clause in a SQL @SELECT@ statement. E.G. +{- | Type to represent a @RETURNING@ clause in a SQL @SELECT@ statement. E.G. > RETURNING (id) @@ -29,10 +28,12 @@ -} newtype ReturningExpr = ReturningExpr RawSql.RawSql - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) -{- | - Constructs a 'ReturningExpr' that returns the items given in the +{- | Constructs a 'ReturningExpr' that returns the items given in the 'SelectList'. Essentialy this retults @RETURNING @. @since 1.0.0.0 diff --git a/src/Orville/PostgreSQL/Expr/RowLocking.hs b/src/Orville/PostgreSQL/Expr/RowLocking.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/RowLocking.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{- | +Copyright : Flipstone Technology Partners 2024 +License : MIT +Stability : Stable + +@since 1.1.0.0 +-} +module Orville.PostgreSQL.Expr.RowLocking + ( RowLockingClause + , rowLockingClause + , RowLockingStrengthExpr + , updateStrength + , noKeyUpdateStrength + , shareStrength + , keyShareStrength + , RowLockingOptionExpr + , noWaitRowLockingOption + , skipLockedRowLockingOption + ) +where + +import qualified Data.List.NonEmpty as NEL + +import Orville.PostgreSQL.Expr.Internal.Name.TableName (TableName) +import qualified Orville.PostgreSQL.Raw.RawSql as RawSql + +{- | Type to represent the row locking part of a SQL @SELECT@ query. E.G. + +> FOR UPDATE + +'RowLockingClause' provides a 'RawSql.SqlExpression' instance. See +'RawSql.unsafeSqlExpression' for how to construct a value with your own custom SQL. + +@since 1.1.0.0 +-} +newtype RowLockingClause + = RowLockingClause RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | Builds a 'RowLockingClause' with the given strength. If provided the optional 'NEL.NonEmpty + TableName' and 'RowLockingOptionExpr' will scope and set the lock option respectively. + +@since 1.1.0.0 +-} +rowLockingClause :: + RowLockingStrengthExpr -> + Maybe (NEL.NonEmpty TableName) -> + Maybe RowLockingOptionExpr -> + RowLockingClause +rowLockingClause strength mbTables mbOpt = + RowLockingClause $ + RawSql.fromString "FOR " + <> RawSql.toRawSql strength + <> maybe + mempty + ( \tables -> + RawSql.fromString " OF " + <> RawSql.intercalate + RawSql.commaSpace + (fmap RawSql.toRawSql tables) + ) + mbTables + <> maybe mempty (\opt -> RawSql.space <> RawSql.toRawSql opt) mbOpt + +{- | Type to represent the lock strength part of a row locking sub expression in a SQL @SELECT@ +query. E.G. + +> NO KEY UPDATE + +'RowLockingStrengthExpr' provides a 'RawSql.SqlExpression' instance. See +'RawSql.unsafeSqlExpression' for how to construct a value with your own custom SQL. + +@since 1.1.0.0 +-} +newtype RowLockingStrengthExpr + = RowLockingStrengthExpr RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | The @UPDATE@ lock strength + +@since 1.1.0.0 +-} +updateStrength :: RowLockingStrengthExpr +updateStrength = + RowLockingStrengthExpr $ RawSql.fromString "UPDATE" + +{- | The @NO KEY UPDATE@ lock strength + +@since 1.1.0.0 +-} +noKeyUpdateStrength :: RowLockingStrengthExpr +noKeyUpdateStrength = + RowLockingStrengthExpr $ RawSql.fromString "NO KEY UPDATE" + +{- | The @SHARE@ lock strength + +@since 1.1.0.0 +-} +shareStrength :: RowLockingStrengthExpr +shareStrength = + RowLockingStrengthExpr $ RawSql.fromString "SHARE" + +{- | The @KEY SHARE@ lock strength + +@since 1.1.0.0 +-} +keyShareStrength :: RowLockingStrengthExpr +keyShareStrength = + RowLockingStrengthExpr $ RawSql.fromString "KEY SHARE" + +{- | Type to represent the lock option part of a row locking sub expression in a SQL @SELECT@ +query. E.G. + +> SKIP LOCKED + +'RowLockingOptionExpr' provides a 'RawSql.SqlExpression' instance. See +'RawSql.unsafeSqlExpression' for how to construct a value with your own custom SQL. + +@since 1.1.0.0 +-} +newtype RowLockingOptionExpr + = RowLockingOptionExpr RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | The @NO WAIT@ lock option + +@since 1.1.0.0 +-} +noWaitRowLockingOption :: RowLockingOptionExpr +noWaitRowLockingOption = + RowLockingOptionExpr $ RawSql.fromString "NO WAIT" + +{- | The @SKIP LOCKED@ lock option + +@since 1.1.0.0 +-} +skipLockedRowLockingOption :: RowLockingOptionExpr +skipLockedRowLockingOption = + RowLockingOptionExpr $ RawSql.fromString "SKIP LOCKED" diff --git a/src/Orville/PostgreSQL/Expr/Select.hs b/src/Orville/PostgreSQL/Expr/Select.hs --- a/src/Orville/PostgreSQL/Expr/Select.hs +++ b/src/Orville/PostgreSQL/Expr/Select.hs @@ -13,13 +13,16 @@ , SelectExpr , selectExpr , Distinct (Distinct) + , DistinctOnExpr + , selectDistinctOnExpr ) where +import qualified Data.List.NonEmpty as NEL + import qualified Orville.PostgreSQL.Raw.RawSql as RawSql -{- | -Type to represent the @SELECT@ part of a SQL query. E.G. +{- | Type to represent the @SELECT@ part of a SQL query. E.G. > SELECT @@ -34,10 +37,12 @@ -} newtype SelectClause = SelectClause RawSql.RawSql - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) -{- | - Constructs a 'SelectClause' using the given 'SelectExpr', which may indicate +{- | Constructs a 'SelectClause' using the given 'SelectExpr', which may indicate that this is a @DISTINCT@ select. @since 1.0.0.0 @@ -45,8 +50,7 @@ selectClause :: SelectExpr -> SelectClause selectClause expr = SelectClause (RawSql.fromString "SELECT " <> RawSql.toRawSql expr) -{- | -Type to represent any expression modifying the @SELECT@ part of a SQL. E.G. +{- | Type to represent any expression modifying the @SELECT@ part of a SQL. E.G. > DISTINCT @@ -56,18 +60,19 @@ @since 1.0.0.0 -} newtype SelectExpr = SelectExpr RawSql.RawSql - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) -{- | - A simple value type used to indicate that a @SELECT@ should be distinct when +{- | A simple value type used to indicate that a @SELECT@ should be distinct when constructing a 'SelectExpr'. @since 1.0.0.0 -} data Distinct = Distinct -{- | - Constructs a 'SelectExpr' that may or may not make the @SELECT@ distinct, +{- | Constructs a 'SelectExpr' that may or may not make the @SELECT@ distinct, depending on whether 'Just Distinct' is passed or not. @since 1.0.0.0 @@ -78,3 +83,33 @@ case mbDistinct of Just Distinct -> "DISTINCT " Nothing -> "" + +{- | Type to represent a expression to be used as part of a @DISTINCT@ modifer of a @SELECT@. E.G. the +foo in + +> DISTINCT ON (foo) + +'SelectExpr' provides a 'RawSql.SqlExpression' instance. See +'RawSql.unsafeSqlExpression' for how to construct a value with your own custom SQL. + +@since 1.1.0.0 +-} +newtype DistinctOnExpr = DistinctOnExpr RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | Constructs a 'SelectExpr' that may or may not make the @SELECT@ distinct on the given expression. + +Note that PostgreSQL states the distinct expressions must match the leftmost order by expressions if +they are both used, but this function does not enforce that. + +@since 1.1.0.0 +-} +selectDistinctOnExpr :: Maybe (NEL.NonEmpty DistinctOnExpr) -> SelectExpr +selectDistinctOnExpr mbDistinctOns = + SelectExpr $ + case mbDistinctOns of + Just ons -> RawSql.fromString "DISTINCT ON " <> RawSql.parenthesized (RawSql.intercalate RawSql.commaSpace ons) + Nothing -> mempty diff --git a/src/Orville/PostgreSQL/Expr/SequenceDefinition.hs b/src/Orville/PostgreSQL/Expr/SequenceDefinition.hs --- a/src/Orville/PostgreSQL/Expr/SequenceDefinition.hs +++ b/src/Orville/PostgreSQL/Expr/SequenceDefinition.hs @@ -46,7 +46,7 @@ import Data.Maybe (catMaybes) import Orville.PostgreSQL.Expr.IfExists (IfExists) -import Orville.PostgreSQL.Expr.Name (FunctionName, Qualified, SequenceName, functionName) +import Orville.PostgreSQL.Expr.Name (FunctionName, QualifiedOrUnqualified, SequenceName, functionName) import Orville.PostgreSQL.Expr.ValueExpression (ValueExpression, functionCall, valueExpression) import qualified Orville.PostgreSQL.Raw.RawSql as RawSql import qualified Orville.PostgreSQL.Raw.SqlValue as SqlValue @@ -64,8 +64,7 @@ @@ -} -{- | -Type to represent a @CREATE SEQUENCE@ statement. E.G. +{- | Type to represent a @CREATE SEQUENCE@ statement. E.G. > CREATE SEQUENCE foo INCREMENT 2 @@ -77,16 +76,18 @@ -} newtype CreateSequenceExpr = CreateSequenceExpr RawSql.RawSql - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) -{- | - Constructs a 'CreateSequenceExpr' with the given sequence options. +{- | Constructs a 'CreateSequenceExpr' with the given sequence options. @since 1.0.0.0 -} createSequenceExpr :: -- | The name to be used for the sequence. - Qualified SequenceName -> + QualifiedOrUnqualified SequenceName -> -- | An optional @INCREMENT@ expression. Maybe IncrementByExpr -> -- | An optional @MINVALUE@ expression. @@ -133,8 +134,7 @@ @@ -} -{- | -Type to represent a @CREATE SEQUENCE@ statement. E.G. +{- | Type to represent a @CREATE SEQUENCE@ statement. E.G. > ALTER SEQUENCE foo START WITH 0 @@ -146,16 +146,18 @@ -} newtype AlterSequenceExpr = AlterSequenceExpr RawSql.RawSql - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) -{- | - Constructs an 'AlterSequenceExpr' with the given sequence options. +{- | Constructs an 'AlterSequenceExpr' with the given sequence options. @since 1.0.0.0 -} alterSequenceExpr :: -- | The name of the sequence to alter - Qualified SequenceName -> + QualifiedOrUnqualified SequenceName -> -- | An optional @INCREMENT@ expression Maybe IncrementByExpr -> -- | An optional @MINVALUE@ expression @@ -183,8 +185,7 @@ , fmap RawSql.toRawSql mbCycle ] -{- | -Type to represent an @INCREMENT BY@ expression for sequences. E.G. +{- | Type to represent an @INCREMENT BY@ expression for sequences. E.G. > INCREMENT BY 0 @@ -196,10 +197,12 @@ -} newtype IncrementByExpr = IncrementByExpr RawSql.RawSql - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) -{- | - Constructs an 'IncrementByExpr' that will make the sequence increment by +{- | Constructs an 'IncrementByExpr' that will make the sequence increment by the given value. @since 1.0.0.0 @@ -210,8 +213,7 @@ RawSql.fromString "INCREMENT BY " <> RawSql.int64DecLiteral n -{- | -Type to represent a @MINVALUE@ expression for sequences. E.G. +{- | Type to represent a @MINVALUE@ expression for sequences. E.G. > MINVALUE 0 @@ -223,10 +225,12 @@ -} newtype MinValueExpr = MinValueExpr RawSql.RawSql - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) -{- | - Constructs a 'MinValueExpr' which gives the sequence the specified minimum +{- | Constructs a 'MinValueExpr' which gives the sequence the specified minimum value. @since 1.0.0.0 @@ -237,8 +241,7 @@ RawSql.fromString "MINVALUE " <> RawSql.int64DecLiteral n -{- | - Constructs a 'MinValueExpr' which gives the sequence no minimum value (i.e. +{- | Constructs a 'MinValueExpr' which gives the sequence no minimum value (i.e. @NO MINVALUE@). @since 1.0.0.0 @@ -247,8 +250,7 @@ noMinValue = MinValueExpr . RawSql.fromString $ "NO MINVALUE" -{- | -Type to represent a @MAXVALUE@ expression for sequences. E.G. +{- | Type to represent a @MAXVALUE@ expression for sequences. E.G. > MAXVALUE 1000000 @@ -260,10 +262,12 @@ -} newtype MaxValueExpr = MaxValueExpr RawSql.RawSql - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) -{- | - Constructs a 'MaxValueExpr' which gives the sequence the specified maximum +{- | Constructs a 'MaxValueExpr' which gives the sequence the specified maximum value. @since 1.0.0.0 @@ -274,8 +278,7 @@ RawSql.fromString "MAXVALUE " <> RawSql.int64DecLiteral n -{- | - Constructs a 'MaxValueExpr' which gives the sequence no maximum value (i.e. +{- | Constructs a 'MaxValueExpr' which gives the sequence no maximum value (i.e. @NO MAXVALUE@). @since 1.0.0.0 @@ -284,8 +287,7 @@ noMaxValue = MaxValueExpr . RawSql.fromString $ "NO MAXVALUE" -{- | -Type to represent a @START WITH@ expression for sequences. E.G. +{- | Type to represent a @START WITH@ expression for sequences. E.G. > START WITH 1 @@ -297,10 +299,12 @@ -} newtype StartWithExpr = StartWithExpr RawSql.RawSql - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) -{- | - Constructs a 'StartWithExpr' which gives the sequence the specified start +{- | Constructs a 'StartWithExpr' which gives the sequence the specified start value. @since 1.0.0.0 @@ -311,8 +315,7 @@ RawSql.fromString "START WITH " <> RawSql.int64DecLiteral n -{- | -Type to represent a @CACHE@ expression for sequences. E.G. +{- | Type to represent a @CACHE@ expression for sequences. E.G. > CACHE 16 @@ -324,10 +327,12 @@ -} newtype CacheExpr = CacheExpr RawSql.RawSql - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) -{- | - Constructs a 'CacheExpr' that will make the sequence pre-allocate the +{- | Constructs a 'CacheExpr' that will make the sequence pre-allocate the specified number of sequence values. @since 1.0.0.0 @@ -338,8 +343,7 @@ RawSql.fromString "CACHE " <> RawSql.int64DecLiteral n -{- | -Type to represent a @CYCLE@ expression for sequences. E.G. +{- | Type to represent a @CYCLE@ expression for sequences. E.G. > CYCLE @@ -355,26 +359,26 @@ -} newtype CycleExpr = CycleExpr RawSql.RawSql - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) -{- | - Constructs a 'CycleExpr' that indicates that the sequence should cycle. +{- | Constructs a 'CycleExpr' that indicates that the sequence should cycle. @since 1.0.0.0 -} cycle :: CycleExpr cycle = CycleExpr $ RawSql.fromString "CYCLE" -{- | - Constructs a 'CycleExpr' that indicates that the sequence should not cycle. +{- | Constructs a 'CycleExpr' that indicates that the sequence should not cycle. @since 1.0.0.0 -} noCycle :: CycleExpr noCycle = CycleExpr $ RawSql.fromString "NO CYCLE" -{- | - Constructs a 'CycleExpr' that will cause the sequence to cycle if the flag +{- | Constructs a 'CycleExpr' that will cause the sequence to cycle if the flag passed is @True@. @since 1.0.0.0 @@ -385,8 +389,7 @@ then cycle else noCycle -{- | -Type to represent a @DROP SEQUENCE@ statement. E.G. +{- | Type to represent a @DROP SEQUENCE@ statement. E.G. > DROP SEQUENCE foo @@ -398,16 +401,18 @@ -} newtype DropSequenceExpr = DropSequenceExpr RawSql.RawSql - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) -{- | - Constructs a 'DropSequenceExpr' that will drop sequence with the given name. +{- | Constructs a 'DropSequenceExpr' that will drop sequence with the given name. You may specify an 'IfExists' argument if you want to include an @IF EXISTS@ condition in the statement. @since 1.0.0.0 -} -dropSequenceExpr :: Maybe IfExists -> Qualified SequenceName -> DropSequenceExpr +dropSequenceExpr :: Maybe IfExists -> QualifiedOrUnqualified SequenceName -> DropSequenceExpr dropSequenceExpr maybeIfExists sequenceName = DropSequenceExpr $ RawSql.intercalate @@ -419,8 +424,7 @@ ] ) -{- | - Constructs a 'ValueExpression' that will use the @nextval@ PostgreSQL +{- | Constructs a 'ValueExpression' that will use the @nextval@ PostgreSQL function to get the next value from the given sequence. If you're trying to construct your own @SELECT@ to get the value of the sequence, you can use the constructed 'ValueExpression' with 'Orville.PostgreSQL.Expr.deriveColumnAs' @@ -428,14 +432,13 @@ @since 1.0.0.0 -} -nextVal :: Qualified SequenceName -> ValueExpression +nextVal :: QualifiedOrUnqualified SequenceName -> ValueExpression nextVal sequenceName = functionCall nextValFunction [valueExpression . SqlValue.fromRawBytes . RawSql.toExampleBytes $ sequenceName] -{- | - The @nextval@ PostgreSQL function. +{- | The @nextval@ PostgreSQL function. @since 1.0.0.0 -} @@ -443,8 +446,7 @@ nextValFunction = functionName "nextval" -{- | - Constructs a 'ValueExpression' that will use the @currval@ PostgreSQL +{- | Constructs a 'ValueExpression' that will use the @currval@ PostgreSQL function to get the current value from the given sequence. If you're trying to construct your own @SELECT@ to get the value of the sequence, you can use the constructed 'ValueExpression' with 'Orville.PostgreSQL.Expr.deriveColumnAs' @@ -452,14 +454,13 @@ @since 1.0.0.0 -} -currVal :: Qualified SequenceName -> ValueExpression +currVal :: QualifiedOrUnqualified SequenceName -> ValueExpression currVal sequenceName = functionCall currValFunction [valueExpression . SqlValue.fromRawBytes . RawSql.toExampleBytes $ sequenceName] -{- | - The @currval@ PostgreSQL function. +{- | The @currval@ PostgreSQL function. @since 1.0.0.0 -} @@ -467,8 +468,7 @@ currValFunction = functionName "currval" -{- | - Constructs a 'ValueExpression' that will use the @setval@ PostgreSQL function +{- | Constructs a 'ValueExpression' that will use the @setval@ PostgreSQL function to set the value from the given sequence. If you're trying to construct your own @SELECT@ to set the value of the sequence, you can use the constructed 'ValueExpression' with 'Orville.PostgreSQL.Expr.deriveColumnAs' to build the @@ -476,7 +476,7 @@ @since 1.0.0.0 -} -setVal :: Qualified SequenceName -> Int64 -> ValueExpression +setVal :: QualifiedOrUnqualified SequenceName -> Int64 -> ValueExpression setVal sequenceName newValue = functionCall setValFunction @@ -484,8 +484,7 @@ , valueExpression . SqlValue.fromInt64 $ newValue ] -{- | - The @setval@ PostgreSQL function. +{- | The @setval@ PostgreSQL function. @since 1.0.0.0 -} diff --git a/src/Orville/PostgreSQL/Expr/TableConstraint.hs b/src/Orville/PostgreSQL/Expr/TableConstraint.hs --- a/src/Orville/PostgreSQL/Expr/TableConstraint.hs +++ b/src/Orville/PostgreSQL/Expr/TableConstraint.hs @@ -25,11 +25,10 @@ import Data.List.NonEmpty (NonEmpty) -import Orville.PostgreSQL.Expr.Name (ColumnName, Qualified, TableName) +import Orville.PostgreSQL.Expr.Name (ColumnName, QualifiedOrUnqualified, TableName) import qualified Orville.PostgreSQL.Raw.RawSql as RawSql -{- | -Type to represent a table constraint that would be part of a @CREATE TABLE@ or +{- | Type to represent a table constraint that would be part of a @CREATE TABLE@ or @ALTER TABLE@ statement. For instance, the @UNIQUE@ constraint in > CREATE TABLE FOO @@ -46,10 +45,12 @@ -} newtype TableConstraint = TableConstraint RawSql.RawSql - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) -{- | - Constructs a 'TableConstraint' will create a @UNIQUE@ constraint on the +{- | Constructs a 'TableConstraint' will create a @UNIQUE@ constraint on the given columns. @since 1.0.0.0 @@ -62,8 +63,7 @@ <> RawSql.intercalate RawSql.comma columnNames <> RawSql.rightParen -{- | -Type to represent a foreign key action on a @FOREIGN KEY@ constraint. E.G. +{- | Type to represent a foreign key action on a @FOREIGN KEY@ constraint. E.G. the @CASCADE@ in > FOREIGN KEY (foo_id) REFERENCES foo (id) ON DELETE CASCADE @@ -76,42 +76,40 @@ -} newtype ForeignKeyActionExpr = ForeignKeyActionExpr RawSql.RawSql - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) -{- | - The foreign key action @RESTRICT@. +{- | The foreign key action @RESTRICT@. @since 1.0.0.0 -} restrictExpr :: ForeignKeyActionExpr restrictExpr = ForeignKeyActionExpr $ RawSql.fromString "RESTRICT" -{- | - The foreign key action @CASCADE@. +{- | The foreign key action @CASCADE@. @since 1.0.0.0 -} cascadeExpr :: ForeignKeyActionExpr cascadeExpr = ForeignKeyActionExpr $ RawSql.fromString "CASCADE" -{- | - The foreign key action @SET NULL@. +{- | The foreign key action @SET NULL@. @since 1.0.0.0 -} setNullExpr :: ForeignKeyActionExpr setNullExpr = ForeignKeyActionExpr $ RawSql.fromString "SET NULL" -{- | - The foreign key action @SET DEFAULT@. +{- | The foreign key action @SET DEFAULT@. @since 1.0.0.0 -} setDefaultExpr :: ForeignKeyActionExpr setDefaultExpr = ForeignKeyActionExpr $ RawSql.fromString "SET DEFAULT" -{- | -Type to represent a foreign key update action on a @FOREIGN KEY@ constraint. E.G. +{- | Type to represent a foreign key update action on a @FOREIGN KEY@ constraint. E.G. the @ON UPDATE RESTRICT@ in > FOREIGN KEY (foo_id) REFERENCES foo (id) ON UPDATE RESTRICT @@ -124,10 +122,12 @@ -} newtype ForeignKeyUpdateActionExpr = ForeignKeyUpdateActionExpr RawSql.RawSql - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) -{- | - Constructs a 'ForeignKeyActionExpr' that uses the given 'ForeignKeyActionExpr' +{- | Constructs a 'ForeignKeyActionExpr' that uses the given 'ForeignKeyActionExpr' in an @ON UPDATE@ clause for a foreign key. @since 1.0.0.0 @@ -139,8 +139,7 @@ <> RawSql.space <> RawSql.toRawSql action -{- | -Type to represent a foreign key update action on a @FOREIGN KEY@ constraint. E.G. +{- | Type to represent a foreign key update action on a @FOREIGN KEY@ constraint. E.G. the @ON DELETE RESTRICT@ in > FOREIGN KEY (foo_id) REFERENCES foo (id) ON DELETE RESTRICT @@ -153,10 +152,12 @@ -} newtype ForeignKeyDeleteActionExpr = ForeignKeyDeleteActionExpr RawSql.RawSql - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) -{- | - Constructs a 'ForeignKeyActionExpr' that uses the given 'ForeignKeyActionExpr' +{- | Constructs a 'ForeignKeyActionExpr' that uses the given 'ForeignKeyActionExpr' in an @ON UPDATE@ clause for a foreign key. @since 1.0.0.0 @@ -168,8 +169,7 @@ <> RawSql.space <> RawSql.toRawSql action -{- | - Constructs a 'TableConstraint' that represent a @FOREIGN KEY@ constraint +{- | Constructs a 'TableConstraint' that represent a @FOREIGN KEY@ constraint @since 1.0.0.0 -} @@ -177,7 +177,7 @@ -- | The names of the columns in the source table that form the foreign key. NonEmpty ColumnName -> -- | The name of the table that the foreign key references. - Qualified TableName -> + QualifiedOrUnqualified TableName -> -- | The names of the columns in the foreign table that the foreign key references. NonEmpty ColumnName -> -- | An optional @ON UPDATE@ foreign key action to perform. diff --git a/src/Orville/PostgreSQL/Expr/TableDefinition.hs b/src/Orville/PostgreSQL/Expr/TableDefinition.hs --- a/src/Orville/PostgreSQL/Expr/TableDefinition.hs +++ b/src/Orville/PostgreSQL/Expr/TableDefinition.hs @@ -1,7 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {- | -Copyright : Flipstone Technology Partners 2023 +Copyright : Flipstone Technology Partners 2023-2025 License : MIT Stability : Stable @@ -14,6 +14,7 @@ , primaryKeyExpr , AlterTableExpr , alterTableExpr + , renameTableExpr , AlterTableAction , addColumn , dropColumn @@ -22,6 +23,8 @@ , alterColumnType , alterColumnSetDefault , alterColumnDropDefault + , alterColumnAddIdentity + , alterColumnDropIdentity , UsingClause , usingCast , alterColumnNullability @@ -30,21 +33,22 @@ , dropNotNull , DropTableExpr , dropTableExpr + , TruncateTableExpr + , truncateTablesExpr ) where import Data.List.NonEmpty (NonEmpty) import Data.Maybe (catMaybes, maybeToList) -import Orville.PostgreSQL.Expr.ColumnDefinition (ColumnDefinition) +import Orville.PostgreSQL.Expr.ColumnDefinition (ColumnDefinition, ColumnIdentityGeneration) import Orville.PostgreSQL.Expr.DataType (DataType) import Orville.PostgreSQL.Expr.IfExists (IfExists) -import Orville.PostgreSQL.Expr.Name (ColumnName, ConstraintName, Qualified, TableName) +import Orville.PostgreSQL.Expr.Name (ColumnName, ConstraintName, QualifiedOrUnqualified, TableName) import Orville.PostgreSQL.Expr.TableConstraint (TableConstraint) import qualified Orville.PostgreSQL.Raw.RawSql as RawSql -{- | -Type to represent a @CREATE TABLE@ statement. E.G. +{- | Type to represent a @CREATE TABLE@ statement. E.G. > CREATE TABLE foo (id integer) @@ -56,16 +60,18 @@ -} newtype CreateTableExpr = CreateTableExpr RawSql.RawSql - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) -{- | - Constructs a 'CreateTableExpr' with the given options. +{- | Constructs a 'CreateTableExpr' with the given options. @since 1.0.0.0 -} createTableExpr :: -- | The name to be used for the table. - Qualified TableName -> + QualifiedOrUnqualified TableName -> -- | The columns to include in the table. [ColumnDefinition] -> -- | A primary key expression for the table. @@ -76,10 +82,10 @@ createTableExpr tableName columnDefs mbPrimaryKey constraints = let columnDefsSql = - map RawSql.toRawSql columnDefs + fmap RawSql.toRawSql columnDefs constraintsSql = - map RawSql.toRawSql constraints + fmap RawSql.toRawSql constraints tableElementsSql = case mbPrimaryKey of @@ -98,8 +104,7 @@ , RawSql.rightParen ] -{- | -Type to represent the primary key of a table. E.G. +{- | Type to represent the primary key of a table. E.G. > PRIMARY KEY (id) @@ -111,10 +116,12 @@ -} newtype PrimaryKeyExpr = PrimaryKeyExpr RawSql.RawSql - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) -{- | - Constructs a 'PrimaryKeyExpr' with the given columns. +{- | Constructs a 'PrimaryKeyExpr' with the given columns. @since 1.0.0.0 -} @@ -128,8 +135,7 @@ , RawSql.rightParen ] -{- | -Type to represent an @ALTER TABLE@ statement. E.G. +{- | Type to represent an @ALTER TABLE@ statement. E.G. > ALTER TABLE foo ADD COLUMN bar integer @@ -141,14 +147,16 @@ -} newtype AlterTableExpr = AlterTableExpr RawSql.RawSql - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) -{- | - Constructs an 'AlterTableExpr' with the given alter table actions. +{- | Constructs an 'AlterTableExpr' with the given alter table actions. @since 1.0.0.0 -} -alterTableExpr :: Qualified TableName -> NonEmpty AlterTableAction -> AlterTableExpr +alterTableExpr :: QualifiedOrUnqualified TableName -> NonEmpty AlterTableAction -> AlterTableExpr alterTableExpr tableName actions = AlterTableExpr $ RawSql.fromString "ALTER TABLE " @@ -156,9 +164,16 @@ <> RawSql.space <> RawSql.intercalate RawSql.commaSpace actions -{- | -Type to represent an action as part of an @ALTER TABLE@ statement. E.G. +{- | Given an existing table name and the desired name, construct an 'AlterTableExpr' that will rename to desired. + @since 1.1.0.0 +-} +renameTableExpr :: QualifiedOrUnqualified TableName -> QualifiedOrUnqualified TableName -> AlterTableExpr +renameTableExpr existingTableName newTableName = + alterTableExpr existingTableName . pure . AlterTableAction $ RawSql.fromString "RENAME TO " <> RawSql.toRawSql newTableName + +{- | Type to represent an action as part of an @ALTER TABLE@ statement. E.G. + > ADD COLUMN bar integer 'AlterTableAction' provides a 'RawSql.SqlExpression' instance. See @@ -169,10 +184,12 @@ -} newtype AlterTableAction = AlterTableAction RawSql.RawSql - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) -{- | - Constructs an 'AlterTableAction' that will add the specified column to the +{- | Constructs an 'AlterTableAction' that will add the specified column to the table. @since 1.0.0.0 @@ -182,8 +199,7 @@ AlterTableAction $ RawSql.fromString "ADD COLUMN " <> RawSql.toRawSql columnDef -{- | - Constructs an 'AlterTableAction' that will drop the specified column from the +{- | Constructs an 'AlterTableAction' that will drop the specified column from the table. @since 1.0.0.0 @@ -193,8 +209,7 @@ AlterTableAction $ RawSql.fromString "DROP COLUMN " <> RawSql.toRawSql columnName -{- | - Constructs an 'AlterTableAction' that will add the specified constraint to the +{- | Constructs an 'AlterTableAction' that will add the specified constraint to the table. @since 1.0.0.0 @@ -204,8 +219,7 @@ AlterTableAction $ RawSql.fromString "ADD " <> RawSql.toRawSql constraint -{- | - Constructs an 'AlterTableAction' that will drop the specified constraint from the +{- | Constructs an 'AlterTableAction' that will drop the specified constraint from the table. @since 1.0.0.0 @@ -215,8 +229,7 @@ AlterTableAction $ RawSql.fromString "DROP CONSTRAINT " <> RawSql.toRawSql constraintName -{- | - Constructs an 'AlterTableAction' that will alter the type of the specified +{- | Constructs an 'AlterTableAction' that will alter the type of the specified column. @since 1.0.0.0 @@ -241,8 +254,7 @@ : maybeToList (fmap RawSql.toRawSql maybeUsingClause) ) -{- | -Type to represent a @USING@ clause as part of an @ALTER COLUMN@ when changing +{- | Type to represent a @USING@ clause as part of an @ALTER COLUMN@ when changing the type of a column. E.G. > USING id :: integer @@ -255,10 +267,12 @@ -} newtype UsingClause = UsingClause RawSql.RawSql - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) -{- | - Constructs a 'UsingClause' that will cast the column to the specified type. +{- | Constructs a 'UsingClause' that will cast the column to the specified type. @since 1.0.0.0 -} @@ -270,8 +284,7 @@ <> RawSql.doubleColon <> RawSql.toRawSql dataType -{- | - Constructs an 'AlterTableAction' that will alter the nullability of the +{- | Constructs an 'AlterTableAction' that will alter the nullability of the column. @since 1.0.0.0 @@ -286,8 +299,7 @@ , RawSql.toRawSql alterNotNull ] -{- | -Type to represent an action to alter the nullability of a column. E.G. +{- | Type to represent an action to alter the nullability of a column. E.G. > SET NOT NULL @@ -299,10 +311,12 @@ -} newtype AlterNotNull = AlterNotNull RawSql.RawSql - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) -{- | - Sets the column to not null via @SET NOT NULL@. +{- | Sets the column to not null via @SET NOT NULL@. @since 1.0.0.0 -} @@ -310,8 +324,7 @@ setNotNull = AlterNotNull $ RawSql.fromString "SET NOT NULL" -{- | - Sets the column to allow null via @DROP NOT NULL@. +{- | Sets the column to allow null via @DROP NOT NULL@. @since 1.0.0.0 -} @@ -319,8 +332,7 @@ dropNotNull = AlterNotNull $ RawSql.fromString "DROP NOT NULL" -{- | - Constructs an 'AlterTableAction' that will use @DROP DEFAULT@ to drop the +{- | Constructs an 'AlterTableAction' that will use @DROP DEFAULT@ to drop the default value of the specified column. @since 1.0.0.0 @@ -335,8 +347,7 @@ , RawSql.fromString "DROP DEFAULT" ] -{- | - Constructs an 'AlterTableAction' that will use @SET DEFAULT@ to set the +{- | Constructs an 'AlterTableAction' that will use @SET DEFAULT@ to set the default value of the specified column. @since 1.0.0.0 @@ -356,9 +367,40 @@ , RawSql.toRawSql defaultValue ] -{- | -Type to represent a @DROP TABLE@ statement. E.G. +{- | Constructs an 'AlterTableAction' that will use @ADD GENERATED .. AS IDENTITY@ to set the + specified column to be an identity column. + @since 1.1.0.0 +-} +alterColumnAddIdentity :: + ColumnName -> + ColumnIdentityGeneration -> + AlterTableAction +alterColumnAddIdentity columnName columnIdentityGeneration = + AlterTableAction $ + RawSql.fromString "ALTER COLUMN " + <> RawSql.toRawSql columnName + <> RawSql.fromString " ADD GENERATED " + <> RawSql.toRawSql columnIdentityGeneration + <> RawSql.fromString " AS IDENTITY" + +{- | Constructs an 'AlterTableAction' that will drop the identity requirement of a column + + @since 1.1.0.0 +-} +alterColumnDropIdentity :: + ColumnName -> + Maybe IfExists -> + AlterTableAction +alterColumnDropIdentity columnName maybeIfExists = + AlterTableAction $ + RawSql.fromString "ALTER COLUMN " + <> RawSql.toRawSql columnName + <> RawSql.fromString " DROP IDENTITY" + <> maybe mempty (\i -> RawSql.space <> RawSql.toRawSql i) maybeIfExists + +{- | Type to represent a @DROP TABLE@ statement. E.G. + > DROP TABLE FOO 'DropTableExpr' provides a 'RawSql.SqlExpression' instance. See @@ -369,14 +411,16 @@ -} newtype DropTableExpr = DropTableExpr RawSql.RawSql - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) -{- | - Constructs a 'DropTableExpr' that will drop the specified table. +{- | Constructs a 'DropTableExpr' that will drop the specified table. @since 1.0.0.0 -} -dropTableExpr :: Maybe IfExists -> Qualified TableName -> DropTableExpr +dropTableExpr :: Maybe IfExists -> QualifiedOrUnqualified TableName -> DropTableExpr dropTableExpr maybeIfExists tableName = DropTableExpr $ RawSql.intercalate @@ -387,3 +431,29 @@ , Just (RawSql.toRawSql tableName) ] ) + +{- | Type to represent a @TRUNCATE TABLE@ statement. E.G. + +> TRUNCATE TABLE FOO + +'TruncateTableExpr' provides a 'RawSql.SqlExpression' instance. See +'RawSql.unsafeSqlExpression' for how to construct a value with your own custom +SQL. + +@since 1.1.0.0 +-} +newtype TruncateTableExpr + = TruncateTableExpr RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | Constructs a 'TruncateTableExpr' that will truncate the specified tables. + + @since 1.1.0.0 +-} +truncateTablesExpr :: NonEmpty (QualifiedOrUnqualified TableName) -> TruncateTableExpr +truncateTablesExpr tableNames = + TruncateTableExpr $ + RawSql.fromString "TRUNCATE TABLE " <> RawSql.intercalate RawSql.commaSpace tableNames diff --git a/src/Orville/PostgreSQL/Expr/TableReferenceList.hs b/src/Orville/PostgreSQL/Expr/TableReferenceList.hs --- a/src/Orville/PostgreSQL/Expr/TableReferenceList.hs +++ b/src/Orville/PostgreSQL/Expr/TableReferenceList.hs @@ -1,7 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {- | -Copyright : Flipstone Technology Partners 2023 +Copyright : Flipstone Technology Partners 2023-2025 License : MIT Stability : Stable @@ -9,22 +9,23 @@ -} module Orville.PostgreSQL.Expr.TableReferenceList ( TableReferenceList - , referencesTable + , tableReferenceList + , singleTableReferenceList + , TableReference + , tableNameReference ) where -import Orville.PostgreSQL.Expr.Name (Qualified, TableName) +import Orville.PostgreSQL.Expr.Name (AliasExpr, QualifiedOrUnqualified, TableName) import qualified Orville.PostgreSQL.Raw.RawSql as RawSql -{- | -Type to represent the table's references in the @FROM@ clause of a @SELECT -statement. E.G. just the +{- | Type to represent the table references in the @FROM@ clause of a @SELECT statement. E.G. just the -> foo +> foo, bar in -> FROM foo +> FROM foo, bar 'TableReferenceList' provides a 'RawSql.SqlExpression' instance. See 'RawSql.unsafeSqlExpression' for how to construct a value with your own custom @@ -36,13 +37,56 @@ = TableReferenceList RawSql.RawSql deriving (RawSql.SqlExpression) -{- | - Constructs a 'TableReferenceList' consisting of just the specified table - name. +{- | Constructs a 'TableReferenceList' from a list of 'TableReference' values. The table references + will be separated by commas in the resulting list - @since 1.0.0.0 +@since 1.1.0.0 -} -referencesTable :: Qualified TableName -> TableReferenceList -referencesTable qualifiedTableName = - TableReferenceList $ +tableReferenceList :: [TableReference] -> TableReferenceList +tableReferenceList = + TableReferenceList . RawSql.intercalate RawSql.commaSpace + +{- | A convenience function for constructing a 'TableReferenceList' that references just a single + table with no alias. + + See also 'tableReferenceList' and 'tableNameReference'. + +@since 1.1.0.0 +-} +singleTableReferenceList :: QualifiedOrUnqualified TableName -> TableReferenceList +singleTableReferenceList name = + tableReferenceList [tableNameReference name Nothing] + +{- | Type to represent a single table references in the @FROM@ clause of a @SELECT@ + statement. E.G. just the + +> foo + +in + +> FROM foo, bar + +'TableReferenceList' provides a 'RawSql.SqlExpression' instance. See +'RawSql.unsafeSqlExpression' for how to construct a value with your own custom +SQL. + +@since 1.1.0.0 +-} +newtype TableReference + = TableReference RawSql.RawSql + deriving (RawSql.SqlExpression) + +{- | Constructs a 'TableReference' for the specified table name. + +@since 1.1.0.0 +-} +tableNameReference :: + QualifiedOrUnqualified TableName -> + Maybe AliasExpr -> + TableReference +tableNameReference qualifiedTableName mbAliasExpr = + TableReference $ RawSql.toRawSql qualifiedTableName + <> case mbAliasExpr of + Nothing -> mempty + Just aliasExpr -> RawSql.fromString " AS " <> RawSql.toRawSql aliasExpr diff --git a/src/Orville/PostgreSQL/Expr/TextSearch.hs b/src/Orville/PostgreSQL/Expr/TextSearch.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/TextSearch.hs @@ -0,0 +1,466 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{- | +Copyright : Flipstone Technology Partners 2024-2025 +License : MIT +Stability : Stable + +@since 1.1.0.0 +-} +module Orville.PostgreSQL.Expr.TextSearch + ( TSVector + , tsVectorToValueExpression + , TSQuery + , tsQueryToValueExpression + , TSWeight + , tsMatch + , tsMatchTSQueryTSVector + , tsVectorConcat + , toTSVector + , toTSQuery + , plainToTSQuery + , toTSRank + , setTSWeight + , tsWeightToValueExpression + , tsWeightA + , tsWeightB + , tsWeightC + , tsWeightD + , RegConfig + , arabicRegConfig + , danishRegConfig + , dutchRegConfig + , englishRegConfig + , finnishRegConfig + , frenchRegConfig + , germanRegConfig + , greekRegConfig + , hungarianRegConfig + , indonesianRegConfig + , irishRegConfig + , italianRegConfig + , lithuanianRegConfig + , nepaliRegConfig + , norwegianRegConfig + , portugueseRegConfig + , romanianRegConfig + , russianRegConfig + , simpleRegConfig + , spanishRegConfig + , swedishRegConfig + , tamilRegConfig + , turkishRegConfig + ) where + +import Orville.PostgreSQL.Expr.BinaryOperator (BinaryOperator, binaryOpExpression, binaryOperator) +import Orville.PostgreSQL.Expr.Name (FunctionName, functionName) +import Orville.PostgreSQL.Expr.ValueExpression (ValueExpression, functionCall) +import Orville.PostgreSQL.Expr.WhereClause (BooleanExpr) +import qualified Orville.PostgreSQL.Raw.RawSql as RawSql + +{- | Type to represent a PostgreSQL @tsvector@. + +'TSVector' provides a 'RawSql.SqlExpression' instance. See +'RawSql.unsafeSqlExpression' for how to construct a value with your own custom +SQL. + + @since 1.1.0.0 +-} +newtype TSVector + = TSVector RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | Type to represent a PostgreSQL @tsquery@. + +'TSQuery' provides a 'RawSql.SqlExpression' instance. See +'RawSql.unsafeSqlExpression' for how to construct a value with your own custom +SQL. + + @since 1.1.0.0 +-} +newtype TSQuery + = TSQuery RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | A type to represent the weight to be given to elements of a 'TSVector' + +'TSWeight' provides a 'RawSql.SqlExpression' instance. See +'RawSql.unsafeSqlExpression' for how to construct a value with your own custom SQL. + + @since 1.1.0.0 +-} +newtype TSWeight + = TSWeight RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +tsMatchOp :: BinaryOperator +tsMatchOp = binaryOperator "@@" + +tsVectorConcatOp :: BinaryOperator +tsVectorConcatOp = binaryOperator "||" + +{- | Matches a 'TSVector' against a 'TSQuery'. This function is an alias for the '@@' operator. + +@since 1.1.0.0 +-} +tsMatch :: TSVector -> TSQuery -> BooleanExpr +tsMatch tsVector tsQuery = + binaryOpExpression + tsMatchOp + (tsVectorToValueExpression tsVector) + (tsQueryToValueExpression tsQuery) + +{- | Matches a 'TSQuery' against a 'TSVector'. This function is an alias for the '@@' operator. + Filped version of 'tsMatch' + +@since 1.1.0.0 +-} +tsMatchTSQueryTSVector :: TSQuery -> TSVector -> BooleanExpr +tsMatchTSQueryTSVector = flip tsMatch + +{- | Concatenates two 'TSVector' values. + +@since 1.1.0.0 +-} +tsVectorConcat :: TSVector -> TSVector -> TSVector +tsVectorConcat tsVector1 tsVector2 = + binaryOpExpression + tsVectorConcatOp + (tsVectorToValueExpression tsVector1) + (tsVectorToValueExpression tsVector2) + +{- | A constant representing the "A" weight for a 'TSVector'. + +@since 1.1.0.0 +-} +tsWeightA :: TSWeight +tsWeightA = TSWeight $ RawSql.fromString "\'A\'" + +{- | A constant representing the "B" weight for a 'TSVector'. + +@since 1.1.0.0 +-} +tsWeightB :: TSWeight +tsWeightB = TSWeight $ RawSql.fromString "\'B\'" + +{- | A constant representing the "C" weight for a 'TSVector'. + +@since 1.1.0.0 +-} +tsWeightC :: TSWeight +tsWeightC = TSWeight $ RawSql.fromString "\'C\'" + +{- | A constant representing the "D" weight for a 'TSVector'. + +@since 1.1.0.0 +-} +tsWeightD :: TSWeight +tsWeightD = TSWeight $ RawSql.fromString "\'D\'" + +toTSVectorFunction :: FunctionName +toTSVectorFunction = functionName "to_tsvector" + +toTSQueryFunction :: FunctionName +toTSQueryFunction = functionName "to_tsquery" + +toTSRankFunction :: FunctionName +toTSRankFunction = functionName "ts_rank" + +setTSWeightFunction :: FunctionName +setTSWeightFunction = functionName "setweight" + +plaintoTSQueryFunction :: FunctionName +plaintoTSQueryFunction = functionName "plainto_tsquery" + +{- | Converts a 'RegConfig' to a 'ValueExpression'. + +@since 1.1.0.0 +-} +regConfigToValueExpression :: RegConfig -> ValueExpression +regConfigToValueExpression (RegConfig regConfig) = + RawSql.unsafeFromRawSql + ( RawSql.fromString "\'" + <> regConfig + <> RawSql.fromString "\'" + ) + +{- | Converts a 'ValueExpression' to a 'TSVector', optionally using a specified 'RegConfig'. + +The provided 'ValueExpression' must adhere to the following limitations: + * It must evaluate to one of the following types: @text@, @json@, or @jsonb@. + * Behavior may differ depending on whether @json@ or @jsonb@ is used. + * Word normalization will be applied during the conversion process. + +@since 1.1.0.0 +-} +toTSVector :: ValueExpression -> Maybe RegConfig -> TSVector +toTSVector val mbRegConfig = + TSVector + . RawSql.toRawSql + . functionCall toTSVectorFunction + $ case mbRegConfig of + Nothing -> [val] + Just regConfig -> [regConfigToValueExpression regConfig, val] + +{- | Converts a 'ValueExpression' to a 'TSQuery', optionally using a specified 'RegConfig'. + +The provided 'ValueExpression' must adhere to the following limitations: + * It must evaluate to one of the following types: @text@, @json@, or @jsonb@. + * Behavior may differ depending on whether @json@ or @jsonb@ is used. + * Word normalization will be applied during the conversion process. + +@since 1.1.0.0 +-} +toTSQuery :: ValueExpression -> Maybe RegConfig -> TSQuery +toTSQuery val mbRegConfig = + TSQuery + . RawSql.toRawSql + . functionCall toTSQueryFunction + $ case mbRegConfig of + Nothing -> [val] + Just regConfig -> [regConfigToValueExpression regConfig, val] + +{- | Converts a 'TSQuery' to a 'ValueExpression'. + +@since 1.1.0.0 +-} +tsQueryToValueExpression :: TSQuery -> ValueExpression +tsQueryToValueExpression (TSQuery rawSql) = RawSql.unsafeFromRawSql rawSql + +{- | Converts a 'TSVector' to a 'ValueExpression'. + +@since 1.1.0.0 +-} +tsVectorToValueExpression :: TSVector -> ValueExpression +tsVectorToValueExpression (TSVector rawSql) = RawSql.unsafeFromRawSql rawSql + +{- | Perform a text search ranking based on how well the 'TSVector' and 'TSQuery' match. + +@since 1.1.0.0 +-} +toTSRank :: TSVector -> TSQuery -> ValueExpression +toTSRank tsVector tsQuery = + functionCall + toTSRankFunction + [ tsVectorToValueExpression tsVector + , tsQueryToValueExpression tsQuery + ] + +{- | Assigns the given weight to each element of a 'TSVector'. + +@since 1.1.0.0 +-} +setTSWeight :: TSVector -> TSWeight -> TSVector +setTSWeight tsVector tsWeight = + TSVector . RawSql.toRawSql $ + functionCall + setTSWeightFunction + [tsVectorToValueExpression tsVector, tsWeightToValueExpression tsWeight] + +{- | Converts a 'TSWeight' to a 'ValueExpression'. + +@since 1.1.0.0 +-} +tsWeightToValueExpression :: TSWeight -> ValueExpression +tsWeightToValueExpression (TSWeight rawSql) = RawSql.unsafeFromRawSql rawSql + +{- | Converts a 'ValueExpression' into a 'TSQuery', optionally using a specified 'RegConfig'. The + 'ValueExpression' must be text. All punctuation in the given 'ValueExpression' will be ignored + and individual words will be combined with a logical AND. This results in a 'TSQuery' that + matches when all words are present. + +@since 1.1.0.0 +-} +plainToTSQuery :: ValueExpression -> Maybe RegConfig -> TSQuery +plainToTSQuery val mbRegConfig = + TSQuery + . RawSql.toRawSql + . functionCall plaintoTSQueryFunction + $ case mbRegConfig of + Nothing -> [val] + Just regConfig -> [regConfigToValueExpression regConfig, val] + +{- | Type to represent a text search configuration. + +'RegConfig' provides a 'RawSql.SqlExpression' instance. See +'RawSql.unsafeSqlExpression' for how to construct a value with your own custom +SQL. + + @since 1.1.0.0 +-} +newtype RegConfig + = RegConfig RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | The "arabic" text search configuration. + +@since 1.1.0.0 +-} +arabicRegConfig :: RegConfig +arabicRegConfig = RegConfig $ RawSql.fromString "arabic" + +{- | The "danish" text search configuration. + +@since 1.1.0.0 +-} +danishRegConfig :: RegConfig +danishRegConfig = RegConfig $ RawSql.fromString "danish" + +{- | The "dutch" text search configuration. + +@since 1.1.0.0 +-} +dutchRegConfig :: RegConfig +dutchRegConfig = RegConfig $ RawSql.fromString "dutch" + +{- | The "english" text search configuration. + +@since 1.1.0.0 +-} +englishRegConfig :: RegConfig +englishRegConfig = RegConfig $ RawSql.fromString "english" + +{- | The "finnish" text search configuration. + +@since 1.1.0.0 +-} +finnishRegConfig :: RegConfig +finnishRegConfig = RegConfig $ RawSql.fromString "finnish" + +{- | The "french" text search configuration. + +@since 1.1.0.0 +-} +frenchRegConfig :: RegConfig +frenchRegConfig = RegConfig $ RawSql.fromString "french" + +{- | The "german" text search configuration. + +@since 1.1.0.0 +-} +germanRegConfig :: RegConfig +germanRegConfig = RegConfig $ RawSql.fromString "german" + +{- | The "greek" text search configuration. + +@since 1.1.0.0 +-} +greekRegConfig :: RegConfig +greekRegConfig = RegConfig $ RawSql.fromString "greek" + +{- | The "hungarian" text search configuration. + +@since 1.1.0.0 +-} +hungarianRegConfig :: RegConfig +hungarianRegConfig = RegConfig $ RawSql.fromString "hungarian" + +{- | The "indonesian" text search configuration. + +@since 1.1.0.0 +-} +indonesianRegConfig :: RegConfig +indonesianRegConfig = RegConfig $ RawSql.fromString "indonesian" + +{- | The "irish" text search configuration. + +@since 1.1.0.0 +-} +irishRegConfig :: RegConfig +irishRegConfig = RegConfig $ RawSql.fromString "irish" + +{- | The "italian" text search configuration. + +@since 1.1.0.0 +-} +italianRegConfig :: RegConfig +italianRegConfig = RegConfig $ RawSql.fromString "italian" + +{- | The "lithuanian" text search configuration. + +@since 1.1.0.0 +-} +lithuanianRegConfig :: RegConfig +lithuanianRegConfig = RegConfig $ RawSql.fromString "lithuanian" + +{- | The "nepali" text search configuration. + +@since 1.1.0.0 +-} +nepaliRegConfig :: RegConfig +nepaliRegConfig = RegConfig $ RawSql.fromString "nepali" + +{- | The "norwegian" text search configuration. + +@since 1.1.0.0 +-} +norwegianRegConfig :: RegConfig +norwegianRegConfig = RegConfig $ RawSql.fromString "norwegian" + +{- | The "portuguese" text search configuration. + +@since 1.1.0.0 +-} +portugueseRegConfig :: RegConfig +portugueseRegConfig = RegConfig $ RawSql.fromString "portuguese" + +{- | The "romanian" text search configuration. + +@since 1.1.0.0 +-} +romanianRegConfig :: RegConfig +romanianRegConfig = RegConfig $ RawSql.fromString "romanian" + +{- | The "russian" text search configuration. + +@since 1.1.0.0 +-} +russianRegConfig :: RegConfig +russianRegConfig = RegConfig $ RawSql.fromString "russian" + +{- | The "simple" text search configuration. + +@since 1.1.0.0 +-} +simpleRegConfig :: RegConfig +simpleRegConfig = RegConfig $ RawSql.fromString "simple" + +{- | The "spanish" text search configuration. + +@since 1.1.0.0 +-} +spanishRegConfig :: RegConfig +spanishRegConfig = RegConfig $ RawSql.fromString "spanish" + +{- | The "swedish" text search configuration. + +@since 1.1.0.0 +-} +swedishRegConfig :: RegConfig +swedishRegConfig = RegConfig $ RawSql.fromString "swedish" + +{- | The "tamil" text search configuration. + +@since 1.1.0.0 +-} +tamilRegConfig :: RegConfig +tamilRegConfig = RegConfig $ RawSql.fromString "tamil" + +{- | The "turkish" text search configuration. + +@since 1.1.0.0 +-} +turkishRegConfig :: RegConfig +turkishRegConfig = RegConfig $ RawSql.fromString "turkish" diff --git a/src/Orville/PostgreSQL/Expr/Time.hs b/src/Orville/PostgreSQL/Expr/Time.hs --- a/src/Orville/PostgreSQL/Expr/Time.hs +++ b/src/Orville/PostgreSQL/Expr/Time.hs @@ -25,16 +25,14 @@ import Orville.PostgreSQL.Expr.ValueExpression (ParameterName, ValueExpression, functionCall, functionCallNamedParams) import qualified Orville.PostgreSQL.Raw.RawSql as RawSql -{- | - The value of the current time as returned by the PostgreSQL function @now()@. +{- | The value of the current time as returned by the PostgreSQL function @now()@. @since 1.0.0.0 -} now :: ValueExpression now = functionCall (functionName "now") [] -{- | - Constructs a 'ValueExpression' whose value in PostgreSQL is the result of +{- | Constructs a 'ValueExpression' whose value in PostgreSQL is the result of calling @make_interval@ with the specified time intervals passed as named arguments. @@ -46,8 +44,7 @@ (functionName "make_interval") (fmap (\(IntervalArgument paramName, value) -> (paramName, value)) args) -{- | -Type to represent the name of a time interval argument to the PostgreSQL +{- | Type to represent the name of a time interval argument to the PostgreSQL @make_interval@ function. E.G. > years @@ -60,10 +57,12 @@ -} newtype IntervalArgument = IntervalArgument ParameterName - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) -{- | - Constructs an arbitrary 'IntervalArgument' with whatever name you specify. It +{- | Constructs an arbitrary 'IntervalArgument' with whatever name you specify. It is up to you to ensure that name a valid argument name for @make_interval@. @since 1.0.0.0 @@ -72,56 +71,49 @@ unsafeIntervalArg = IntervalArgument . RawSql.unsafeSqlExpression -{- | - The @years@ argument to @make_interval@. +{- | The @years@ argument to @make_interval@. @since 1.0.0.0 -} years :: IntervalArgument years = unsafeIntervalArg "years" -{- | - The @months@ argument to @make_interval@. +{- | The @months@ argument to @make_interval@. @since 1.0.0.0 -} months :: IntervalArgument months = unsafeIntervalArg "months" -{- | - The @weeks@ argument to @make_interval@. +{- | The @weeks@ argument to @make_interval@. @since 1.0.0.0 -} weeks :: IntervalArgument weeks = unsafeIntervalArg "weeks" -{- | - The @days@ argument to @make_interval@. +{- | The @days@ argument to @make_interval@. @since 1.0.0.0 -} days :: IntervalArgument days = unsafeIntervalArg "days" -{- | - The @hours@ argument to @make_interval@. +{- | The @hours@ argument to @make_interval@. @since 1.0.0.0 -} hours :: IntervalArgument hours = unsafeIntervalArg "hours" -{- | - The @mins@ argument to @make_interval@. +{- | The @mins@ argument to @make_interval@. @since 1.0.0.0 -} minutes :: IntervalArgument minutes = unsafeIntervalArg "mins" -{- | - The @secs@ argument to @make_interval@. +{- | The @secs@ argument to @make_interval@. @since 1.0.0.0 -} diff --git a/src/Orville/PostgreSQL/Expr/Transaction.hs b/src/Orville/PostgreSQL/Expr/Transaction.hs --- a/src/Orville/PostgreSQL/Expr/Transaction.hs +++ b/src/Orville/PostgreSQL/Expr/Transaction.hs @@ -38,8 +38,7 @@ import qualified Orville.PostgreSQL.Expr.Name as Name import qualified Orville.PostgreSQL.Raw.RawSql as RawSql -{- | -Type to represent the name of a begin transaction statement. E.G. +{- | Type to represent the name of a begin transaction statement. E.G. > BEGIN TRANSACTION @@ -51,24 +50,24 @@ -} newtype BeginTransactionExpr = BeginTransactionExpr RawSql.RawSql - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) -{- | - Constructs a 'BeginTransactionExpr' that will begin a transaction using +{- | Constructs a 'BeginTransactionExpr' that will begin a transaction using the specified mode, if any. @since 1.0.0.0 -} beginTransaction :: Maybe TransactionMode -> BeginTransactionExpr beginTransaction maybeTransactionMode = - BeginTransactionExpr $ - RawSql.intercalate RawSql.space $ - ( RawSql.fromString "BEGIN TRANSACTION" - : maybeToList (RawSql.toRawSql <$> maybeTransactionMode) - ) + BeginTransactionExpr + . RawSql.intercalate RawSql.space + $ RawSql.fromString "BEGIN TRANSACTION" + : maybeToList (RawSql.toRawSql <$> maybeTransactionMode) -{- | -Type to represent the transaction mode. E.G. +{- | Type to represent the transaction mode. E.G. > ISOLATION LEVEL SERIALIZABLE @@ -80,10 +79,12 @@ -} newtype TransactionMode = TransactionMode RawSql.RawSql - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) -{- | - The @READ WRITE@ transaction mode. +{- | The @READ WRITE@ transaction mode. @since 1.0.0.0 -} @@ -91,8 +92,7 @@ readWrite = TransactionMode (RawSql.fromString "READ WRITE") -{- | - The @READ ONLY@ transaction mode. +{- | The @READ ONLY@ transaction mode. @since 1.0.0.0 -} @@ -100,8 +100,7 @@ readOnly = TransactionMode (RawSql.fromString "READ ONLY") -{- | - The @DEFERRABLE@ transaction mode. +{- | The @DEFERRABLE@ transaction mode. @since 1.0.0.0 -} @@ -109,8 +108,7 @@ deferrable = TransactionMode (RawSql.fromString "DEFERRABLE") -{- | - The @NOT DEFERRABLE@ transaction mode. +{- | The @NOT DEFERRABLE@ transaction mode. @since 1.0.0.0 -} @@ -118,18 +116,16 @@ notDeferrable = TransactionMode (RawSql.fromString "NOT DEFERRABLE") -{- | - An @ISOLATION LEVEL@ transaction mode with the given 'IsolationLevel'. +{- | An @ISOLATION LEVEL@ transaction mode with the given 'IsolationLevel'. @since 1.0.0.0 -} isolationLevel :: IsolationLevel -> TransactionMode isolationLevel level = - TransactionMode $ + TransactionMode (RawSql.fromString "ISOLATION LEVEL " <> RawSql.toRawSql level) -{- | -Type to represent the transaction isolation level. E.G. +{- | Type to represent the transaction isolation level. E.G. > SERIALIZABLE @@ -141,10 +137,12 @@ -} newtype IsolationLevel = IsolationLevel RawSql.RawSql - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) -{- | - The @SERIALIZABLE@ isolation level. +{- | The @SERIALIZABLE@ isolation level. @since 1.0.0.0 -} @@ -152,8 +150,7 @@ serializable = IsolationLevel (RawSql.fromString "SERIALIZABLE") -{- | - The @REPEATABLE READ@ isolation level. +{- | The @REPEATABLE READ@ isolation level. @since 1.0.0.0 -} @@ -161,8 +158,7 @@ repeatableRead = IsolationLevel (RawSql.fromString "REPEATABLE READ") -{- | - The @READ COMMITTED@ isolation level. +{- | The @READ COMMITTED@ isolation level. @since 1.0.0.0 -} @@ -170,8 +166,7 @@ readCommitted = IsolationLevel (RawSql.fromString "READ COMMITTED") -{- | - The @READ UNCOMMITTED@ isolation level. +{- | The @READ UNCOMMITTED@ isolation level. @since 1.0.0.0 -} @@ -179,8 +174,7 @@ readUncommitted = IsolationLevel (RawSql.fromString "READ UNCOMMITTED") -{- | -Type to represent the transaction commit statement. E.G. +{- | Type to represent the transaction commit statement. E.G. > COMMIT @@ -192,10 +186,12 @@ -} newtype CommitExpr = CommitExpr RawSql.RawSql - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) -{- | - A @COMMIT@ transaction statement. +{- | A @COMMIT@ transaction statement. @since 1.0.0.0 -} @@ -203,8 +199,7 @@ commit = CommitExpr (RawSql.fromString "COMMIT") -{- | -Type to represent the transaction rollback statement. E.G. +{- | Type to represent the transaction rollback statement. E.G. > ROLLBACK @@ -216,10 +211,12 @@ -} newtype RollbackExpr = RollbackExpr RawSql.RawSql - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) -{- | - A @ROLLBACK@ transaction statement. +{- | A @ROLLBACK@ transaction statement. @since 1.0.0.0 -} @@ -227,8 +224,7 @@ rollback = RollbackExpr (RawSql.fromString "ROLLBACK") -{- | - A @ROLLBACK TO@ transaction statement that will rollback to the specified +{- | A @ROLLBACK TO@ transaction statement that will rollback to the specified savepoint. @since 1.0.0.0 @@ -238,8 +234,7 @@ RollbackExpr $ RawSql.fromString "ROLLBACK TO SAVEPOINT " <> RawSql.toRawSql savepointName -{- | -Type to represent the transaction savepoint statement. E.G. +{- | Type to represent the transaction savepoint statement. E.G. > SAVEPOINT foo @@ -251,10 +246,12 @@ -} newtype SavepointExpr = SavepointExpr RawSql.RawSql - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) -{- | - A @SAVEPOINT@ statement that will create a savepoint with the given name. +{- | A @SAVEPOINT@ statement that will create a savepoint with the given name. @since 1.0.0.0 -} @@ -263,8 +260,7 @@ SavepointExpr $ RawSql.fromString "SAVEPOINT " <> RawSql.toRawSql savepointName -{- | -Type to represent the transaction release savepoint statement. E.G. +{- | Type to represent the transaction release savepoint statement. E.G. > RELEASE SAVEPOINT foo @@ -276,10 +272,12 @@ -} newtype ReleaseSavepointExpr = ReleaseSavepontExpr RawSql.RawSql - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) -{- | - A @RELEASE SAVEPOINT@ statement that will release the specified savepoint. +{- | A @RELEASE SAVEPOINT@ statement that will release the specified savepoint. @since 1.0.0.0 -} diff --git a/src/Orville/PostgreSQL/Expr/Trigger.hs b/src/Orville/PostgreSQL/Expr/Trigger.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/Trigger.hs @@ -0,0 +1,270 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{- | +Copyright : Flipstone Technology Partners 2024 +License : MIT +Stability : Stable + +@since 1.1.0.0 +-} +module Orville.PostgreSQL.Expr.Trigger + ( DropTriggerExpr + , dropTrigger + , CreateTriggerExpr + , createTrigger + , TriggerTiming + , triggerBefore + , triggerAfter + , triggerInsteadOf + , TriggerEvent + , triggerOnInsert + , triggerOnUpdate + , triggerOnUpdateOf + , triggerOnDelete + , triggerOnTruncate + , TriggerFireScope + , triggerForEachRow + , triggerForEachStatement + ) where + +import qualified Data.List.NonEmpty as NEL +import Data.Maybe (catMaybes) + +import Orville.PostgreSQL.Expr.IfExists (IfExists) +import Orville.PostgreSQL.Expr.Name (ColumnName, FunctionName, QualifiedOrUnqualified, TableName, TriggerName) +import Orville.PostgreSQL.Expr.OrReplace (OrReplace) +import qualified Orville.PostgreSQL.Raw.RawSql as RawSql + +{- | Type to represent a SQL "DROP TRIGGER" statement. E.G. + +> DROP TRIGGER my_trigger ON my_table + +'DropTriggerExpr' provides a 'RawSql.SqlExpression' instance. See +'RawSql.unsafeSqlExpression' for how to construct a value with your own custom +SQL. + +@since 1.1.0.0 +-} +newtype DropTriggerExpr + = DropTriggerExpr RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | Constructs a SQL @DROP TRIGGER@ statement from the trigger name and table name + +@since 1.1.0.0 +-} +dropTrigger :: + Maybe IfExists -> + TriggerName -> + QualifiedOrUnqualified TableName -> + DropTriggerExpr +dropTrigger maybeIfExists name tableName = + DropTriggerExpr $ + RawSql.intercalate + RawSql.space + ( catMaybes + [ Just (RawSql.fromString "DROP TRIGGER") + , fmap RawSql.toRawSql maybeIfExists + , Just (RawSql.toRawSql name) + , Just (RawSql.fromString "ON") + , Just (RawSql.toRawSql tableName) + ] + ) + +{- | Type to represent a SQL "CREATE TRIGGER" statement. E.G. + +> CREATE TRIGGER my_trigger BEFORE UPDATE ON my_table EXECUTE PROCEDURE my_trigger_function + +'CreateTriggerExpr' provides a 'RawSql.SqlExpression' instance. See +'RawSql.unsafeSqlExpression' for how to construct a value with your own custom +SQL. + +@since 1.1.0.0 +-} +newtype CreateTriggerExpr + = CreateTriggerExpr RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | Constructs a SQL @CREATE TRIGGER@ statement from the trigger name and its defining +attributes. + +Note: Orville does not currently support creating triggers with arguments. + +Note: Before PostgreSQL 14, there is no @CREATE OR REPLACE TRIGGER@ syntax in +PsotgreSQL. If you're using a version of PostgreSQL prior to 14 then you must +specify 'Nothing' for the 'OrReplace' property. + +@since 1.1.0.0 +-} +createTrigger :: + Maybe OrReplace -> + TriggerName -> + TriggerTiming -> + NEL.NonEmpty TriggerEvent -> + QualifiedOrUnqualified TableName -> + TriggerFireScope -> + QualifiedOrUnqualified FunctionName -> + CreateTriggerExpr +createTrigger maybeOrReplace name timing events tableName fireScope functionName = + CreateTriggerExpr $ + RawSql.intercalate + RawSql.space + ( catMaybes + [ Just $ RawSql.fromString "CREATE" + , RawSql.toRawSql <$> maybeOrReplace + , Just $ RawSql.fromString "TRIGGER" + , Just $ RawSql.toRawSql name + , Just $ RawSql.toRawSql timing + , Just $ RawSql.intercalate (RawSql.fromString " OR ") events + , Just $ RawSql.fromString "ON" + , Just $ RawSql.toRawSql tableName + , Just $ RawSql.toRawSql fireScope + , Just $ RawSql.fromString "EXECUTE FUNCTION" + , Just $ RawSql.toRawSql functionName + , Just $ RawSql.fromString "()" -- we don't currently support arguments + ] + ) + +{- | Type to represent the time at which a trigger will fire in releation to the +event that caused it. E.G. the @BEFORE@ in + +> CREATE TRIGGER my_trigger BEFORE UPDATE ON my_table FOR EACH ROW EXECUTE PROCEDURE my_trigger_function + +'TriggerTiming' provides a 'RawSql.SqlExpression' instance. See +'RawSql.unsafeSqlExpression' for how to construct a value with your own custom +SQL. + +@since 1.1.0.0 +-} +newtype TriggerTiming + = TriggerTiming RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | The @BEFORE@ 'TriggerTiming'. + +@since 1.1.0.0 +-} +triggerBefore :: TriggerTiming +triggerBefore = + TriggerTiming (RawSql.fromString "BEFORE") + +{- | The @AFTER@ 'TriggerTiming'. + +@since 1.1.0.0 +-} +triggerAfter :: TriggerTiming +triggerAfter = + TriggerTiming (RawSql.fromString "AFTER") + +{- | The @INSTEAD OF@ 'TriggerTiming'. + +@since 1.1.0.0 +-} +triggerInsteadOf :: TriggerTiming +triggerInsteadOf = + TriggerTiming (RawSql.fromString "INSTEAD OF") + +{- | Type to represent the an event that will cause a trigger to fire in a SQL "CREATE +TRIGGER" statement. E.G. the @UPDATE@ in + +> CREATE TRIGGER my_trigger BEFORE UPDATE ON my_table FOR EACH ROW EXECUTE PROCEDURE my_trigger_function + +'TriggerEvent' provides a 'RawSql.SqlExpression' instance. See +'RawSql.unsafeSqlExpression' for how to construct a value with your own custom +SQL. + +@since 1.1.0.0 +-} +newtype TriggerEvent + = TriggerEvent RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | The @INSERT@ 'TriggerEvent' + +@since 1.1.0.0 +-} +triggerOnInsert :: TriggerEvent +triggerOnInsert = + TriggerEvent (RawSql.fromString "INSERT") + +{- | The @UPDATE@ 'TriggerEvent' + +@since 1.1.0.0 +-} +triggerOnUpdate :: TriggerEvent +triggerOnUpdate = + TriggerEvent (RawSql.fromString "UPDATE") + +{- | The @UPDATE OF@ 'TriggerEvent'. This causes the trigger only to fire when on of +the specified columns is mentioned of affected by an update. + +@since 1.1.0.0 +-} +triggerOnUpdateOf :: NEL.NonEmpty ColumnName -> TriggerEvent +triggerOnUpdateOf columnNames = + TriggerEvent $ + RawSql.fromString "UPDATE OF" + <> RawSql.intercalate RawSql.comma (fmap RawSql.toRawSql columnNames) + +{- | The @DELETE@ 'TriggerEvent' + +@since 1.1.0.0 +-} +triggerOnDelete :: TriggerEvent +triggerOnDelete = + TriggerEvent (RawSql.fromString "DELETE") + +{- | The @TRUNCATE@ 'TriggerEvent' + +@since 1.1.0.0 +-} +triggerOnTruncate :: TriggerEvent +triggerOnTruncate = + TriggerEvent (RawSql.fromString "TRUNCATE") + +{- | Type to represent the part of a SQL "CREATE TRIGGER" statement that indicates whether +the trigger will be fired once for each row or once for each statement. E.G. the +@FOR EACH ROW@ in + +> CREATE TRIGGER my_trigger BEFORE UPDATE ON my_table FOR EACH ROW EXECUTE PROCEDURE my_trigger_function + +'TriggerFireScope' provides a 'RawSql.SqlExpression' instance. See +'RawSql.unsafeSqlExpression' for how to construct a value with your own custom +SQL. + +@since 1.1.0.0 +-} +newtype TriggerFireScope + = TriggerFireScope RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | The @FOR EACH ROW@ 'TriggerFireScope' + +@since 1.1.0.0 +-} +triggerForEachRow :: TriggerFireScope +triggerForEachRow = + TriggerFireScope (RawSql.fromString "FOR EACH ROW") + +{- | The @FOR EACH STATEMENT@ 'TriggerFireScope' + +@since 1.1.0.0 +-} +triggerForEachStatement :: TriggerFireScope +triggerForEachStatement = + TriggerFireScope (RawSql.fromString "FOR EACH STATEMENT") diff --git a/src/Orville/PostgreSQL/Expr/Update.hs b/src/Orville/PostgreSQL/Expr/Update.hs --- a/src/Orville/PostgreSQL/Expr/Update.hs +++ b/src/Orville/PostgreSQL/Expr/Update.hs @@ -1,7 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {- | -Copyright : Flipstone Technology Partners 2023 +Copyright : Flipstone Technology Partners 2023-2025 License : MIT Stability : Stable @@ -14,20 +14,24 @@ , setClauseList , SetClause , setColumn + , setColumnExpression + , UpdateNamedOnly + , onlyUpdateNamedTable ) where import Data.List.NonEmpty (NonEmpty) import Data.Maybe (catMaybes) -import Orville.PostgreSQL.Expr.Name (ColumnName, Qualified, TableName) +import Orville.PostgreSQL.Expr.Name (ColumnName, QualifiedOrUnqualified, TableName) import Orville.PostgreSQL.Expr.ReturningExpr (ReturningExpr) +import Orville.PostgreSQL.Expr.TableReferenceList (TableReferenceList) +import Orville.PostgreSQL.Expr.ValueExpression (ValueExpression) import Orville.PostgreSQL.Expr.WhereClause (WhereClause) import qualified Orville.PostgreSQL.Raw.RawSql as RawSql import qualified Orville.PostgreSQL.Raw.SqlValue as SqlValue -{- | -Type to represent a SQL @UPDATE@ statement. E.G. +{- | Type to represent a SQL @UPDATE@ statement. E.G. > UPDATE foo > SET id = 1 @@ -41,38 +45,78 @@ -} newtype UpdateExpr = UpdateExpr RawSql.RawSql - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) -{- | - Constructs an 'UpdateExpr' with the given options. +{- | Constructs an 'UpdateExpr' with the given options. - @since 1.0.0.0 +@since 1.0.0.0 -} updateExpr :: -- | The name of the table to be updated. - Qualified TableName -> + QualifiedOrUnqualified TableName -> + -- | Optionally update only the given table name + Maybe UpdateNamedOnly -> -- | The updates to be made to the table. SetClauseList -> + -- | An optional 'TableReferenceList' to allow columns from other tables to be included in the + -- 'SetClauseList' and 'WhereClause' + -- + -- @since 1.1.0.0 + Maybe TableReferenceList -> -- | An optional where clause to limit the rows updated. Maybe WhereClause -> -- | An optional returning clause to return data from the updated rows. Maybe ReturningExpr -> UpdateExpr -updateExpr tableName setClause maybeWhereClause maybeReturningExpr = - UpdateExpr $ - RawSql.intercalate RawSql.space $ - catMaybes +updateExpr tableName maybeUpdateNamedOnly setClause maybeTableRefs maybeWhereClause maybeReturningExpr = + let + buildTableRefs :: TableReferenceList -> RawSql.RawSql + buildTableRefs tableRefs = + RawSql.fromString "FROM " <> RawSql.toRawSql tableRefs + in + UpdateExpr + . RawSql.intercalate RawSql.space + $ catMaybes [ Just $ RawSql.fromString "UPDATE" + , fmap RawSql.toRawSql maybeUpdateNamedOnly , Just $ RawSql.toRawSql tableName , Just $ RawSql.fromString "SET" , Just $ RawSql.toRawSql setClause + , fmap buildTableRefs maybeTableRefs , fmap RawSql.toRawSql maybeWhereClause , fmap RawSql.toRawSql maybeReturningExpr ] -{- | -Type to represent the list of updates to be made in an @UPDATE@ statement. E.G. +{- | Type to represent the option to update only the named table and not any descendants. E.G. +> ONLY + +'UpdateNamedOnly' provides a 'RawSql.SqlExpression' instance. See +'RawSql.unsafeSqlExpression' for how to construct a value with your own custom +SQL. + +@since 1.1.0.0 +-} +newtype UpdateNamedOnly + = UpdateNamedOnly RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | The @ONLY@ modifier to an @UPDATE@ to not update any descendant tables. + +@since 1.1.0.0 +-} +onlyUpdateNamedTable :: UpdateNamedOnly +onlyUpdateNamedTable = + UpdateNamedOnly $ RawSql.fromString "ONLY" + +{- | Type to represent the list of updates to be made in an @UPDATE@ statement. E.G. + > foo = 1, > bar = 2 @@ -84,10 +128,12 @@ -} newtype SetClauseList = SetClauseList RawSql.RawSql - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) -{- | - Constructs a 'SetClauseList' with the specified set clauses. +{- | Constructs a 'SetClauseList' with the specified set clauses. @since 1.0.0.0 -} @@ -95,8 +141,7 @@ setClauseList = SetClauseList . RawSql.intercalate RawSql.comma -{- | -Type to represent a single update to be made in an @UPDATE@ statement. E.G. +{- | Type to represent a single update to be made in an @UPDATE@ statement. E.G. > foo = 1 @@ -108,17 +153,33 @@ -} newtype SetClause = SetClause RawSql.RawSql - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) -{- | - Constructs a 'SetClause' that will set the specified column to the specified +{- | Constructs a 'SetClause' that will set the specified column to the specified value. @since 1.0.0.0 -} -setColumn :: ColumnName -> SqlValue.SqlValue -> SetClause +setColumn :: QualifiedOrUnqualified ColumnName -> SqlValue.SqlValue -> SetClause setColumn columnName value = SetClause $ RawSql.toRawSql columnName <> RawSql.fromString "=" <> RawSql.parameter value + +{- | Constructs a 'SetClause' that will set the specified columns to the expression. + +@since 1.1.0.0 +-} +setColumnExpression :: + NonEmpty (QualifiedOrUnqualified ColumnName) -> + ValueExpression -> + SetClause +setColumnExpression columnNames value = + SetClause $ + RawSql.intercalate RawSql.comma (fmap RawSql.toRawSql columnNames) + <> RawSql.fromString "=" + <> RawSql.parenthesized (RawSql.toRawSql value) diff --git a/src/Orville/PostgreSQL/Expr/Vacuum.hs b/src/Orville/PostgreSQL/Expr/Vacuum.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/Vacuum.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{- | +Copyright : Flipstone Technology Partners 2024 +License : MIT +Stability : Stable + +@since 1.1.0.0 +-} +module Orville.PostgreSQL.Expr.Vacuum + ( VacuumExpr + , vacuumExpr + , VacuumOption + , vacuumFull + , vacuumFreeze + , vacuumVerbose + , vacuumAnalyze + ) +where + +import Data.List.NonEmpty (NonEmpty) + +import Orville.PostgreSQL.Expr.Name (QualifiedOrUnqualified, TableName) +import qualified Orville.PostgreSQL.Raw.RawSql as RawSql + +{- | Type to represent a @VACUUM@ statement. E.G. + +> VACUUM foo + +'VacuumExpr' provides a 'RawSql.SqlExpression' instance. See +'RawSql.unsafeSqlExpression' for how to construct a value with your own custom +SQL. + +@since 1.1.0.0 +-} +newtype VacuumExpr + = VacuumExpr RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | Constructs a 'VacuumExpr' with the given vacuum options on the given tables. + + @since 1.1.0.0 +-} +vacuumExpr :: [VacuumOption] -> NonEmpty (QualifiedOrUnqualified TableName) -> VacuumExpr +vacuumExpr vacuumOptions tables = + let + optionsWithSpaceRawSql = + case vacuumOptions of + [] -> + RawSql.space + opts -> + RawSql.space + <> RawSql.parenthesized (RawSql.intercalate RawSql.commaSpace opts) + <> RawSql.space + in + VacuumExpr $ + RawSql.fromString "VACUUM" + <> optionsWithSpaceRawSql + <> RawSql.intercalate RawSql.commaSpace tables + +{- | Type to represent the option(s) to a @VACUUM@ statement. E.G. + +> FULL TRUE + +'VacuumExpr' provides a 'RawSql.SqlExpression' instance. See +'RawSql.unsafeSqlExpression' for how to construct a value with your own custom +SQL. + +@since 1.1.0.0 +-} +newtype VacuumOption + = VacuumOption RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | Constructs a 'VaccumOption' that will instruct if the vacuum should be "full". + + @since 1.1.0.0 +-} +vacuumFull :: Bool -> VacuumOption +vacuumFull bool = + VacuumOption $ RawSql.fromString "FULL " <> boolRawSql bool + +{- | Constructs a 'VaccumOption' that will instruct if the vacuum should be agressive in "freezing" of + tuples. + + @since 1.1.0.0 +-} +vacuumFreeze :: Bool -> VacuumOption +vacuumFreeze bool = + VacuumOption $ RawSql.fromString "FREEZE " <> boolRawSql bool + +{- | Constructs a 'VaccumOption' that will instruct if the vacuum should be verbose. + + @since 1.1.0.0 +-} +vacuumVerbose :: Bool -> VacuumOption +vacuumVerbose bool = + VacuumOption $ RawSql.fromString "VERBOSE " <> boolRawSql bool + +{- | Constructs a 'VaccumOption' that will instruct if the vacuum should "analyze" to update statitics + used by the PostgreSQL query planner. + + @since 1.1.0.0 +-} +vacuumAnalyze :: Bool -> VacuumOption +vacuumAnalyze bool = + VacuumOption $ RawSql.fromString "ANALYZE " <> boolRawSql bool + +boolRawSql :: Bool -> RawSql.RawSql +boolRawSql bool = + if bool then RawSql.fromString "TRUE" else RawSql.fromString "FALSE" diff --git a/src/Orville/PostgreSQL/Expr/ValueExpression.hs b/src/Orville/PostgreSQL/Expr/ValueExpression.hs --- a/src/Orville/PostgreSQL/Expr/ValueExpression.hs +++ b/src/Orville/PostgreSQL/Expr/ValueExpression.hs @@ -1,7 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {- | -Copyright : Flipstone Technology Partners 2023 +Copyright : Flipstone Technology Partners 2023-2025 License : MIT Stability : Stable @@ -22,12 +22,11 @@ import qualified Data.List.NonEmpty as NE import Orville.PostgreSQL.Expr.DataType (DataType) -import Orville.PostgreSQL.Expr.Name (ColumnName, FunctionName) +import Orville.PostgreSQL.Expr.Name (ColumnName, FunctionName, QualifiedOrUnqualified) import qualified Orville.PostgreSQL.Raw.RawSql as RawSql import Orville.PostgreSQL.Raw.SqlValue (SqlValue) -{- | -Type to represent an arbitrary value in a SQL expression. This could be a +{- | Type to represent an arbitrary value in a SQL expression. This could be a constant value, a column reference or any arbitrary calculated expression. E.G. @@ -40,10 +39,12 @@ @since 1.0.0.0 -} newtype ValueExpression = ValueExpression RawSql.RawSql - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) -{- | -Performs a SQL type cast to the specified type on the given 'ValueExpression'. +{- | Performs a SQL type cast to the specified type on the given 'ValueExpression'. E.G. > foo :: integer @@ -57,19 +58,17 @@ <> RawSql.fromString "::" <> RawSql.toRawSql dataType -{- | -Uses a 'ColumnName' to reference a column as a 'ValueExpression'. This +{- | Uses a 'ColumnName' to reference a column as a 'ValueExpression'. This is the equivalent of simply writing the column name as the expression. E.G. > foo @since 1.0.0.0 -} -columnReference :: ColumnName -> ValueExpression +columnReference :: QualifiedOrUnqualified ColumnName -> ValueExpression columnReference = ValueExpression . RawSql.toRawSql -{- | - Uses the given 'SqlValue' as a constant expression. The value will be passed +{- | Uses the given 'SqlValue' as a constant expression. The value will be passed as a statement parameter, not as a literal expression, so there is not need to worry about escaping. However, there are a few places (usually in DDL) where PostgreSQL does not support values passed as parameters where this @@ -80,8 +79,7 @@ valueExpression :: SqlValue -> ValueExpression valueExpression = ValueExpression . RawSql.parameter -{- | -Constructs a PostgreSQL row value expression from the given list of +{- | Constructs a PostgreSQL row value expression from the given list of expressions. E.G. > (foo, bar, now()) @@ -95,8 +93,7 @@ <> RawSql.intercalate RawSql.comma elements <> RawSql.rightParen -{- | -Constructs a 'ValueExpression' that will call the specified PostgreSQL +{- | Constructs a 'ValueExpression' that will call the specified PostgreSQL function with the given arguments passed as position parameters. E.G. > nextval(sequence_name) @@ -111,8 +108,7 @@ <> RawSql.intercalate RawSql.comma parameters <> RawSql.rightParen -{- | -Type to represent the name of a name parameter in a PostgreSQL function call. +{- | Type to represent the name of a name parameter in a PostgreSQL function call. E.G. > foo @@ -128,10 +124,12 @@ @since 1.0.0.0 -} newtype ParameterName = ParameterName RawSql.RawSql - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) -{- | -Constructs a 'ValueExpression' that will call the specified PostgreSQL +{- | Constructs a 'ValueExpression' that will call the specified PostgreSQL function with the given arguments passed as named parameters. E.G. > make_interval(years => 1) @@ -146,8 +144,7 @@ <> RawSql.intercalate RawSql.comma (fmap (uncurry namedParameterArgument) parameters) <> RawSql.rightParen -{- | - Constructs a sql fragment that will pass the given named argument with the +{- | Constructs a sql fragment that will pass the given named argument with the specified value. @since 1.0.0.0 diff --git a/src/Orville/PostgreSQL/Expr/Values.hs b/src/Orville/PostgreSQL/Expr/Values.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/Values.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{- | +Copyright : Flipstone Technology Partners 2024 +License : MIT +Stability : Stable + +@since 1.1.0.0 +-} +module Orville.PostgreSQL.Expr.Values + ( ValuesExpr + , valuesExpr + , valuesExprFromValueExpressions + , ValuesExprRow + , valuesExprRow + , ValuesExprValue + , valuesExprValue + , valuesExprDefaultValue + , valuesQueryExpr + ) where + +import Data.List.NonEmpty (NonEmpty) +import Data.Maybe (catMaybes) + +import Orville.PostgreSQL.Expr.FetchClause (FetchClause) +import Orville.PostgreSQL.Expr.LimitExpr (LimitExpr) +import Orville.PostgreSQL.Expr.OffsetExpr (OffsetExpr) +import Orville.PostgreSQL.Expr.OrderBy (OrderByExpr) +import Orville.PostgreSQL.Expr.Query (QueryExpr) +import Orville.PostgreSQL.Expr.ValueExpression (ValueExpression) +import qualified Orville.PostgreSQL.Raw.RawSql as RawSql + +{- | Type to represent a @VALUES@ statement, e.g. + +> VALUES ('Bob',32),('Cindy',33) + +@since 1.1.0.0 +-} +newtype ValuesExpr = ValuesExpr RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | Construct a 'ValuesExpr' for the given 'ValuesExprRow's, and any of the supported + optional clauses. + +@since 1.1.0.0 +-} +valuesExpr :: + NonEmpty ValuesExprRow -> + Maybe OrderByExpr -> + Maybe LimitExpr -> + Maybe OffsetExpr -> + Maybe FetchClause -> + ValuesExpr +valuesExpr vals mbOrderBy mbLimit mbOffset mbFetch = + let + opts = + RawSql.intercalate RawSql.space $ + catMaybes + [ fmap RawSql.toRawSql mbOrderBy + , fmap RawSql.toRawSql mbLimit + , fmap RawSql.toRawSql mbOffset + , fmap RawSql.toRawSql mbFetch + ] + in + ValuesExpr $ + RawSql.fromString "VALUES " + <> RawSql.intercalate RawSql.comma (fmap RawSql.toRawSql vals) + <> opts + +{- | A helper function to construct a 'ValuesExpr' from a non-empty lists of 'ValueExpression's, + useful for conveinently constructing a 'ValuesExpr' in contexts where you don't need to use + @DEFAULT@ values or additional clauses. + +@since 1.1.0.0 +-} +valuesExprFromValueExpressions :: NonEmpty (NonEmpty ValueExpression) -> ValuesExpr +valuesExprFromValueExpressions valExprs = + let + rows = + fmap (valuesExprRow . fmap valuesExprValue) valExprs + in + valuesExpr rows Nothing Nothing Nothing Nothing + +{- | A non-emtpy row of values or @DEFAULT@s used to construct the rows for a 'ValueExpr'. + +@since 1.1.0.0 +-} +newtype ValuesExprRow = ValuesExprRow RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | Construct a 'ValuesExprRow' from a non-empty list of 'ValuesExprValue's. + +@since 1.1.0.0 +-} +valuesExprRow :: NonEmpty ValuesExprValue -> ValuesExprRow +valuesExprRow vals = + ValuesExprRow + . RawSql.parenthesized + $ RawSql.intercalate RawSql.comma (fmap RawSql.toRawSql vals) + +{- | A value used to construct a 'ValuesExprRow'. + +@since 1.1.0.0 +-} +newtype ValuesExprValue = ValuesExprValue RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | Construct a 'ValuesExprValue' from a 'ValueExpression'. + +@since 1.1.0.0 +-} +valuesExprValue :: ValueExpression -> ValuesExprValue +valuesExprValue = ValuesExprValue . RawSql.toRawSql + +{- | Construct a @DEFAULT@ 'ValuesExprValue'. Only valid in the context of a 'ValuesExpr' used for an + @INSERT@ statement, where it indicates that the default value should be used for a column. + +@since 1.1.0.0 +-} +valuesExprDefaultValue :: ValuesExprValue +valuesExprDefaultValue = ValuesExprValue $ RawSql.fromString "DEFAULT" + +{- | Use a 'ValuesExpr' as a 'QueryExpr'. + +@since 1.1.0.0 +-} +valuesQueryExpr :: ValuesExpr -> QueryExpr +valuesQueryExpr = RawSql.unsafeFromRawSql . RawSql.toRawSql diff --git a/src/Orville/PostgreSQL/Expr/WhereClause.hs b/src/Orville/PostgreSQL/Expr/WhereClause.hs --- a/src/Orville/PostgreSQL/Expr/WhereClause.hs +++ b/src/Orville/PostgreSQL/Expr/WhereClause.hs @@ -1,7 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {- | -Copyright : Flipstone Technology Partners 2023 +Copyright : Flipstone Technology Partners 2023-2024 License : MIT Stability : Stable @@ -16,9 +16,12 @@ , (.&&) , orExpr , (.||) + , notExpr , parenthesized , equals , notEquals + , isDistinctFrom + , isNotDistinctFrom , greaterThan , lessThan , greaterThanOrEqualTo @@ -40,12 +43,11 @@ import qualified Data.List.NonEmpty as NE -import Orville.PostgreSQL.Expr.BinaryOperator (andOp, binaryOpExpression, equalsOp, greaterThanOp, greaterThanOrEqualsOp, iLikeOp, lessThanOp, lessThanOrEqualsOp, likeOp, notEqualsOp, orOp) +import Orville.PostgreSQL.Expr.BinaryOperator (andOp, binaryOpExpression, equalsOp, greaterThanOp, greaterThanOrEqualsOp, iLikeOp, isDistinctFromOp, isNotDistinctFromOp, lessThanOp, lessThanOrEqualsOp, likeOp, notEqualsOp, orOp) import Orville.PostgreSQL.Expr.ValueExpression (ValueExpression, rowValueConstructor) import qualified Orville.PostgreSQL.Raw.RawSql as RawSql -{- | -Type to represent a @WHERE@ clause restriction on a @SELECT@, @UPDATE@ or +{- | Type to represent a @WHERE@ clause restriction on a @SELECT@, @UPDATE@ or @DELETE@ statement. E.G. > WHERE (foo > 10) @@ -58,10 +60,12 @@ -} newtype WhereClause = WhereClause RawSql.RawSql - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) -{- | -Constructs a @WHERE@ clause from the given 'BooleanExpr'. E.G. +{- | Constructs a @WHERE@ clause from the given 'BooleanExpr'. E.G. > WHERE @@ -72,8 +76,7 @@ WhereClause $ RawSql.fromString "WHERE " <> RawSql.toRawSql booleanExpr -{- | -Type to represent a SQL value expression that evaluates to a boolean and therefore +{- | Type to represent a SQL value expression that evaluates to a boolean and therefore can used with boolean logic functions. E.G. > foo > 10 @@ -86,10 +89,12 @@ -} newtype BooleanExpr = BooleanExpr RawSql.RawSql - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) -{- | - Constructs a 'BooleanExpr' whose value is the SQL literal @TRUE@ or @FALSE@ +{- | Constructs a 'BooleanExpr' whose value is the SQL literal @TRUE@ or @FALSE@ depending on the argument given. @since 1.0.0.0 @@ -101,8 +106,7 @@ False -> "FALSE" True -> "TRUE" -{- | - Converts a 'BooleanExpr' to a 'ValueExpression' so that it can be used +{- | Converts a 'BooleanExpr' to a 'ValueExpression' so that it can be used anywhere 'ValueExpression' is allowed. @since 1.0.0.0 @@ -111,8 +115,7 @@ booleanValueExpression (BooleanExpr rawSql) = RawSql.unsafeFromRawSql rawSql -{- | - The SQL @OR@ operator. The arguments will be surrounded with parentheses +{- | The SQL @OR@ operator. The arguments will be surrounded with parentheses to ensure that the associativity of expression in the resulting SQL matches the associativity implied by this Haskell function. @@ -125,8 +128,7 @@ (booleanValueExpression left) (booleanValueExpression right) -{- | - The SQL @OR@ operator (alias for 'orExpr'). +{- | The SQL @OR@ operator (alias for 'orExpr'). @since 1.0.0.0 -} @@ -135,8 +137,7 @@ infixr 8 .|| -{- | - The SQL @AND@ operator. The arguments will be surrounded with parentheses +{- | The SQL @AND@ operator. The arguments will be surrounded with parentheses to ensure that the associativity of expression in the resulting SQL matches the associativity implied by this Haskell function. @@ -149,8 +150,7 @@ (booleanValueExpression left) (booleanValueExpression right) -{- | - The SQL @AND@ operator (alias for 'andExpr'). +{- | The SQL @AND@ operator (alias for 'andExpr'). @since 1.0.0.0 -} @@ -159,8 +159,19 @@ infixr 8 .&& -{- | - The SQL @IN@ operator. The result will be @TRUE@ if the given value +{- | The SQL @NOT@ operator. The argument will be surrounded with parentheses + to ensure that the associativity of expression in the resulting SQL matches + the associativity implied by this Haskell function. + + @since 1.1.0.0 +-} +notExpr :: BooleanExpr -> BooleanExpr +notExpr bool = + BooleanExpr $ + RawSql.fromString "NOT " + <> RawSql.parenthesized bool + +{- | The SQL @IN@ operator. The result will be @TRUE@ if the given value appears in the list of values given. @since 1.0.0.0 @@ -169,8 +180,7 @@ valueIn needle haystack = inPredicate needle (inValueList haystack) -{- | - The SQL @NOT IN@ operator. The result will be @TRUE@ if the given value +{- | The SQL @NOT IN@ operator. The result will be @TRUE@ if the given value does not appear in the list of values given. @since 1.0.0.0 @@ -179,8 +189,7 @@ valueNotIn needle haystack = notInPredicate needle (inValueList haystack) -{- | - The SQL @IN@ operator, like 'valueIn', but for when you want to construct a +{- | The SQL @IN@ operator, like 'valueIn', but for when you want to construct a tuple in SQL and check if it is in a list of tuples. It is up to the caller to ensure that all the tuples given have the same arity. @@ -192,8 +201,7 @@ (rowValueConstructor needle) (inValueList (fmap rowValueConstructor haystack)) -{- | - The SQL @NOT IN@ operator, like 'valueNotIn', but for when you want to +{- | The SQL @NOT IN@ operator, like 'valueNotIn', but for when you want to construct a tuple in SQL and check if it is not in a list of tuples. It is up to the caller to ensure that all the tuples given have the same arity. @@ -205,8 +213,7 @@ (rowValueConstructor needle) (inValueList (fmap rowValueConstructor haystack)) -{- | - Lower-level access to the SQL @IN@ operator. This takes any 'ValueExpression' +{- | Lower-level access to the SQL @IN@ operator. This takes any 'ValueExpression' and 'InValuePredicate'. It is up to the caller to ensure the expressions given make sense together. @@ -219,8 +226,7 @@ <> RawSql.fromString " IN " <> RawSql.toRawSql predicate -{- | - Lower-level access to the SQL @NOT IN@ operator. This takes any +{- | Lower-level access to the SQL @NOT IN@ operator. This takes any 'ValueExpression' and 'InValuePredicate'. It is up to the caller to ensure the expressions given make sense together. @@ -233,8 +239,7 @@ <> RawSql.fromString " NOT IN " <> RawSql.toRawSql predicate -{- | -Type to represent the right hand side of an @IN@ or @NOT IN@ expression. +{- | Type to represent the right hand side of an @IN@ or @NOT IN@ expression. E.G. > (10,12,13) @@ -247,10 +252,12 @@ -} newtype InValuePredicate = InValuePredicate RawSql.RawSql - deriving (RawSql.SqlExpression) + deriving + ( -- | @since 1.0.0.0 + RawSql.SqlExpression + ) -{- | - Constructs an 'InValuePredicate' from the given list of 'ValueExpression'. +{- | Constructs an 'InValuePredicate' from the given list of 'ValueExpression'. @since 1.0.0.0 -} @@ -261,8 +268,7 @@ <> RawSql.intercalate RawSql.commaSpace values <> RawSql.rightParen -{- | - Surrounds the given 'BooleanExpr' with parentheses. +{- | Surrounds the given 'BooleanExpr' with parentheses. @since 1.0.0.0 -} @@ -271,8 +277,7 @@ BooleanExpr $ RawSql.leftParen <> RawSql.toRawSql expr <> RawSql.rightParen -{- | - The SQL @=@ operator. +{- | The SQL @=@ operator. @since 1.0.0.0 -} @@ -280,8 +285,7 @@ equals = binaryOpExpression equalsOp -{- | - The SQL @<>@ operator. +{- | The SQL @<>@ operator. @since 1.0.0.0 -} @@ -289,17 +293,31 @@ notEquals = binaryOpExpression notEqualsOp -{- | - The SQL @>@ operator. +{- | The SQL @IS DISTINCT FROM@ binary comparison. + @since 1.1.0.0 +-} +isDistinctFrom :: ValueExpression -> ValueExpression -> BooleanExpr +isDistinctFrom = + binaryOpExpression isDistinctFromOp + +{- | The SQL @IS NOT DISTINCT FROM@ binary comparison. + + @since 1.1.0.0 +-} +isNotDistinctFrom :: ValueExpression -> ValueExpression -> BooleanExpr +isNotDistinctFrom = + binaryOpExpression isNotDistinctFromOp + +{- | The SQL @>@ operator. + @since 1.0.0.0 -} greaterThan :: ValueExpression -> ValueExpression -> BooleanExpr greaterThan = binaryOpExpression greaterThanOp -{- | - The SQL @<@ operator. +{- | The SQL @<@ operator. @since 1.0.0.0 -} @@ -307,8 +325,7 @@ lessThan = binaryOpExpression lessThanOp -{- | - The SQL @>=@ operator. +{- | The SQL @>=@ operator. @since 1.0.0.0 -} @@ -316,8 +333,7 @@ greaterThanOrEqualTo = binaryOpExpression greaterThanOrEqualsOp -{- | - The SQL @<=@ operator. +{- | The SQL @<=@ operator. @since 1.0.0.0 -} @@ -325,8 +341,7 @@ lessThanOrEqualTo = binaryOpExpression lessThanOrEqualsOp -{- | - The SQL @LIKE@ operator. +{- | The SQL @LIKE@ operator. @since 1.0.0.0 -} @@ -334,8 +349,7 @@ like = binaryOpExpression likeOp -{- | - The SQL @ILIKE@ operator. +{- | The SQL @ILIKE@ operator. @since 1.0.0.0 -} @@ -343,8 +357,7 @@ likeInsensitive = binaryOpExpression iLikeOp -{- | - The SQL @IS NULL@ condition. +{- | The SQL @IS NULL@ condition. @since 1.0.0.0 -} @@ -355,8 +368,7 @@ <> RawSql.space <> RawSql.fromString "IS NULL" -{- | - The SQL @IS NOT NULL@ condition. +{- | The SQL @IS NOT NULL@ condition. @since 1.0.0.0 -} diff --git a/src/Orville/PostgreSQL/Expr/Window.hs b/src/Orville/PostgreSQL/Expr/Window.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/Window.hs @@ -0,0 +1,17 @@ +{-# OPTIONS_GHC -Wno-missing-import-lists #-} + +{- | +Copyright : Flipstone Technology Partners 2024 +License : MIT +Stability : Stable + +@since 1.1.0.0 +-} +module Orville.PostgreSQL.Expr.Window + ( module Export + ) +where + +import Orville.PostgreSQL.Expr.Window.WindowClause as Export +import Orville.PostgreSQL.Expr.Window.WindowDefinitionExpr as Export +import Orville.PostgreSQL.Expr.Window.WindowFunction as Export diff --git a/src/Orville/PostgreSQL/Expr/Window/WindowClause.hs b/src/Orville/PostgreSQL/Expr/Window/WindowClause.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/Window/WindowClause.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{- | +Copyright : Flipstone Technology Partners 2024 +License : MIT +Stability : Stable + +@since 1.1.0.0 +-} +module Orville.PostgreSQL.Expr.Window.WindowClause + ( WindowClause + , windowClause + , NamedWindowDefinitionExpr + , namedWindowDefinition + , appendNamedWindowDefinitionExpr + ) +where + +import Orville.PostgreSQL.Expr.Name (WindowName) +import Orville.PostgreSQL.Expr.Window.WindowDefinitionExpr (WindowDefinitionExpr) +import qualified Orville.PostgreSQL.Raw.RawSql as RawSql + +{- | Type to represent a named SQL window definition. This should only be used in a @WINDOW@ clause. + +'NamedWindowDefinitionExpr' provides a 'RawSql.SqlExpression' instance. +See 'RawSql.unsafeSqlExpression' for how to construct a value with your own custom SQL. + +@since 1.1.0.0 +-} +newtype NamedWindowDefinitionExpr = NamedWindowDefinitionExpr RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | +@since 1.1.0.0 +-} +instance Semigroup NamedWindowDefinitionExpr where + (<>) = appendNamedWindowDefinitionExpr + +{- | Combines two 'NamedWindowDefinitionExpr's with a comma between them. + +@since 1.1.0.0 +-} +appendNamedWindowDefinitionExpr :: NamedWindowDefinitionExpr -> NamedWindowDefinitionExpr -> NamedWindowDefinitionExpr +appendNamedWindowDefinitionExpr (NamedWindowDefinitionExpr a) (NamedWindowDefinitionExpr b) = + NamedWindowDefinitionExpr (a <> RawSql.commaSpace <> b) + +{- | Builds a 'NamedWindowDefinitionExpr' with the given name and 'WindowDefinitionExpr'. +1 +@since 1.1.0.0 +-} +namedWindowDefinition :: WindowName -> WindowDefinitionExpr -> NamedWindowDefinitionExpr +namedWindowDefinition windowName expr = + NamedWindowDefinitionExpr $ + RawSql.toRawSql windowName + <> RawSql.space + <> RawSql.fromString "AS" + <> RawSql.space + <> RawSql.parenthesized (RawSql.toRawSql expr) + +{- | Type to represent a SQL window clause. E.G. + +> WINDOW foo , bar + +'WindowClause' provides a 'RawSql.SqlExpression' instance. See +'RawSql.unsafeSqlExpression' for how to construct a value with your own custom +SQL. + +@since 1.1.0.0 +-} +newtype WindowClause + = WindowClause RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | Builds a full 'WindowClause' with the given windowing described in the 'NamedWindowDefinitionExpr' +1 +@since 1.1.0.0 +-} +windowClause :: NamedWindowDefinitionExpr -> WindowClause +windowClause namedWindowDefinitionExpr = + WindowClause $ + RawSql.fromString "WINDOW" + <> RawSql.space + <> RawSql.toRawSql namedWindowDefinitionExpr diff --git a/src/Orville/PostgreSQL/Expr/Window/WindowDefinitionExpr.hs b/src/Orville/PostgreSQL/Expr/Window/WindowDefinitionExpr.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/Window/WindowDefinitionExpr.hs @@ -0,0 +1,309 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{- | +Copyright : Flipstone Technology Partners 2024 +License : MIT +Stability : Stable + +@since 1.1.0.0 +-} +module Orville.PostgreSQL.Expr.Window.WindowDefinitionExpr + ( WindowDefinitionExpr + , windowDefinition + , PartitionByExpr + , partitionBy + , FrameClause + , frameClause + , FrameModeExpr + , rangeFrameMode + , rowsFrameMode + , groupsFrameMode + , FrameStartExpr + , unboundedPrecedingFrameStart + , offsetPrecedingFrameStart + , currentRowFrameStart + , offsetFollowingFrameStart + , FrameEndExpr + , offsetPrecedingFrameEnd + , currentRowFrameEnd + , offsetFollowingFrameEnd + , unboundedFollowingFrameEnd + , FrameExclusionExpr + , currentRowFrameExclusion + , groupFrameExclusion + , tiesFrameExclusion + , noOthersFrameExclusion + ) +where + +import qualified Data.List.NonEmpty as NEL +import Data.Maybe (catMaybes) + +import Orville.PostgreSQL.Expr.Name (WindowName) +import qualified Orville.PostgreSQL.Expr.OrderBy as OrderBy +import qualified Orville.PostgreSQL.Expr.ValueExpression as ValueExpression +import qualified Orville.PostgreSQL.Raw.RawSql as RawSql + +{- | Type to represent a SQL window definition. This can be used in either a @WINDOW@ clause or in the +portion of a window function call after the @OVER@. + +'WindowDefinitionExpr' provides a 'RawSql.SqlExpression' instance. +See 'RawSql.unsafeSqlExpression' for how to construct a value with your own custom SQL. + +@since 1.1.0.0 +-} +newtype WindowDefinitionExpr = WindowDefinitionExpr RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | Builds a 'WindowDefinitionExpr'. Note that it is up to the caller to ensure the options make + sense togther, including particular rules below. + +N.B. If the 'WindowName' is used (so we are "copying" a previous definition), then a few rules apply: + * The 'ParititionByExpr' and 'OrderByClause' will be copied if any + * If either 'ParitionByExpr' and 'OrderByClause' exist then a 'PartitionByExpr' may not be specified. + * The 'OrderByClause' can _only_ be specified if the window copied does not have one. + * The copied window must not specify a 'FrameClause'. + +@since 1.1.0.0 +-} +windowDefinition :: + -- | An, optional, already existing named window that must be named in a prior @WINDOW@ entry. + Maybe WindowName -> + Maybe PartitionByExpr -> + Maybe OrderBy.OrderByClause -> + Maybe FrameClause -> + WindowDefinitionExpr +windowDefinition mbWindowName mbPartitionBy mbOrderBy mbFrame = + WindowDefinitionExpr + . RawSql.intercalate RawSql.space + $ catMaybes + [ fmap RawSql.toRawSql mbWindowName + , fmap RawSql.toRawSql mbPartitionBy + , fmap RawSql.toRawSql mbOrderBy + , fmap RawSql.toRawSql mbFrame + ] + +{- | Type to represent the @PARTITION BY expression [, ...]@ portion of a SQL window definition. + +'PartitionByExpr' provides a 'RawSql.SqlExpression' instance. +See 'RawSql.unsafeSqlExpression' for how to construct a value with your own custom SQL. + +@since 1.1.0.0 +-} +newtype PartitionByExpr = PartitionByExpr RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | Builds a 'PartitionByExpr'. + +@since 1.1.0.0 +-} +partitionBy :: NEL.NonEmpty ValueExpression.ValueExpression -> PartitionByExpr +partitionBy exprs = + PartitionByExpr $ + RawSql.fromString "PARTITION BY " + <> RawSql.intercalate RawSql.commaSpace exprs + +{- | Type to represent the framing clause of a window definition. + +'FrameClause' provides a 'RawSql.SqlExpression' instance. +See 'RawSql.unsafeSqlExpression' for how to construct a value with your own custom SQL. + +@since 1.1.0.0 +-} +newtype FrameClause = FrameClause RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | Builds a 'FrameClause' from the given pieces. + +@since 1.1.0.0 +-} +frameClause :: Maybe FrameModeExpr -> FrameStartExpr -> Maybe FrameEndExpr -> Maybe FrameExclusionExpr -> FrameClause +frameClause mbFrameMode frameStart mbFrameEnd mbExclusion = + let + mode = + maybe mempty RawSql.toRawSql mbFrameMode + exclusion = + maybe mempty RawSql.toRawSql mbExclusion + in + FrameClause $ + mode + <> RawSql.space + <> case mbFrameEnd of + Nothing -> RawSql.toRawSql frameStart + Just frameEnd -> + RawSql.fromString "BETWEEN " + <> RawSql.toRawSql frameStart + <> RawSql.fromString " AND " + <> RawSql.toRawSql frameEnd + <> RawSql.space + <> exclusion + +{- | Type to represent the mode of the framing in a window definition. + +'FrameModeExpr' provides a 'RawSql.SqlExpression' instance. +See 'RawSql.unsafeSqlExpression' for how to construct a value with your own custom SQL. + +@since 1.1.0.0 +-} +newtype FrameModeExpr = FrameModeExpr RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | Value for the frame mode of @RANGE@ + +@since 1.1.0.0 +-} +rangeFrameMode :: FrameModeExpr +rangeFrameMode = FrameModeExpr $ RawSql.fromString "RANGE" + +{- | Value for the frame mode of @ROWS@ + +@since 1.1.0.0 +-} +rowsFrameMode :: FrameModeExpr +rowsFrameMode = FrameModeExpr $ RawSql.fromString "ROWS" + +{- | Value for the frame mode of @GROUPS@ + +@since 1.1.0.0 +-} +groupsFrameMode :: FrameModeExpr +groupsFrameMode = FrameModeExpr $ RawSql.fromString "GROUPS" + +{- | Type to represent the beginning of the framing in a window definition. + +'FrameStartExpr' provides a 'RawSql.SqlExpression' instance. +See 'RawSql.unsafeSqlExpression' for how to construct a value with your own custom SQL. + +@since 1.1.0.0 +-} +newtype FrameStartExpr = FrameStartExpr RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | Value for a frame start of @UNBOUNDED PRECEDING@ + +@since 1.1.0.0 +-} +unboundedPrecedingFrameStart :: FrameStartExpr +unboundedPrecedingFrameStart = FrameStartExpr $ RawSql.fromString "UNBOUNDED PRECEDING" + +{- | Value for a frame start of @expression PRECEDING@. Note that it is up to the caller to ensure + that the 'ValueExpression' is valid in this context. + +@since 1.1.0.0 +-} +offsetPrecedingFrameStart :: ValueExpression.ValueExpression -> FrameStartExpr +offsetPrecedingFrameStart val = FrameStartExpr $ RawSql.toRawSql val <> RawSql.fromString " PRECEDING" + +{- | Value for a frame start of @CURRENT ROW@ + +@since 1.1.0.0 +-} +currentRowFrameStart :: FrameStartExpr +currentRowFrameStart = FrameStartExpr $ RawSql.fromString "CURRENT ROW" + +{- | Value for a frame start of @expression FOLLOWING@. Note that it is up to the caller to ensure + that the 'ValueExpression' is valid in this context. + +@since 1.1.0.0 +-} +offsetFollowingFrameStart :: ValueExpression.ValueExpression -> FrameStartExpr +offsetFollowingFrameStart val = FrameStartExpr $ RawSql.toRawSql val <> RawSql.fromString " FOLLOWING" + +{- | Type to represent the ending of the framing in a window definition. + +'FrameEndExpr' provides a 'RawSql.SqlExpression' instance. +See 'RawSql.unsafeSqlExpression' for how to construct a value with your own custom SQL. + +@since 1.1.0.0 +-} +newtype FrameEndExpr = FrameEndExpr RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | Value for a frame end of @expression PRECEDING@. Note that it is up to the caller to ensure + that the 'ValueExpression' is valid in this context. + +@since 1.1.0.0 +-} +offsetPrecedingFrameEnd :: ValueExpression.ValueExpression -> FrameEndExpr +offsetPrecedingFrameEnd val = FrameEndExpr $ RawSql.toRawSql val <> RawSql.fromString " PRECEDING" + +{- | Value for a frame end of @CURRENT ROW@ + +@since 1.1.0.0 +-} +currentRowFrameEnd :: FrameEndExpr +currentRowFrameEnd = FrameEndExpr $ RawSql.fromString "CURRENT ROW" + +{- | Value for a frame end of @expression FOLLOWING@. Note that it is up to the caller to ensure + that the 'ValueExpression' is valid in this context. + +@since 1.1.0.0 +-} +offsetFollowingFrameEnd :: ValueExpression.ValueExpression -> FrameEndExpr +offsetFollowingFrameEnd val = FrameEndExpr $ RawSql.toRawSql val <> RawSql.fromString " FOLLOWING" + +{- | Value for a frame end of @UNBOUNDED FOLLOWING@ + +@since 1.1.0.0 +-} +unboundedFollowingFrameEnd :: FrameEndExpr +unboundedFollowingFrameEnd = FrameEndExpr $ RawSql.fromString "UNBOUNDED FOLLOWING" + +{- | Type to represent the exclusion of results in the framing in a window definition. + +'FrameExclusionExpr' provides a 'RawSql.SqlExpression' instance. +See 'RawSql.unsafeSqlExpression' for how to construct a value with your own custom SQL. + +@since 1.1.0.0 +-} +newtype FrameExclusionExpr = FrameExclusionExpr RawSql.RawSql + deriving + ( -- | @since 1.1.0.0 + RawSql.SqlExpression + ) + +{- | Value for a frame exclusion of @EXCLUDE CURRENT ROW@ + +@since 1.1.0.0 +-} +currentRowFrameExclusion :: FrameExclusionExpr +currentRowFrameExclusion = FrameExclusionExpr $ RawSql.fromString "EXCLUDE CURRENT ROW" + +{- | Value for a frame exclusion of @EXCLUDE GROUP@ + +@since 1.1.0.0 +-} +groupFrameExclusion :: FrameExclusionExpr +groupFrameExclusion = FrameExclusionExpr $ RawSql.fromString "EXCLUDE GROUP" + +{- | Value for a frame exclusion of @EXCLUDE TIES@ + +@since 1.1.0.0 +-} +tiesFrameExclusion :: FrameExclusionExpr +tiesFrameExclusion = FrameExclusionExpr $ RawSql.fromString "EXCLUDE TIES" + +{- | Value for a frame exclusion of @EXCLUDE NO OTHERS@ + +@since 1.1.0.0 +-} +noOthersFrameExclusion :: FrameExclusionExpr +noOthersFrameExclusion = FrameExclusionExpr $ RawSql.fromString "EXCLUDE NO OTHERS" diff --git a/src/Orville/PostgreSQL/Expr/Window/WindowFunction.hs b/src/Orville/PostgreSQL/Expr/Window/WindowFunction.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/Window/WindowFunction.hs @@ -0,0 +1,306 @@ +{- | +Copyright : Flipstone Technology Partners 2024 +License : MIT +Stability : Stable + +@since 1.1.0.0 +-} +module Orville.PostgreSQL.Expr.Window.WindowFunction + ( windowFunction + , rowNumberWindowFunction + , rankWindowFunction + , denseRankWindowFunction + , percentRankWindowFunction + , arrayAggWindowFunction + , avgWindowFunction + , bitAndWindowFunction + , bitOrWindowFunction + , bitXorWindowFunction + , boolAndWindowFunction + , boolOrWindowFunction + , countWindowFunction + , everyWindowFunction + , jsonAggWindowFunction + , jsonObjectAggWindowFunction + , jsonbAggWindowFunction + , jsonbObjectAggWindowFunction + , maxWindowFunction + , minWindowFunction + , stringAggWindowFunction + , sumWindowFunction + , corWindowFunction + , covarPopWindowFunction + , covarSampWindowFunction + , stddevPopWindowFunction + , stddevSampWindowFunction + , varPopWindowFunction + , varSampWindowFunction + ) +where + +import qualified Orville.PostgreSQL.Expr.Filter as Filter +import Orville.PostgreSQL.Expr.Name (FunctionName, functionName) +import qualified Orville.PostgreSQL.Expr.Name as Name +import qualified Orville.PostgreSQL.Expr.ValueExpression as ValueExpression +import Orville.PostgreSQL.Expr.Window.WindowDefinitionExpr (WindowDefinitionExpr) +import qualified Orville.PostgreSQL.Raw.RawSql as RawSql + +{- | The @row_number@ window function + +@since 1.1.0.0 +-} +rowNumberWindowFunction :: Maybe Filter.FilterExpr -> WindowDefinitionExpr -> ValueExpression.ValueExpression +rowNumberWindowFunction = windowFunction (functionName "row_number") mempty + +{- | The @rank@ window function + +@since 1.1.0.0 +-} +rankWindowFunction :: Maybe Filter.FilterExpr -> WindowDefinitionExpr -> ValueExpression.ValueExpression +rankWindowFunction = windowFunction (functionName "rank") mempty + +{- | The @dense_rank@ window function + +@since 1.1.0.0 +-} +denseRankWindowFunction :: Maybe Filter.FilterExpr -> WindowDefinitionExpr -> ValueExpression.ValueExpression +denseRankWindowFunction = windowFunction (functionName "dense_rank") mempty + +{- | The @percent_rank@ window function + +@since 1.1.0.0 +-} +percentRankWindowFunction :: Maybe Filter.FilterExpr -> WindowDefinitionExpr -> ValueExpression.ValueExpression +percentRankWindowFunction = windowFunction (functionName "percent_rank") mempty + +{- | Build a 'ValueExpression' that represents a window function call. It is up to the caller to +ensure this makes sense as windowing functions are not allowed in all places. + +@since 1.1.0.0 +-} +windowFunction :: + FunctionName -> + [ValueExpression.ValueExpression] -> + Maybe Filter.FilterExpr -> + WindowDefinitionExpr -> + ValueExpression.ValueExpression +windowFunction function parameters mbFilter windowDef = + let + filtering = + case mbFilter of + Nothing -> mempty + Just filterExpr -> RawSql.space <> RawSql.toRawSql filterExpr + in + RawSql.unsafeFromRawSql $ + RawSql.toRawSql (ValueExpression.functionCall function parameters) + <> filtering + <> RawSql.space + <> RawSql.fromString "OVER" + <> RawSql.parenthesized (RawSql.toRawSql windowDef) + +{- | The SQL @array_agg@ window function. + +@since 1.1.0.0 +-} +arrayAggWindowFunction :: + ValueExpression.ValueExpression -> Maybe Filter.FilterExpr -> WindowDefinitionExpr -> ValueExpression.ValueExpression +arrayAggWindowFunction = singleParameterWindowFunction Name.arrayAggFunctionName + +{- | The SQL @avg@ window function. + +@since 1.1.0.0 +-} +avgWindowFunction :: + ValueExpression.ValueExpression -> Maybe Filter.FilterExpr -> WindowDefinitionExpr -> ValueExpression.ValueExpression +avgWindowFunction = singleParameterWindowFunction Name.avgFunctionName + +{- | The SQL @bit_and@ window function. + +@since 1.1.0.0 +-} +bitAndWindowFunction :: + ValueExpression.ValueExpression -> Maybe Filter.FilterExpr -> WindowDefinitionExpr -> ValueExpression.ValueExpression +bitAndWindowFunction = singleParameterWindowFunction Name.bitAndFunctionName + +{- | The SQL @bit_or@ window function. + +@since 1.1.0.0 +-} +bitOrWindowFunction :: + ValueExpression.ValueExpression -> Maybe Filter.FilterExpr -> WindowDefinitionExpr -> ValueExpression.ValueExpression +bitOrWindowFunction = singleParameterWindowFunction Name.bitOrFunctionName + +{- | The SQL @bit_xor@ window function. + +@since 1.1.0.0 +-} +bitXorWindowFunction :: + ValueExpression.ValueExpression -> Maybe Filter.FilterExpr -> WindowDefinitionExpr -> ValueExpression.ValueExpression +bitXorWindowFunction = singleParameterWindowFunction Name.bitXorFunctionName + +{- | The SQL @bool_and@ window function. + +@since 1.1.0.0 +-} +boolAndWindowFunction :: + ValueExpression.ValueExpression -> Maybe Filter.FilterExpr -> WindowDefinitionExpr -> ValueExpression.ValueExpression +boolAndWindowFunction = singleParameterWindowFunction Name.boolAndFunctionName + +{- | The SQL @bool_or@ window function. + +@since 1.1.0.0 +-} +boolOrWindowFunction :: + ValueExpression.ValueExpression -> Maybe Filter.FilterExpr -> WindowDefinitionExpr -> ValueExpression.ValueExpression +boolOrWindowFunction = singleParameterWindowFunction Name.boolOrFunctionName + +{- | The SQL @count@ window function. + +@since 1.1.0.0 +-} +countWindowFunction :: + ValueExpression.ValueExpression -> Maybe Filter.FilterExpr -> WindowDefinitionExpr -> ValueExpression.ValueExpression +countWindowFunction = singleParameterWindowFunction Name.countFunctionName + +{- | The SQL @every@ window function. + +@since 1.1.0.0 +-} +everyWindowFunction :: + ValueExpression.ValueExpression -> Maybe Filter.FilterExpr -> WindowDefinitionExpr -> ValueExpression.ValueExpression +everyWindowFunction = singleParameterWindowFunction Name.everyFunctionName + +{- | The SQL @json_agg@ window function. + +@since 1.1.0.0 +-} +jsonAggWindowFunction :: + ValueExpression.ValueExpression -> Maybe Filter.FilterExpr -> WindowDefinitionExpr -> ValueExpression.ValueExpression +jsonAggWindowFunction = singleParameterWindowFunction Name.jsonAggFunctionName + +{- | The SQL @json_object_agg@ window function. + +@since 1.1.0.0 +-} +jsonObjectAggWindowFunction :: + ValueExpression.ValueExpression -> ValueExpression.ValueExpression -> Maybe Filter.FilterExpr -> WindowDefinitionExpr -> ValueExpression.ValueExpression +jsonObjectAggWindowFunction param1 param2 = + windowFunction Name.jsonObjectAggFunctionName [param1, param2] + +{- | The SQL @jsonb_agg@ window function. + +@since 1.1.0.0 +-} +jsonbAggWindowFunction :: + ValueExpression.ValueExpression -> Maybe Filter.FilterExpr -> WindowDefinitionExpr -> ValueExpression.ValueExpression +jsonbAggWindowFunction = singleParameterWindowFunction Name.jsonbAggFunctionName + +{- | The SQL @jsonb_object_agg@ window function. + +@since 1.1.0.0 +-} +jsonbObjectAggWindowFunction :: + ValueExpression.ValueExpression -> ValueExpression.ValueExpression -> Maybe Filter.FilterExpr -> WindowDefinitionExpr -> ValueExpression.ValueExpression +jsonbObjectAggWindowFunction param1 param2 = + windowFunction Name.jsonbObjectAggFunctionName [param1, param2] + +{- | The SQL @max@ window function. + +@since 1.1.0.0 +-} +maxWindowFunction :: + ValueExpression.ValueExpression -> Maybe Filter.FilterExpr -> WindowDefinitionExpr -> ValueExpression.ValueExpression +maxWindowFunction = singleParameterWindowFunction Name.maxFunctionName + +{- | The SQL @min@ window function. + +@since 1.1.0.0 +-} +minWindowFunction :: + ValueExpression.ValueExpression -> Maybe Filter.FilterExpr -> WindowDefinitionExpr -> ValueExpression.ValueExpression +minWindowFunction = singleParameterWindowFunction Name.minFunctionName + +{- | The SQL @string_agg@ window function. + +@since 1.1.0.0 +-} +stringAggWindowFunction :: + ValueExpression.ValueExpression -> ValueExpression.ValueExpression -> Maybe Filter.FilterExpr -> WindowDefinitionExpr -> ValueExpression.ValueExpression +stringAggWindowFunction param1 param2 = + windowFunction Name.stringAggFunctionName [param1, param2] + +{- | The SQL @sum@ window function. + +@since 1.1.0.0 +-} +sumWindowFunction :: + ValueExpression.ValueExpression -> Maybe Filter.FilterExpr -> WindowDefinitionExpr -> ValueExpression.ValueExpression +sumWindowFunction = singleParameterWindowFunction Name.sumFunctionName + +{- | The SQL @cor@ window function. + +@since 1.1.0.0 +-} +corWindowFunction :: + ValueExpression.ValueExpression -> ValueExpression.ValueExpression -> Maybe Filter.FilterExpr -> WindowDefinitionExpr -> ValueExpression.ValueExpression +corWindowFunction param1 param2 = + windowFunction Name.corFunctionName [param1, param2] + +{- | The SQL @covar_pop@ window function. + +@since 1.1.0.0 +-} +covarPopWindowFunction :: + ValueExpression.ValueExpression -> ValueExpression.ValueExpression -> Maybe Filter.FilterExpr -> WindowDefinitionExpr -> ValueExpression.ValueExpression +covarPopWindowFunction param1 param2 = + windowFunction Name.covarPopFunctionName [param1, param2] + +{- | The SQL @covar_samp@ window function. + +@since 1.1.0.0 +-} +covarSampWindowFunction :: + ValueExpression.ValueExpression -> ValueExpression.ValueExpression -> Maybe Filter.FilterExpr -> WindowDefinitionExpr -> ValueExpression.ValueExpression +covarSampWindowFunction param1 param2 = + windowFunction Name.covarSampFunctionName [param1, param2] + +{- | The SQL @stddev_pop@ window function. + +@since 1.1.0.0 +-} +stddevPopWindowFunction :: + ValueExpression.ValueExpression -> ValueExpression.ValueExpression -> Maybe Filter.FilterExpr -> WindowDefinitionExpr -> ValueExpression.ValueExpression +stddevPopWindowFunction param1 param2 = + windowFunction Name.stddevPopFunctionName [param1, param2] + +{- | The SQL @stddev_samp@ window function. + +@since 1.1.0.0 +-} +stddevSampWindowFunction :: + ValueExpression.ValueExpression -> ValueExpression.ValueExpression -> Maybe Filter.FilterExpr -> WindowDefinitionExpr -> ValueExpression.ValueExpression +stddevSampWindowFunction param1 param2 = + windowFunction Name.stddevSampFunctionName [param1, param2] + +{- | The SQL @var_pop@ window function. + +@since 1.1.0.0 +-} +varPopWindowFunction :: + ValueExpression.ValueExpression -> ValueExpression.ValueExpression -> Maybe Filter.FilterExpr -> WindowDefinitionExpr -> ValueExpression.ValueExpression +varPopWindowFunction param1 param2 = + windowFunction Name.varPopFunctionName [param1, param2] + +{- | The SQL @var_samp@ window function. + +@since 1.1.0.0 +-} +varSampWindowFunction :: + ValueExpression.ValueExpression -> ValueExpression.ValueExpression -> Maybe Filter.FilterExpr -> WindowDefinitionExpr -> ValueExpression.ValueExpression +varSampWindowFunction param1 param2 = + windowFunction Name.varSampFunctionName [param1, param2] + +singleParameterWindowFunction :: + FunctionName -> ValueExpression.ValueExpression -> Maybe Filter.FilterExpr -> WindowDefinitionExpr -> ValueExpression.ValueExpression +singleParameterWindowFunction function parameter = + windowFunction function (pure parameter) diff --git a/src/Orville/PostgreSQL/Extension/PgTrgm.hs b/src/Orville/PostgreSQL/Extension/PgTrgm.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Extension/PgTrgm.hs @@ -0,0 +1,182 @@ +{- | +Copyright : Flipstone Technology Partners 2024 +License : MIT +Stability : Stable + +Functionality for loading and using the +[pg_trgm](https://www.postgresql.org/docs/current/pgtrgm.html) extension. While this extension is +supplied by default with PostgreSQL, it is entirely up to users to ensure access to the extension. + +@since 1.1.0.0 +-} +module Orville.PostgreSQL.Extension.PgTrgm + ( trigramSimilaritySyntheticField + , trigramWordSimilaritySyntheticField + , trigramStrictWordSimilaritySyntheticField + , mkNamedTrigramGinIndexDefinition + , mkNamedTrigramGistIndexDefinition + , trigramSimilarity + , trigramWordSimilarity + , trigramStrictWordSimilarity + ) where + +import qualified Data.List.NonEmpty as NEL + +import qualified Orville.PostgreSQL.Expr as Expr +import qualified Orville.PostgreSQL.Internal.IndexDefinition as IndexDefinition +import qualified Orville.PostgreSQL.Marshall as Marshall +import qualified Orville.PostgreSQL.Raw.RawSql as RawSql + +{- | Create a named GIN index over the given fields for fast text searching. + +@since 1.1.0.0 +-} +mkNamedTrigramGinIndexDefinition :: + -- | The name of the index to be created. + String -> + -- | Field names to create the index over. + NEL.NonEmpty Marshall.FieldName -> + IndexDefinition.IndexDefinition +mkNamedTrigramGinIndexDefinition name = + IndexDefinition.mkNamedIndexDefinition Expr.NonUniqueIndex name . RawSql.unsafeFromRawSql . trigramGinIndexFieldsExpr + +trigramGinIndexFieldsExpr :: NEL.NonEmpty Marshall.FieldName -> RawSql.RawSql +trigramGinIndexFieldsExpr fields = + let + fieldExpr :: Marshall.FieldName -> RawSql.RawSql + fieldExpr name = + RawSql.toRawSql (Marshall.fieldNameToColumnName name) + <> RawSql.space + <> RawSql.fromString "gin_trgm_ops" + in + RawSql.fromString "USING GIN " + <> RawSql.parenthesized (RawSql.intercalate RawSql.commaSpace (fmap fieldExpr fields)) + +{- | Create a named GIST index for fast text searching. The index is created, over the fields each of + with an optional override of the index parameter "siglen". See [pg_trgm index + docs](https://www.postgresql.org/docs/current/pgtrgm.html#PGTRGM-INDEX) for more information. + +@since 1.1.0.0 +-} +mkNamedTrigramGistIndexDefinition :: + -- | The name of the index to be created. + String -> + -- | Pairs of field name and optionally a value of the siglen parameter, to create the index over. + NEL.NonEmpty (Marshall.FieldName, Maybe Int) -> + IndexDefinition.IndexDefinition +mkNamedTrigramGistIndexDefinition name = + IndexDefinition.mkNamedIndexDefinition Expr.NonUniqueIndex name . RawSql.unsafeFromRawSql . trigramGistIndexFieldsExpr + +trigramGistIndexFieldsExpr :: + NEL.NonEmpty (Marshall.FieldName, Maybe Int) -> + RawSql.RawSql +trigramGistIndexFieldsExpr fields = + let + fieldExpr :: (Marshall.FieldName, Maybe Int) -> RawSql.RawSql + fieldExpr (name, mbSiglen) = + RawSql.toRawSql (Marshall.fieldNameToColumnName name) + <> RawSql.space + <> RawSql.fromString "gist_trgm_ops" + <> maybe + mempty + (\len -> RawSql.parenthesized (RawSql.fromString "siglen=" <> RawSql.intDecLiteral len)) + mbSiglen + in + RawSql.fromString "USING GIST " + <> RawSql.parenthesized (RawSql.intercalate RawSql.commaSpace (fmap fieldExpr fields)) + +{- | Create a synthetic field using the similarity function provided by pg_trgm. + +@since 1.1.0.0 +-} +trigramSimilaritySyntheticField :: + -- | The column to be used in the similarity comparison + Expr.ColumnName -> + -- | The value to be compared against. + Expr.ValueExpression -> + -- | The alias to be used to name the similarity result. + String -> + -- | A field with the resulting similarity score between the column value and the comparison. + Marshall.SyntheticField Double +trigramSimilaritySyntheticField colname compareVal fieldAlias = + Marshall.syntheticField + (trigramSimilarity (Expr.columnReference $ Expr.unqualified colname) compareVal) + fieldAlias + Marshall.double + +{- | Create a synthetic field using the word_similarity function provided by pg_trgm. + +@since 1.1.0.0 +-} +trigramWordSimilaritySyntheticField :: + -- | The column to be used in the word_similarity comparison + Expr.ColumnName -> + -- | The value to be compared against. + Expr.ValueExpression -> + -- | The alias to be used to name the word_similarity result. + String -> + -- | A field with the resulting word_similarity score between the column value and the comparison. + Marshall.SyntheticField Double +trigramWordSimilaritySyntheticField colname compareVal fieldAlias = + Marshall.syntheticField + (trigramWordSimilarity (Expr.columnReference $ Expr.unqualified colname) compareVal) + fieldAlias + Marshall.double + +{- | Create a synthetic field using the strict_word_similarity function provided by pg_trgm. + +@since 1.1.0.0 +-} +trigramStrictWordSimilaritySyntheticField :: + -- | The column to be used in the strict_word_similarity comparison + Expr.ColumnName -> + -- | The value to be compared against. + Expr.ValueExpression -> + -- | The alias to be used to name the strict_word_similarity result. + String -> + -- | A field with the resulting strict_word_similarity score between the column value and the comparison. + Marshall.SyntheticField Double +trigramStrictWordSimilaritySyntheticField colname compareVal fieldAlias = + Marshall.syntheticField + (trigramStrictWordSimilarity (Expr.columnReference $ Expr.unqualified colname) compareVal) + fieldAlias + Marshall.double + +{- | Call the similarity function provided by pg_trgm, comparing the pair of values. + +@since 1.1.0.0 +-} +trigramSimilarity :: + Expr.ValueExpression -> + Expr.ValueExpression -> + Expr.ValueExpression +trigramSimilarity firstVal secondVal = + Expr.functionCall + (Expr.functionName "similarity") + [firstVal, secondVal] + +{- | Call the word_similarity function provided by pg_trgm, comparing the pair of values. + +@since 1.1.0.0 +-} +trigramWordSimilarity :: + Expr.ValueExpression -> + Expr.ValueExpression -> + Expr.ValueExpression +trigramWordSimilarity firstVal secondVal = + Expr.functionCall + (Expr.functionName "word_similarity") + [firstVal, secondVal] + +{- | Call the strict_word_similarity function provided by pg_trgm, comparing the pair of values. + +@since 1.1.0.0 +-} +trigramStrictWordSimilarity :: + Expr.ValueExpression -> + Expr.ValueExpression -> + Expr.ValueExpression +trigramStrictWordSimilarity firstVal secondVal = + Expr.functionCall + (Expr.functionName "strict_word_similarity") + [firstVal, secondVal] diff --git a/src/Orville/PostgreSQL/Internal/Bracket.hs b/src/Orville/PostgreSQL/Internal/Bracket.hs --- a/src/Orville/PostgreSQL/Internal/Bracket.hs +++ b/src/Orville/PostgreSQL/Internal/Bracket.hs @@ -1,5 +1,5 @@ {- | -Copyright : Flipstone Technology Partners 2023 +Copyright : Flipstone Technology Partners 2023-2025 License : MIT Stability : Stable @@ -11,16 +11,20 @@ ) where import Control.Exception (SomeException, catch, mask, throwIO) +import Control.Monad (void) import Control.Monad.IO.Class (MonadIO (liftIO)) import Orville.PostgreSQL.Monad.MonadOrville (MonadOrvilleControl (liftCatch, liftMask)) -data BracketResult - = BracketSuccess +{- | Track the result of a bracket + +@since 1.0.0.0 +-} +data BracketResult a + = BracketSuccess a | BracketError -{- | - INTERNAL: A version of 'Control.Exception.bracket' that allows us to distinguish between +{- | INTERNAL: A version of 'Control.Exception.bracket' that allows us to distinguish between exception and non-exception release cases. This is available in certain packages as a typeclass function under the name "generalBracket", but is implemented here directly in terms of IO's 'mask' and 'catch' to guarantee @@ -32,35 +36,33 @@ bracketWithResult :: (MonadIO m, MonadOrvilleControl m) => m a -> - (a -> BracketResult -> m c) -> + (a -> BracketResult b -> m c) -> (a -> m b) -> m b bracketWithResult acquire release action = do liftMask mask $ \restore -> do resource <- acquire - result <- liftCatch catch (restore (action resource)) (handleAndRethrow (release resource BracketError)) - _ <- release resource BracketSuccess + _ <- release resource (BracketSuccess result) pure result -{- | - INTERNAL: Catch any exception, run the given handler, and rethrow the +{- | INTERNAL: Catch any exception, run the given handler, and rethrow the exception. This is mostly useful to force the exception being caught to be of the type 'SomeException'. @since 1.0.0.0 -} handleAndRethrow :: - MonadIO m => + (MonadIO m, MonadOrvilleControl m) => m a -> SomeException -> m b handleAndRethrow handle ex = do - _ <- handle + liftCatch catch (void handle) (\e -> case e :: SomeException of _ -> pure ()) liftIO . throwIO $ ex diff --git a/src/Orville/PostgreSQL/Internal/Extra/NonEmpty.hs b/src/Orville/PostgreSQL/Internal/Extra/NonEmpty.hs --- a/src/Orville/PostgreSQL/Internal/Extra/NonEmpty.hs +++ b/src/Orville/PostgreSQL/Internal/Extra/NonEmpty.hs @@ -7,12 +7,25 @@ -} module Orville.PostgreSQL.Internal.Extra.NonEmpty ( foldl1' + , foldMap1' ) where import qualified Data.Foldable as Fold import Data.List.NonEmpty (NonEmpty ((:|))) +{- | A variant of foldl' that safely does not need a base case. + +@since 1.0.0.0 +-} foldl1' :: (a -> a -> a) -> NonEmpty a -> a foldl1' f (first :| rest) = Fold.foldl' f first rest + +{- | A variant of foldMap' that safely does not need a base case. + +@since 1.0.0.0 +-} +foldMap1' :: Semigroup m => (a -> m) -> NonEmpty a -> m +foldMap1' f (first :| rest) = + Fold.foldl' (\m a -> m <> f a) (f first) rest diff --git a/src/Orville/PostgreSQL/Internal/FieldName.hs b/src/Orville/PostgreSQL/Internal/FieldName.hs --- a/src/Orville/PostgreSQL/Internal/FieldName.hs +++ b/src/Orville/PostgreSQL/Internal/FieldName.hs @@ -18,27 +18,31 @@ import qualified Orville.PostgreSQL.Expr as Expr -{- | - A simple type to represent the name of a field. +{- | A simple type to represent the name of a field. @since 1.0.0.0 -} newtype FieldName = FieldName B8.ByteString - deriving (Eq, Ord, Show) + deriving + ( -- | @since 1.0.0.0 + Eq + , -- | @since 1.0.0.0 + Ord + , -- | @since 1.0.0.0 + Show + ) -{- | - Convert a field name to a 'Expr.ColumnName' for usage in SQL expressions. +{- | Convert a field name to a 'Expr.ColumnName' for usage in SQL expressions. The field name will be properly quoted and escaped. @since 1.0.0.0 -} fieldNameToColumnName :: FieldName -> Expr.ColumnName -fieldNameToColumnName (FieldName name) = - Expr.fromIdentifier (Expr.identifierFromBytes name) +fieldNameToColumnName = + Expr.fromIdentifier . Expr.identifierFromBytes . fieldNameToByteString -{- | - Constructs a 'FieldName' from a 'String'. +{- | Constructs a 'FieldName' from a 'String'. @since 1.0.0.0 -} @@ -46,8 +50,7 @@ stringToFieldName = FieldName . B8.pack -{- | - Converts a 'FieldName' back to a 'String'. +{- | Converts a 'FieldName' back to a 'String'. @since 1.0.0.0 -} @@ -55,8 +58,7 @@ fieldNameToString = B8.unpack . fieldNameToByteString -{- | - Converts a 'FieldName' back to a 'B8.ByteString'. +{- | Converts a 'FieldName' back to a 'B8.ByteString'. @since 1.0.0.0 -} @@ -64,8 +66,7 @@ fieldNameToByteString (FieldName name) = name -{- | - Constructs a 'FieldName' from a 'B8.ByteString'. +{- | Constructs a 'FieldName' from a 'B8.ByteString'. @since 1.0.0.0 -} diff --git a/src/Orville/PostgreSQL/Internal/IndexDefinition.hs b/src/Orville/PostgreSQL/Internal/IndexDefinition.hs --- a/src/Orville/PostgreSQL/Internal/IndexDefinition.hs +++ b/src/Orville/PostgreSQL/Internal/IndexDefinition.hs @@ -30,8 +30,7 @@ import qualified Orville.PostgreSQL.Expr as Expr import qualified Orville.PostgreSQL.Marshall.FieldDefinition as FieldDefinition -{- | - Defines an index that can be added to a 'Orville.PostgreSQL.TableDefinition'. +{- | Defines an index that can be added to a 'Orville.PostgreSQL.TableDefinition'. Use one of the constructor functions below (such as 'uniqueIndex') to construct the index definition you wish to have and then use 'Orville.PostgreSQL.addTableIndexes' to add them to your table definition. @@ -42,14 +41,13 @@ data IndexDefinition = IndexDefinition { i_indexCreateExpr :: IndexCreationStrategy -> - Expr.Qualified Expr.TableName -> + Expr.QualifiedOrUnqualified Expr.TableName -> Expr.CreateIndexExpr , i_indexMigrationKey :: IndexMigrationKey , i_indexCreationStrategy :: IndexCreationStrategy } -{- | - Sets the 'IndexCreationStrategy' to be used when creating the index described +{- | Sets the 'IndexCreationStrategy' to be used when creating the index described by the 'IndexDefinition'. By default, all indexes are created using the 'Transactional' strategy, but some tables are too large for this to be feasible. See the 'Concurrent' creation strategy for how to work around this. @@ -65,8 +63,7 @@ { i_indexCreationStrategy = strategy } -{- | - Gets the 'IndexCreationStrategy' to be used when creating the index described +{- | Gets the 'IndexCreationStrategy' to be used when creating the index described by the 'IndexDefinition'. By default, all indexes are created using the 'Transactional' strategy. @@ -78,22 +75,19 @@ indexCreationStrategy = i_indexCreationStrategy -{- | - Defines how an 'IndexDefinition' will be executed to add an index to a table. +{- | Defines how an 'IndexDefinition' will be executed to add an index to a table. By default, all indexes are created using the 'Transactional' strategy. @since 1.0.0.0 -} data IndexCreationStrategy - = -- | - -- The default strategy. The index will be added as part of a + = -- | The default strategy. The index will be added as part of a -- database transaction along with all the other DDL being executed -- to migrate the database schema. If any migration should fail, the -- index creation will be rolled back as part of the transaction. -- This is how schema migrations work in general in Orville. Transactional - | -- | - -- Creates the index using the @CONCURRENTLY@ keyword in PostgreSQL. + | -- | Creates the index using the @CONCURRENTLY@ keyword in PostgreSQL. -- Index creation will not lock the table during creation, allowing -- the application to access the table normally while the index is -- created. Concurrent index creation cannot be done in a @@ -112,10 +106,14 @@ -- indexes concurrently before you use this strategy. See -- https://www.postgresql.org/docs/current/sql-createindex.html#SQL-CREATEINDEX-CONCURRENTLY. Concurrent - deriving (Eq, Show) + deriving + ( -- | @since 1.0.0.0 + Eq + , -- | @since 1.0.0.0 + Show + ) -{- | - Orville uses 'IndexMigrationKey' values while performing auto migrations to +{- | Orville uses 'IndexMigrationKey' values while performing auto migrations to determine whether an index needs to be added or dropped. For most use cases the constructor functions that build an 'IndexDefinition' will create this automatically for you. @@ -125,10 +123,14 @@ data IndexMigrationKey = AttributeBasedIndexKey AttributeBasedIndexMigrationKey | NamedIndexKey NamedIndexMigrationKey - deriving (Eq, Ord) + deriving + ( -- | @since 1.0.0.0 + Eq + , -- | @since 1.0.0.0 + Ord + ) -{- | - An 'IndexMigrationKey' using 'AttributeBasedIndexMigrationKey' will cause +{- | An 'IndexMigrationKey' using 'AttributeBasedIndexMigrationKey' will cause Orville to compare the structure of the indexes found in the database to the index structure it wants to create. If no matching index is found it will create a new index. @@ -139,10 +141,16 @@ { indexKeyUniqueness :: Expr.IndexUniqueness , indexKeyColumns :: [FieldDefinition.FieldName] } - deriving (Eq, Ord, Show) + deriving + ( -- | @since 1.0.0.0 + Eq + , -- | @since 1.0.0.0 + Ord + , -- | @since 1.0.0.0 + Show + ) -{- | - An 'IndexMigrationKey' using 'NamedIndexMigrationKey' will cause Orville to +{- | An 'IndexMigrationKey' using 'NamedIndexMigrationKey' will cause Orville to compare the only the names of indexes found in the database when determine whether to create the index. If an index with a matching name is found no index will be created. If no matching index name is found a new index will be @@ -154,28 +162,25 @@ -} type NamedIndexMigrationKey = String -{- | - Gets the 'IndexMigrationKey' for the 'IndexDefinition' +{- | Gets the 'IndexMigrationKey' for the 'IndexDefinition' @since 1.0.0.0 -} indexMigrationKey :: IndexDefinition -> IndexMigrationKey indexMigrationKey = i_indexMigrationKey -{- | - Gets the SQL expression that will be used to add the index to the specified +{- | Gets the SQL expression that will be used to add the index to the specified table. @since 1.0.0.0 -} -indexCreateExpr :: IndexDefinition -> Expr.Qualified Expr.TableName -> Expr.CreateIndexExpr +indexCreateExpr :: IndexDefinition -> Expr.QualifiedOrUnqualified Expr.TableName -> Expr.CreateIndexExpr indexCreateExpr indexDef = i_indexCreateExpr indexDef (i_indexCreationStrategy indexDef) -{- | - Constructs an 'IndexDefinition' for a non-unique index on the given columns. +{- | Constructs an 'IndexDefinition' for a non-unique index on the given columns. @since 1.0.0.0 -} @@ -183,8 +188,7 @@ nonUniqueIndex = mkIndexDefinition Expr.NonUniqueIndex -{- | - Constructs an 'IndexDefinition' for a non-unique index with given SQL and +{- | Constructs an 'IndexDefinition' for a non-unique index with given SQL and index name. @since 1.0.0.0 @@ -193,8 +197,7 @@ nonUniqueNamedIndex = mkNamedIndexDefinition Expr.NonUniqueIndex -{- | - Constructs an 'IndexDefinition' for a @UNIQUE@ index on the given columns. +{- | Constructs an 'IndexDefinition' for a @UNIQUE@ index on the given columns. @since 1.0.0.0 -} @@ -202,8 +205,7 @@ uniqueIndex = mkIndexDefinition Expr.UniqueIndex -{- | - Constructs an 'IndexDefinition' for a @UNIQUE@ index with given SQL and index +{- | Constructs an 'IndexDefinition' for a @UNIQUE@ index with given SQL and index name. @since 1.0.0.0 @@ -212,8 +214,7 @@ uniqueNamedIndex = mkNamedIndexDefinition Expr.UniqueIndex -{- | - Constructs an 'IndexDefinition' for an index on the given columns with the +{- | Constructs an 'IndexDefinition' for an index on the given columns with the given uniqueness. @since 1.0.0.0 @@ -243,8 +244,7 @@ , i_indexCreationStrategy = Transactional } -{- | - Constructs an 'IndexDefinition' for an index with the given uniqueness, given +{- | Constructs an 'IndexDefinition' for an index with the given uniqueness, given name, and given SQL. @since 1.0.0.0 @@ -270,8 +270,7 @@ , i_indexCreationStrategy = Transactional } -{- | - Internal helper to determine whether @CONCURRENTLY@ should be included in +{- | Internal helper to determine whether @CONCURRENTLY@ should be included in the SQL to create the index. @since 1.0.0.0 diff --git a/src/Orville/PostgreSQL/Internal/MigrationLock.hs b/src/Orville/PostgreSQL/Internal/MigrationLock.hs --- a/src/Orville/PostgreSQL/Internal/MigrationLock.hs +++ b/src/Orville/PostgreSQL/Internal/MigrationLock.hs @@ -8,7 +8,9 @@ @since 1.0.0.0 -} module Orville.PostgreSQL.Internal.MigrationLock - ( MigrationLockId + ( MigrationLockOptions (migrationLockId, maxLockAttempts, delayBetweenLockAttemptsMicros, lockDelayVariationMicros) + , defaultLockOptions + , MigrationLockId , defaultLockId , nextLockId , withMigrationLock @@ -21,6 +23,7 @@ import qualified Control.Monad as Monad import qualified Control.Monad.IO.Class as MIO import Data.Int (Int32) +import qualified System.Random as Rand import qualified Orville.PostgreSQL.Execution as Exec import qualified Orville.PostgreSQL.Internal.Bracket as Bracket @@ -29,8 +32,58 @@ import qualified Orville.PostgreSQL.Raw.RawSql as RawSql import qualified Orville.PostgreSQL.Raw.SqlValue as SqlValue -{- | -Identifies a PostgreSQL advisory lock to to be aquired by the application. Use +{- | 'MigrationLockOptions' controls how Orville acquires its PostgreSQL advisory lock + to ensure that only one process is attempting to make schema changes at a time. + See the descriptions of each of the options for more detail: + + * 'migrationLockId' + * 'maxLockAttempts' + * 'delayBetweenLockAttemptsMicros' + * 'lockDelayVariationMicros' + +@since 1.1.0.0 +-} +data MigrationLockOptions = MigrationLockOptions + { migrationLockId :: MigrationLockId + -- ^ Specifies the 'MigrationLockId' for the lock that will be acquired to ensure + -- only one process is attempting to migrate the schema at a time. + -- + -- @since 1.1.0.0 + , maxLockAttempts :: Int + -- ^ The maximum number of times Orville will attempt to acquire the migration + -- lock. If the lock has not bene acquired after this many attempts, a + -- 'MigrationLockError' will be thrown as an exception. + -- + -- @since 1.1.0.0 + , delayBetweenLockAttemptsMicros :: Int + -- ^ The minimum number of microseconds Orville will wait after a failed attempt to + -- acquire the lock before it tries again. A random variation will be added to this + -- to determine the delay after each failed attempt. See 'lockDelayVariationMicros' + -- + -- @since 1.1.0.0 + , lockDelayVariationMicros :: Int + -- ^ The maximum variation to add to the delay before attempting to acquire the lock + -- again. The actual variation at each delay will be a pseudo-random number between + -- @0@ and 'lockDelayVariationMicros'. + -- + -- @since 1.1.0.0 + } + +{- | The default lock options use the 'defaultLockId', 25 attempts and randomized delay +between 100 and 125 milliseconds. + +@since 1.1.0.0 +-} +defaultLockOptions :: MigrationLockOptions +defaultLockOptions = + MigrationLockOptions + { migrationLockId = defaultLockId + , maxLockAttempts = 25 + , delayBetweenLockAttemptsMicros = 100000 + , lockDelayVariationMicros = 25000 + } + +{- | Identifies a PostgreSQL advisory lock to to be aquired by the application. Use 'defaultLockId' to obtain the default value and 'nextLockId' to create custom values if you need them. @@ -41,8 +94,7 @@ , i_lockKey2 :: Int32 } -{- | -The lock id that Orville uses by default to ensure that just one copy of the +{- | The lock id that Orville uses by default to ensure that just one copy of the application is attempting to run migrations at a time. @since 1.0.0.0 @@ -54,8 +106,7 @@ , i_lockKey2 = 7995632 } -{- | -Increments the id of the given 'MigrationLockId', creating a new distinct lock +{- | Increments the id of the given 'MigrationLockId', creating a new distinct lock id. You can use this to create your own custom 'MigrationLockId' values as necessary if you need to control migration runs in a custom manner. @@ -70,8 +121,7 @@ orvilleLockScope :: Int32 orvilleLockScope = 17772 -{- | - Executes an Orville action with a PostgreSQL advisory lock held that +{- | Executes an Orville action with a PostgreSQL advisory lock held that indicates to other Orville processes that a database migration is being done and no others should be performed concurrently. @@ -79,23 +129,35 @@ -} withMigrationLock :: Monad.MonadOrville m => - MigrationLockId -> + MigrationLockOptions -> m a -> m a -withMigrationLock lockId action = +withMigrationLock options action = Monad.withConnection_ $ Bracket.bracketWithResult - (accquireTransactionLock lockId) - (\() _bracketResult -> releaseTransactionLock lockId) + (accquireTransactionLock options) + (\() _bracketResult -> releaseTransactionLock options) (\() -> action) accquireTransactionLock :: forall m. Monad.MonadOrville m => - MigrationLockId -> + MigrationLockOptions -> m () -accquireTransactionLock lockId = +accquireTransactionLock options = let + lockId = + migrationLockId options + + maxAttempts = + maxLockAttempts options + + delayMicros = + delayBetweenLockAttemptsMicros options + + delayVariationMicros = + lockDelayVariationMicros options + go :: Int -> m () go attempts = do locked <- attemptLockAcquisition @@ -103,14 +165,17 @@ then pure () else do MIO.liftIO $ do - Monad.when (attempts >= 25) $ do + Monad.when (attempts >= maxAttempts) $ do throwIO $ MigrationLockError - "Giving up after 25 attempts to aquire the migration lock." - threadDelay 10000 + ("Giving up after " <> show maxAttempts <> " attempts to aquire the migration lock.") + variation <- Rand.randomRIO (0, delayVariationMicros) + threadDelay (delayMicros + variation) + go $ attempts + 1 + attemptLockAcquisition :: m Bool attemptLockAcquisition = do tryLockResults <- Exec.executeAndDecode Exec.OtherQuery (tryLockExpr lockId) lockedMarshaller @@ -124,9 +189,9 @@ in go 0 -releaseTransactionLock :: Monad.MonadOrville m => MigrationLockId -> m () +releaseTransactionLock :: Monad.MonadOrville m => MigrationLockOptions -> m () releaseTransactionLock = - Exec.executeVoid Exec.OtherQuery . releaseLockExpr + Exec.executeVoid Exec.OtherQuery . releaseLockExpr . migrationLockId lockedMarshaller :: Marshall.AnnotatedSqlMarshaller Bool Bool lockedMarshaller = @@ -152,14 +217,17 @@ <> RawSql.parameter (SqlValue.fromInt32 (i_lockKey2 lockId)) <> RawSql.rightParen -{- | - Raised if 'withMigrationLock' cannot acquire the migration lock in a +{- | Raised if 'withMigrationLock' cannot acquire the migration lock in a timely manner. @since 1.0.0.0 -} newtype MigrationLockError = MigrationLockError String - deriving (Show) + deriving + ( -- | @since 1.0.0.0 + Show + ) +-- | @since 1.0.0.0 instance Exception MigrationLockError diff --git a/src/Orville/PostgreSQL/Internal/MonadOrville.hs b/src/Orville/PostgreSQL/Internal/MonadOrville.hs --- a/src/Orville/PostgreSQL/Internal/MonadOrville.hs +++ b/src/Orville/PostgreSQL/Internal/MonadOrville.hs @@ -32,8 +32,7 @@ import Orville.PostgreSQL.Monad.HasOrvilleState (HasOrvilleState (askOrvilleState, localOrvilleState)) import Orville.PostgreSQL.Raw.Connection (Connection, withPoolConnection) -{- | - 'MonadOrville' is the typeclass that most Orville operations require to +{- | 'MonadOrville' is the typeclass that most Orville operations require to do anything that connects to the database. 'MonadOrville' itself is empty, but it lists all the required typeclasses as superclass constraints so that it can be used instead of listing all the constraints on every function. @@ -57,8 +56,7 @@ ) => MonadOrville m -{- | - 'MonadOrvilleControl' presents the interface that Orville will use to lift +{- | 'MonadOrvilleControl' presents the interface that Orville will use to lift low-level IO operations that cannot be lifted via 'Control.Monad.IO.Class.liftIO' (i.e. those where the IO parameter is contravariant rather than covariant). @@ -75,20 +73,31 @@ implementation of the methods below for monads that implement 'Control.Monad.IO.Unlift.MonadUnliftIO'. + Note: Orville assumes that execution of any monadic operations will continue + normally other than when an exception is thrown in the IO monad. The monad + implementing 'MonadOrvilleControl' allows for the monad execution to + terminate in other ways (such as a 'Nothing' in the case of 'MaybeT' or + 'Left' in the case of 'ExceptT'), it will likely interfere with Orville's + 'withTransaction' function. In particular, if the action passed to + 'withTransaction' terminates early in any way other than an exception it will + prevent the transaction from being resolved before the connection is returned + to the connection pool. When that connection is taken from the pool in the + future, it will already have the open and unfinished transaction on it. + Another call to 'withTransaction' using that connection will raise an + exception when it detects that there is already an open transaction. + @since 1.0.0.0 -} class MonadOrvilleControl m where - -- | - -- Orville will use this function to lift the acquisition of connections - -- from the resource pool into the application monad. + -- | Orville will use this function to lift the acquisition of connections + -- from the resource pool into the application monad. -- -- @since 1.0.0.0 liftWithConnection :: (forall a. (Connection -> IO a) -> IO a) -> (Connection -> m b) -> m b - -- | - -- Orville will use this function to lift exception catches into the - -- application monad. + -- | Orville will use this function to lift exception catches into the + -- application monad. -- -- @since 1.0.0.0 liftCatch :: @@ -98,10 +107,9 @@ (e -> m b) -> m b - -- | - -- Orville will use this function to lift 'Control.Exception.mask' calls - -- into the application monad to guarantee resource cleanup is executed - -- even when asynchronous exceptions are thrown. + -- | Orville will use this function to lift 'Control.Exception.mask' calls + -- into the application monad to guarantee resource cleanup is executed + -- even when asynchronous exceptions are thrown. -- -- @since 1.0.0.0 liftMask :: @@ -109,6 +117,7 @@ ((forall a. m a -> m a) -> m c) -> m c +-- | @since 1.0.0.0 instance MonadOrvilleControl IO where liftWithConnection ioWithConn = ioWithConn @@ -119,6 +128,7 @@ liftMask ioMask = ioMask +-- | @since 1.0.0.0 instance MonadOrvilleControl m => MonadOrvilleControl (ReaderT state m) where liftWithConnection ioWithConn action = do ReaderT $ \env -> @@ -136,10 +146,10 @@ liftMask ioMask $ \restore -> runReaderT (action (mapReaderT restore)) env +-- | @since 1.0.0.0 instance (MonadOrvilleControl m, MonadIO m) => MonadOrville (ReaderT OrvilleState m) -{- | - 'withConnection' should be used to receive a 'Connection' handle for +{- | 'withConnection' should be used to receive a 'Connection' handle for executing queries against the database from within an application monad using Orville. For the "outermost" call of 'withConnection', a connection will be acquired from the resource pool. Additional calls to 'withConnection' that @@ -155,8 +165,7 @@ withConnection connectedAction = do withConnectedState (connectedAction . connectedConnection) -{- | - 'withConnection_' is a convenience version of 'withConnection' for those that +{- | 'withConnection_' is a convenience version of 'withConnection' for those that don't need the actual connection handle. You might want to use this function even without using the handle because it ensures that all the Orville operations performed by the action passed to it occur on the same connection. @@ -170,8 +179,7 @@ withConnection_ = withConnection . const -{- | - INTERNAL: This in an internal version of 'withConnection' that gives access to +{- | INTERNAL: This in an internal version of 'withConnection' that gives access to the entire 'ConnectedState' value to allow for transaction management. @since 1.0.0.0 diff --git a/src/Orville/PostgreSQL/Internal/OrvilleState.hs b/src/Orville/PostgreSQL/Internal/OrvilleState.hs --- a/src/Orville/PostgreSQL/Internal/OrvilleState.hs +++ b/src/Orville/PostgreSQL/Internal/OrvilleState.hs @@ -48,8 +48,7 @@ import qualified Orville.PostgreSQL.Raw.RawSql as RawSql import qualified Orville.PostgreSQL.Raw.SqlCommenter as SqlCommenter -{- | - 'OrvilleState' is used to manage opening connections to the database, +{- | 'OrvilleState' is used to manage opening connections to the database, transactions, etc. 'newOrvilleState' should be used to create an appopriate initial state for your monad's context. @@ -65,8 +64,7 @@ , _orvilleSqlCommenterAttributes :: Maybe SqlCommenter.SqlCommenterAttributes } -{- | - Get the connection pool being used for the 'OrvilleState'. +{- | Get the connection pool being used for the 'OrvilleState'. @since 1.0.0.0 -} @@ -74,8 +72,7 @@ orvilleConnectionPool = _orvilleConnectionPool -{- | - INTERNAL: The 'ConnectionState' indicates whether Orville currently has a +{- | INTERNAL: The 'ConnectionState' indicates whether Orville currently has a connection open, and contains the connection if it does. @since 1.0.0.0 @@ -84,8 +81,7 @@ orvilleConnectionState = _orvilleConnectionState -{- | - The 'ErrorDetailLevel' controls how much information Orville includes in +{- | The 'ErrorDetailLevel' controls how much information Orville includes in error messages it generates when data cannot be decoded from rows in the database. @@ -95,8 +91,7 @@ orvilleErrorDetailLevel = _orvilleErrorDetailLevel -{- | - Orville will call the transaction callback any time a transaction event +{- | Orville will call the transaction callback any time a transaction event occurs. You can register a callback with 'addTransactionCallback'. @since 1.0.0.0 @@ -105,8 +100,7 @@ orvilleTransactionCallback = _orvilleTransactionCallback -{- | - The SQL expression that Orville will use to begin a transaction. You can set +{- | The SQL expression that Orville will use to begin a transaction. You can set this via 'setBeginTransactionExpr' to have fine-grained control over the transaction parameters, such as isolation level. @@ -116,8 +110,7 @@ orvilleBeginTransactionExpr = _orvilleBeginTransactionExpr -{- | - The SqlCommenter attributes that Orville will include with queries. These can +{- | The SqlCommenter attributes that Orville will include with queries. These can be modified with 'addSqlCommenterAttributes'. See https://google.github.io/sqlcommenter/. @@ -127,8 +120,7 @@ orvilleSqlCommenterAttributes = _orvilleSqlCommenterAttributes -{- | - Registers a callback to be invoked during transactions. +{- | Registers a callback to be invoked during transactions. The callback given will be called after the SQL statement corresponding to the given event has finished executing. Callbacks will be called @@ -160,8 +152,7 @@ in state {_orvilleTransactionCallback = wrappedCallback} -{- | - Creates an appropriate initial 'OrvilleState' that will use the connection +{- | Creates an appropriate initial 'OrvilleState' that will use the connection pool given to initiate connections to the database. @since 1.0.0.0 @@ -178,8 +169,7 @@ , _orvilleSqlCommenterAttributes = Nothing } -{- | - Creates a new initial 'OrvilleState' using the connection pool from the +{- | Creates a new initial 'OrvilleState' using the connection pool from the provided state. You might need to use this if you are spawning one Orville monad from another and they should not share the same connection and transaction state. @@ -192,8 +182,7 @@ <$> _orvilleErrorDetailLevel <*> _orvilleConnectionPool -{- | - INTERNAL: Transitions the 'OrvilleState' into "connected" status, storing the +{- | INTERNAL: Transitions the 'OrvilleState' into "connected" status, storing the given 'Connection' as the database connection to be used to execute all queries. This is used by 'Orville.PostgreSQL.Monad.withConnection' to track the connection it retrieves from the pool. @@ -206,8 +195,7 @@ { _orvilleConnectionState = Connected connectedState } -{- | - INTERNAL: This type is used to signal whether a database connection has +{- | INTERNAL: This type is used to signal whether a database connection has been retrieved from the pool for the current operation or not. The value is tracked in the 'OrvilleState' for the host monad, and is checked by 'Orville.PostgreSQL.Monad.withConnection' to avoid checking out two @@ -220,8 +208,7 @@ = NotConnected | Connected ConnectedState -{- | - INTERNAL: This type is used hold the connection while it is open and +{- | INTERNAL: This type is used hold the connection while it is open and track the state of open transactions and savepoints on the connection. @since 1.0.0.0 @@ -231,8 +218,7 @@ , connectedTransaction :: Maybe TransactionState } -{- | - INTERNAL: This type is use to track the state of open transactions and +{- | INTERNAL: This type is use to track the state of open transactions and savepoints on an open connection. @since 1.0.0.0 @@ -241,8 +227,7 @@ = OutermostTransaction | SavepointTransaction Savepoint -{- | - INTERNAL: Constructs a new 'TransactionState' to represent beginning a +{- | INTERNAL: Constructs a new 'TransactionState' to represent beginning a new transaction in SQL. @since 1.0.0.0 @@ -257,17 +242,20 @@ Just (SavepointTransaction savepoint) -> SavepointTransaction (nextSavepoint savepoint) -{- | - An internal Orville identifier for a savepoint in a PostgreSQL transaction. +{- | An internal Orville identifier for a savepoint in a PostgreSQL transaction. @since 1.0.0.0 -} newtype Savepoint = Savepoint Int - deriving (Eq, Show) + deriving + ( -- | @since 1.0.0.0 + Eq + , -- | @since 1.0.0.0 + Show + ) -{- | - The initial identifier Orville uses to track the first savepoint within +{- | The initial identifier Orville uses to track the first savepoint within a transaction. @since 1.0.0.0 @@ -276,8 +264,7 @@ initialSavepoint = Savepoint 1 -{- | - Determines the identifier for the next savepoint in a transaction after the +{- | Determines the identifier for the next savepoint in a transaction after the given savepoint. @since 1.0.0.0 @@ -286,8 +273,7 @@ nextSavepoint (Savepoint n) = Savepoint (n + 1) -{- | - Indicates how many levels of nested savepoints the given 'Savepoint' +{- | Indicates how many levels of nested savepoints the given 'Savepoint' identifier represents. @since 1.0.0.0 @@ -295,8 +281,7 @@ savepointNestingLevel :: Savepoint -> Int savepointNestingLevel (Savepoint n) = n -{- | - Describes an event in the lifecycle of a database transaction. You can use +{- | Describes an event in the lifecycle of a database transaction. You can use 'addTransactionCallback' to register a callback to respond to these events. The callback will be called after the event in question has been successfully executed. @@ -324,18 +309,21 @@ CommitTransaction | -- | Indicates that the transaction has been rolled back. RollbackTransaction - deriving (Eq, Show) + deriving + ( -- | @since 1.0.0.0 + Eq + , -- | @since 1.0.0.0 + Show + ) -{- | - The default transaction callback is simply a no-op. +{- | The default transaction callback is simply a no-op. @since 1.0.0.0 -} defaultTransactionCallback :: TransactionEvent -> IO () defaultTransactionCallback = const (pure ()) -{- | - Constructs the appropriate 'TransactionEvent' for opening a new transaction +{- | Constructs the appropriate 'TransactionEvent' for opening a new transaction based on the current 'TransactionState'. @since 1.0.0.0 @@ -346,8 +334,7 @@ OutermostTransaction -> BeginTransaction SavepointTransaction savepoint -> NewSavepoint savepoint -{- | - Constructs the appropriate 'TransactionEvent' for rolling back the innermost +{- | Constructs the appropriate 'TransactionEvent' for rolling back the innermost transaction based on the current 'TransactionState'. @since 1.0.0.0 @@ -358,8 +345,7 @@ OutermostTransaction -> RollbackTransaction SavepointTransaction savepoint -> RollbackToSavepoint savepoint -{- | - Constructs the appropriate 'TransactionEvent' to represent a transaction +{- | Constructs the appropriate 'TransactionEvent' to represent a transaction completely successfully based on the current 'TransactionState'. @since 1.0.0.0 @@ -370,8 +356,7 @@ OutermostTransaction -> CommitTransaction SavepointTransaction savepoint -> ReleaseSavepoint savepoint -{- | - The callback Orville will call whenever it wants to run SQL. You can +{- | The callback Orville will call whenever it wants to run SQL. You can register a callback using 'addSqlExecutionCallback'. @since 1.0.0.0 @@ -386,8 +371,7 @@ orvilleSqlExecutionCallback = _orvilleSqlExecutionCallback -{- | - The default SQL execption callback simply runs the IO action given without +{- | The default SQL execption callback simply runs the IO action given without doing anything else. @since 1.0.0.0 @@ -395,8 +379,7 @@ defaultSqlExectionCallback :: QueryType -> RawSql.RawSql -> IO a -> IO a defaultSqlExectionCallback _ _ io = io -{- | - Adds a callback to be called when an Orville operation executes a SQL +{- | Adds a callback to be called when an Orville operation executes a SQL statement. The callback is given the IO action that will perform the query execution and must call that action for the query to be run. In particular, you can use this to time queries and log any that are slow. @@ -424,8 +407,7 @@ in state {_orvilleSqlExecutionCallback = layeredCallback} -{- | - The default begin transaction expression is simply @BEGIN TRANSACTION@ +{- | The default begin transaction expression is simply @BEGIN TRANSACTION@ with no options specified. @since 1.0.0.0 @@ -434,8 +416,7 @@ defaultBeginTransactionExpr = Expr.beginTransaction Nothing -{- | - Sets the SQL expression that Orville will use to begin transactions. You can +{- | Sets the SQL expression that Orville will use to begin transactions. You can control the transaction isolation level by building your own 'Expr.BeginTransactionExpr' with the desired isolation level. @@ -450,8 +431,7 @@ { _orvilleBeginTransactionExpr = expr } -{- | - Sets the SqlCommenterAttributes that Orville will then add to any following +{- | Sets the SqlCommenterAttributes that Orville will then add to any following statement executions. @since 1.0.0.0 @@ -465,8 +445,7 @@ { _orvilleSqlCommenterAttributes = Just comments } -{- | - Adds the SqlCommenterAttributes to the already existing attributes that +{- | Adds the SqlCommenterAttributes to the already existing attributes that Orville will then add to any following statement executions. @since 1.0.0.0 diff --git a/src/Orville/PostgreSQL/Internal/RowCountExpectation.hs b/src/Orville/PostgreSQL/Internal/RowCountExpectation.hs --- a/src/Orville/PostgreSQL/Internal/RowCountExpectation.hs +++ b/src/Orville/PostgreSQL/Internal/RowCountExpectation.hs @@ -14,8 +14,7 @@ import Control.Exception (Exception, throwIO) import Control.Monad.IO.Class (MonadIO (liftIO)) -{- | - INTERNAL: This should really never get thrown in the real world. It would be +{- | INTERNAL: This should really never get thrown in the real world. It would be thrown if the returning clause from an insert statement for a single record returned 0 records or more than 1 record. @@ -23,10 +22,18 @@ -} newtype RowCountExpectationError = RowCountExpectationError String - deriving (Show) + deriving + ( -- | @since 1.0.0.0 + Show + ) +-- | @since 1.0.0.0 instance Exception RowCountExpectationError +{- | Throw if input was not exactly size 1. + +@since 1.0.0.0 +-} expectExactlyOneRow :: MonadIO m => String -> [a] -> m a expectExactlyOneRow caller rows = case rows of @@ -38,6 +45,10 @@ <> ": Expected exactly one row to be returned, but got " <> show (length rows) +{- | Throw if input size was greater than 1. + +@since 1.0.0.0 +-} expectAtMostOneRow :: MonadIO m => String -> [a] -> m (Maybe a) expectAtMostOneRow caller rows = case rows of diff --git a/src/Orville/PostgreSQL/Marshall.hs b/src/Orville/PostgreSQL/Marshall.hs --- a/src/Orville/PostgreSQL/Marshall.hs +++ b/src/Orville/PostgreSQL/Marshall.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -Wno-missing-import-lists #-} {- | -Copyright : Flipstone Technology Partners 2023 +Copyright : Flipstone Technology Partners 2023-2024 License : MIT Stability : Stable @@ -20,15 +20,19 @@ , module Orville.PostgreSQL.Marshall.SyntheticField , module Orville.PostgreSQL.Marshall.MarshallError , module Orville.PostgreSQL.Marshall.SqlType + , module Orville.PostgreSQL.Marshall.AliasName + , module Orville.PostgreSQL.Marshall.SqlComparable ) where -- Note: we list the re-exports explicity above to control the order that they -- appear in the generated haddock documentation. +import Orville.PostgreSQL.Marshall.AliasName import Orville.PostgreSQL.Marshall.DefaultValue import Orville.PostgreSQL.Marshall.FieldDefinition import Orville.PostgreSQL.Marshall.MarshallError +import Orville.PostgreSQL.Marshall.SqlComparable import Orville.PostgreSQL.Marshall.SqlMarshaller import Orville.PostgreSQL.Marshall.SqlType import Orville.PostgreSQL.Marshall.SyntheticField diff --git a/src/Orville/PostgreSQL/Marshall/AliasName.hs b/src/Orville/PostgreSQL/Marshall/AliasName.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Marshall/AliasName.hs @@ -0,0 +1,86 @@ +{- | +Copyright : Flipstone Technology Partners 2024-2025 +License : MIT +Stability : Stable + +@since 1.1.0.0 +-} +module Orville.PostgreSQL.Marshall.AliasName + ( AliasName + , stringToAliasName + , aliasNameToString + , aliasNameToAliasExpr + , aliasNameAndFieldNameToColumnName + , aliasNameToByteString + , byteStringToAliasName + ) where + +import qualified Data.ByteString.Char8 as B8 + +import qualified Orville.PostgreSQL.Expr as Expr +import Orville.PostgreSQL.Internal.FieldName (FieldName, fieldNameToColumnName) + +{- | A simple type to represent the name of a field. + +@since 1.1.0.0 +-} +newtype AliasName + = AliasName B8.ByteString + deriving + ( -- | @since 1.1.0.0 + Eq + , -- | @since 1.1.0.0 + Ord + , -- | @since 1.1.0.0 + Show + ) + +{- | Convert an 'AliasName' and a 'FieldName' to a 'Expr.ColumnName' for usage in SQL expressions. + The result will be properly quoted and escaped. + +@since 1.1.0.0 +-} +aliasNameAndFieldNameToColumnName :: AliasName -> FieldName -> Expr.Qualified Expr.ColumnName +aliasNameAndFieldNameToColumnName aliasName = + Expr.aliasQualifyColumn + (aliasNameToAliasExpr aliasName) + . fieldNameToColumnName + +{- | Constructs a 'AliasName' from a 'String'. + +@since 1.1.0.0 +-} +stringToAliasName :: String -> AliasName +stringToAliasName = + AliasName . B8.pack + +{- | Converts a 'AliasName' to an 'AliasExpr'. + +@since 1.1.0.0 +-} +aliasNameToAliasExpr :: AliasName -> Expr.AliasExpr +aliasNameToAliasExpr = + Expr.fromIdentifier . Expr.identifierFromBytes . aliasNameToByteString + +{- | Converts a 'AliasName' back to a 'String'. + +@since 1.1.0.0 +-} +aliasNameToString :: AliasName -> String +aliasNameToString = + B8.unpack . aliasNameToByteString + +{- | Converts a 'AliasName' back to a 'B8.ByteString'. + +@since 1.1.0.0 +-} +aliasNameToByteString :: AliasName -> B8.ByteString +aliasNameToByteString (AliasName name) = + name + +{- | Constructs a 'AliasName' from a 'B8.ByteString'. + +@since 1.1.0.0 +-} +byteStringToAliasName :: B8.ByteString -> AliasName +byteStringToAliasName = AliasName diff --git a/src/Orville/PostgreSQL/Marshall/DefaultValue.hs b/src/Orville/PostgreSQL/Marshall/DefaultValue.hs --- a/src/Orville/PostgreSQL/Marshall/DefaultValue.hs +++ b/src/Orville/PostgreSQL/Marshall/DefaultValue.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - {- | Copyright : Flipstone Technology Partners 2023 License : MIT @@ -34,14 +32,13 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as TextEnc import qualified Data.Time as Time -import qualified Numeric as Numeric +import qualified Numeric import qualified Orville.PostgreSQL.Expr as Expr import qualified Orville.PostgreSQL.Raw.PgTime as PgTime import qualified Orville.PostgreSQL.Raw.RawSql as RawSql -{- | - A 'DefaultValue' is a SQL expression that can be attached to a +{- | A 'DefaultValue' is a SQL expression that can be attached to a field definition to give a default value for a column at the database level. The default value will be used if an insert is done and the column is not provided. @@ -58,8 +55,7 @@ newtype DefaultValue a = DefaultValue Expr.ValueExpression -{- | - Builds a default value for any 'Integral' type @n@ by converting it to an +{- | Builds a default value for any 'Integral' type @n@ by converting it to an 'Integer'. @since 1.0.0.0 @@ -81,8 +77,7 @@ <> RawSql.fromString "::integer" else DefaultValue . RawSql.unsafeFromRawSql . RawSql.fromBytes $ decimalBytes -{- | - Builds a default value from an 'Int16' for use with small integer fields. +{- | Builds a default value from an 'Int16' for use with small integer fields. This is a specialization of 'integerDefault'. @@ -91,8 +86,7 @@ smallIntegerDefault :: Int16 -> DefaultValue Int16 smallIntegerDefault = integralDefault -{- | - Builds a default value from an 'Int32' for use with integer fields. +{- | Builds a default value from an 'Int32' for use with integer fields. This is a specialization of 'integerDefault'. @@ -101,8 +95,7 @@ integerDefault :: Int32 -> DefaultValue Int32 integerDefault = integralDefault -{- | - Builds a default value from an 'Int16' for use with big integer fields. +{- | Builds a default value from an 'Int16' for use with big integer fields. This is a specialization of 'integerDefault'. @@ -111,8 +104,7 @@ bigIntegerDefault :: Int64 -> DefaultValue Int64 bigIntegerDefault = integralDefault -{- | - Builds a default value from a 'Double' field for use with double fields. +{- | Builds a default value from a 'Double' field for use with double fields. @since 1.0.0.0 -} @@ -132,8 +124,7 @@ <> RawSql.fromString "::numeric" else DefaultValue . RawSql.unsafeFromRawSql . RawSql.fromBytes $ decimalBytes -{- | - Builds a default value from a 'Bool', for use with boolean fields. +{- | Builds a default value from a 'Bool', for use with boolean fields. @since 1.0.0.0 -} @@ -147,8 +138,7 @@ in DefaultValue $ RawSql.unsafeSqlExpression pgString -{- | - Builds a default value from a 'T.Text', for use with unbounded, bounded +{- | Builds a default value from a 'T.Text', for use with unbounded, bounded and fixed-length text fields. @since 1.0.0.0 @@ -159,8 +149,7 @@ RawSql.stringLiteral (TextEnc.encodeUtf8 text) <> RawSql.fromString "::text" -{- | - Builds a default value from a 'Time.Day' for use with date fields. +{- | Builds a default value from a 'Time.Day' for use with date fields. @since 1.0.0.0 -} @@ -174,8 +163,7 @@ RawSql.stringLiteral pgText <> RawSql.fromString "::date" -{- | - Builds a default value that will default to the current date (i.e. the +{- | Builds a default value that will default to the current date (i.e. the date at which the database populates the default value on a given row). For use with date fields. @@ -189,8 +177,7 @@ . RawSql.fromString $ "('now'::text)::date" -{- | - Builds a default value from a 'Time.UTCTime' for use with UTC timestamp fields. +{- | Builds a default value from a 'Time.UTCTime' for use with UTC timestamp fields. @since 1.0.0.0 -} @@ -204,8 +191,7 @@ RawSql.stringLiteral pgText <> RawSql.fromString "::timestamp with time zone" -{- | - Builds a default value that will default to the current UTC time (i.e. the +{- | Builds a default value that will default to the current UTC time (i.e. the time at which the database populates the default value on a given row). For use with UTC timestamp fields. @@ -216,8 +202,7 @@ currentUTCTimestampDefault = DefaultValue $ RawSql.unsafeSqlExpression "now()" -{- | - Builds a default value from a 'Time.LocalTime' for use with local timestamp fields. +{- | Builds a default value from a 'Time.LocalTime' for use with local timestamp fields. @since 1.0.0.0 -} @@ -232,8 +217,7 @@ $ RawSql.stringLiteral pgText <> RawSql.fromString "::timestamp without time zone" -{- | - Builds a default value that will default to the current local time (i.e. the +{- | Builds a default value that will default to the current local time (i.e. the time at which the database populates the default value on a given row). Note: "local" time here will be determined by the database itself, subject to @@ -247,8 +231,7 @@ currentLocalTimestampDefault = DefaultValue $ RawSql.unsafeSqlExpression "('now'::text)::timestamp without time zone" -{- | - Coerces a 'DefaultValue' so that it can be used with field definitions of +{- | Coerces a 'DefaultValue' so that it can be used with field definitions of a different Haskell type. The coercion will always succeed, and is safe as far as Haskell itself is concerned. As long as the 'DefaultValue' is used with a column whose database type is the same as the one the 'DefaultValue' @@ -260,8 +243,7 @@ coerceDefaultValue (DefaultValue expression) = DefaultValue expression -{- | - Returns a database value expression for the default value. +{- | Returns a database value expression for the default value. @since 1.0.0.0 -} @@ -269,8 +251,7 @@ defaultValueExpression (DefaultValue expression) = expression -{- | - Constructs a default value from a 'Expr.ValueExpression'. You can use this to +{- | Constructs a default value from a 'Expr.ValueExpression'. You can use this to construct default values for any SQL expression that Orville does not support directly. diff --git a/src/Orville/PostgreSQL/Marshall/FieldDefinition.hs b/src/Orville/PostgreSQL/Marshall/FieldDefinition.hs --- a/src/Orville/PostgreSQL/Marshall/FieldDefinition.hs +++ b/src/Orville/PostgreSQL/Marshall/FieldDefinition.hs @@ -1,8 +1,10 @@ +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {- | -Copyright : Flipstone Technology Partners 2023 +Copyright : Flipstone Technology Partners 2023-2025 License : MIT Stability : Stable @@ -33,6 +35,8 @@ , (.==) , fieldNotEquals , (./=) + , fieldIsDistinctFrom + , fieldIsNotDistinctFrom , fieldGreaterThan , (.>) , fieldLessThan @@ -94,6 +98,14 @@ , jsonbField , fieldOfType , whereColumnComparison + , QualifiedFieldDefinition + , qualifyField + , qualifiedFieldColumnName + , FieldQualifier (qualifyColumnName) + , FieldIdentityGeneration (GeneratedAlways, GeneratedByDefault) + , markAsIdentity + , unmarkIdentity + , fieldIdentityGeneration ) where @@ -107,14 +119,16 @@ import qualified Orville.PostgreSQL.Expr as Expr import Orville.PostgreSQL.Internal.FieldName (FieldName, byteStringToFieldName, fieldNameToByteString, fieldNameToColumnName, fieldNameToString, stringToFieldName) +import qualified Orville.PostgreSQL.Marshall.AliasName as AliasName import qualified Orville.PostgreSQL.Marshall.DefaultValue as DefaultValue +import Orville.PostgreSQL.Marshall.SqlComparable (SqlComparable (referenceValueExpression, toComparableSqlValue)) +import qualified Orville.PostgreSQL.Marshall.SqlComparable as SqlComparable import qualified Orville.PostgreSQL.Marshall.SqlType as SqlType import qualified Orville.PostgreSQL.Raw.SqlValue as SqlValue import qualified Orville.PostgreSQL.Schema.ConstraintDefinition as ConstraintDefinition import qualified Orville.PostgreSQL.Schema.TableIdentifier as TableIdentifier -{- | - 'FieldDefinition' determines the SQL construction of a column in the +{- | 'FieldDefinition' determines the SQL construction of a column in the database, comprising the name, SQL type and whether the field is nullable. A 'FieldDefinition' is matched to a particular Haskell type, which it knows how to marshall to and from the database representation of SQL type for @@ -129,18 +143,26 @@ , i_fieldDefaultValue :: Maybe (DefaultValue.DefaultValue a) , i_fieldDescription :: Maybe String , i_fieldTableConstraints :: [FieldName -> ConstraintDefinition.ConstraintDefinition] + , i_fieldIdentity :: IdentityGADT nullability } -{- | - The name used in database queries to reference the field. +{- | Constructs the 'Expr.ValueExpression' for a field for use in SQL expressions + from the "Orville.PostgreSQL.Expr" module. +@since 1.1.0.0 +-} +instance SqlComparable.SqlComparable (FieldDefinition nullability a) a where + toComparableSqlValue = fieldValueToSqlValue + referenceValueExpression = fieldColumnReference + +{- | The name used in database queries to reference the field. + @since 1.0.0.0 -} fieldName :: FieldDefinition nullability a -> FieldName fieldName = i_fieldName -{- | - Sets the name used in database queries to reference the field. +{- | Sets the name used in database queries to reference the field. @since 1.0.0.0 -} @@ -150,17 +172,15 @@ { i_fieldName = newName } -{- | - Returns the description that was passed to 'setFieldDescription', if any. +{- | Returns the description that was passed to 'setFieldDescription', if any. @since 1.0.0.0 -} fieldDescription :: FieldDefinition nullability a -> Maybe String fieldDescription = i_fieldDescription -{- | - Sets the description for the field. This description is not currently used - anywhere by Orville itself, but users can retrieve the description via +{- | Sets the description for the field. This description will be used to add + a comment to the column, and users can retrieve the description via 'fieldDescription' for their own purposes (e.g. generating documentation). @since 1.0.0.0 @@ -171,8 +191,7 @@ { i_fieldDescription = Just description } -{- | - The 'SqlType.SqlType' for the 'FieldDefinition' determines the PostgreSQL +{- | The 'SqlType.SqlType' for the 'FieldDefinition' determines the PostgreSQL data type used to define the field as well as how to marshall Haskell values to and from the database. @@ -181,16 +200,14 @@ fieldType :: FieldDefinition nullability a -> SqlType.SqlType a fieldType = i_fieldType -{- | - Returns the default value definition for the field, if any has been set. +{- | Returns the default value definition for the field, if any has been set. @since 1.0.0.0 -} fieldDefaultValue :: FieldDefinition nullability a -> Maybe (DefaultValue.DefaultValue a) fieldDefaultValue = i_fieldDefaultValue -{- | - A 'FieldNullability' is returned by the 'fieldNullability' function, which +{- | A 'FieldNullability' is returned by the 'fieldNullability' function, which can be used when a function works on both 'Nullable' and 'NotNull' functions but needs to deal with each type of field separately. It adds wrapper constructors around the 'FieldDefinition' that you can pattern match on to @@ -202,8 +219,7 @@ = NullableField (FieldDefinition Nullable a) | NotNullField (FieldDefinition NotNull a) -{- | - Resolves the @nullability@ of a field to a concrete type, which is returned +{- | Resolves the @nullability@ of a field to a concrete type, which is returned via the 'FieldNullability' type. You can pattern match on this type to then extract the either 'Nullable' or 'NotNull' field for cases where you may require different logic based on the nullability of a field. @@ -216,8 +232,7 @@ NullableGADT -> NullableField field NotNullGADT -> NotNullField field -{- | - Indicates whether a field is not nullable. +{- | Indicates whether a field is not nullable. @since 1.0.0.0 -} @@ -227,8 +242,7 @@ NullableGADT -> False NotNullGADT -> True -{- | - A list of table constraints that will be included on any table that uses this +{- | A list of table constraints that will be included on any table that uses this field definition. @since 1.0.0.0 @@ -249,8 +263,7 @@ ConstraintDefinition.emptyTableConstraints constructedConstraints -{- | - Adds the given table constraints to the field definition. These constraints +{- | Adds the given table constraints to the field definition. These constraints will then be included on any table where the field is used. The constraints are passed a function that will take the name of the field definition and construct the constraints. This allows the @@ -274,8 +287,7 @@ constraintDefs <> i_fieldTableConstraints fieldDef } -{- | - Adds a @FOREIGN KEY@ constraint to the 'FieldDefinition' (using +{- | Adds a @FOREIGN KEY@ constraint to the 'FieldDefinition' (using 'addFieldTableConstraints'). This constraint will be included on any table that uses the field definition. @@ -294,8 +306,7 @@ foreignFieldName ConstraintDefinition.defaultForeignKeyOptions -{- | - Adds a @FOREIGN KEY@ constraint to the 'FieldDefinition'. This constraint +{- | Adds a @FOREIGN KEY@ constraint to the 'FieldDefinition'. This constraint will be included on any table that uses the field definition. @since 1.0.0.0 @@ -324,8 +335,7 @@ in addFieldTableConstraints [constraintToAdd] fieldDef -{- | - Adds a @UNIQUE@ constraint to the 'FieldDefinition'. This constraint +{- | Adds a @UNIQUE@ constraint to the 'FieldDefinition'. This constraint will be included on any table that uses the field definition. @since 1.0.0.0 @@ -340,8 +350,7 @@ in addFieldTableConstraints [constraintToAdd] fieldDef -{- | - Marshalls a Haskell value to be stored in the field to its 'SqlValue.SqlValue' +{- | Marshalls a Haskell value to be stored in the field to its 'SqlValue.SqlValue' representation and packages the result as a 'Expr.ValueExpression' so that it can be easily used with other @Expr@ functions. @@ -351,18 +360,15 @@ fieldValueToExpression field = Expr.valueExpression . fieldValueToSqlValue field -{- | - Marshalls a Haskell value to be stored in the field to its 'SqlValue.SqlValue' +{- | Marshalls a Haskell value to be stored in the field to its 'SqlValue.SqlValue' representation. @since 1.0.0.0 -} fieldValueToSqlValue :: FieldDefinition nullability a -> a -> SqlValue.SqlValue -fieldValueToSqlValue = - SqlType.sqlTypeToSql . fieldType +fieldValueToSqlValue = SqlType.sqlTypeToSql . fieldType -{- | - Marshalls a 'SqlValue.SqlValue' from the database into the Haskell value that represents it. +{- | Marshalls a 'SqlValue.SqlValue' from the database into the Haskell value that represents it. This may fail, in which case a 'Left' is returned with an error message. @since 1.0.0.0 @@ -371,8 +377,7 @@ fieldValueFromSqlValue = SqlType.sqlTypeFromSql . fieldType -{- | - Constructs the 'Expr.ColumnName' for a field for use in SQL expressions +{- | Constructs the 'Expr.ColumnName' for a field for use in SQL expressions from the "Orville.PostgreSQL.Expr" module. @since 1.0.0.0 @@ -381,18 +386,19 @@ fieldColumnName = fieldNameToColumnName . fieldName -{- | - Constructs the 'Expr.ValueExpression' for a field for use in SQL expressions - from the "Orville.PostgreSQL.Expr" module. +{- | Constructs the 'Expr.ValueExpression' for use in SQL expressions from the + "Orville.PostgreSQL.Expr" module. @since 1.0.0.0 -} fieldColumnReference :: FieldDefinition nullability a -> Expr.ValueExpression fieldColumnReference = - Expr.columnReference . fieldColumnName + Expr.columnReference + . Expr.unqualified + . fieldNameToColumnName + . fieldName -{- | - Constructs the equivalent 'Expr.FieldDefinition' as a SQL expression, +{- | Constructs the equivalent 'Expr.FieldDefinition' as a SQL expression, generally for use in DDL for creating columns in a table. @since 1.0.0.0 @@ -400,29 +406,30 @@ fieldColumnDefinition :: FieldDefinition nullability a -> Expr.ColumnDefinition fieldColumnDefinition fieldDef = Expr.columnDefinition - (fieldColumnName fieldDef) + (fieldNameToColumnName $ fieldName fieldDef) (SqlType.sqlTypeExpr $ fieldType fieldDef) - (Just $ fieldColumnConstraint fieldDef) + (fieldColumnConstraints fieldDef) (fmap (Expr.columnDefault . DefaultValue.defaultValueExpression) $ i_fieldDefaultValue fieldDef) -{- | - INTERNAL - Builds the appropriate ColumnConstraint for a field. Currently - this only handles nullability, but if we add support for more constraints - directly on columns it may end up handling those as well. +{- | INTERNAL - Builds the appropriate [ColumnConstraint] for a field. @since 1.0.0.0 -} -fieldColumnConstraint :: FieldDefinition nullabily a -> Expr.ColumnConstraint -fieldColumnConstraint fieldDef = +fieldColumnConstraints :: FieldDefinition nullabily a -> [Expr.ColumnConstraint] +fieldColumnConstraints fieldDef = case fieldNullability fieldDef of - NotNullField _ -> - Expr.notNullConstraint + NotNullField nnf -> + case i_fieldIdentity nnf of + IsIdentityGADT GeneratedAlways -> + [Expr.notNullConstraint, Expr.identityColumnConstraint Expr.alwaysColumnIdentityGeneration] + IsIdentityGADT GeneratedByDefault -> + [Expr.notNullConstraint, Expr.identityColumnConstraint Expr.byDefaultColumnIdentityGeneration] + AllowedIdentityButNotSetGADT -> + pure Expr.notNullConstraint NullableField _ -> - Expr.nullConstraint - -{- | + pure Expr.nullConstraint - The type in considered internal because it requires GADTs to make use of +{- | The type in considered internal because it requires GADTs to make use of it meaningfully. The 'FieldNullability' type is used as the public interface to surface this information to users outside the module. @@ -438,9 +445,7 @@ NullableGADT :: NullabilityGADT Nullable NotNullGADT :: NullabilityGADT NotNull -{- | - - 'NotNull' is a valueless type used to track that a 'FieldDefinition' +{- | 'NotNull' is a valueless type used to track that a 'FieldDefinition' represents a field that is marked not-null in the database schema. See the 'FieldNullability' type for the value-level representation of field nullability. @@ -448,8 +453,7 @@ -} data NotNull -{- | - 'Nullable' is a valueless type used to track that a 'FieldDefinition' +{- | 'Nullable' is a valueless type used to track that a 'FieldDefinition' represents a field that is marked nullable in the database schema. See the 'FieldNullability' type for the value-level representation of field nullability. @@ -457,8 +461,7 @@ -} data Nullable -{- | - Builds a 'FieldDefinition' that stores Haskell 'Int32' values as the +{- | Builds a 'FieldDefinition' that stores Haskell 'Int32' values as the PostgreSQL "INT" type. @since 1.0.0.0 @@ -469,8 +472,7 @@ FieldDefinition NotNull Int32 integerField = fieldOfType SqlType.integer -{- | - Builds a 'FieldDefinition' that stores Haskell 'Int16' values as the +{- | Builds a 'FieldDefinition' that stores Haskell 'Int16' values as the PostgreSQL "SMALLINT" type. @since 1.0.0.0 @@ -481,8 +483,7 @@ FieldDefinition NotNull Int16 smallIntegerField = fieldOfType SqlType.smallInteger -{- | - Builds a 'FieldDefinition' that stores an 'Int32' value as the "SERIAL" +{- | Builds a 'FieldDefinition' that stores an 'Int32' value as the "SERIAL" type. This can be used to create auto-incrementing columns. @since 1.0.0.0 @@ -493,8 +494,7 @@ FieldDefinition NotNull Int32 serialField = fieldOfType SqlType.serial -{- | - Builds a 'FieldDefinition' that stores Haskell 'Int64' values as the +{- | Builds a 'FieldDefinition' that stores Haskell 'Int64' values as the PostgreSQL "BIGINT" type. @since 1.0.0.0 @@ -505,8 +505,7 @@ FieldDefinition NotNull Int64 bigIntegerField = fieldOfType SqlType.bigInteger -{- | - Builds a 'FieldDefinition' that stores an 'Int64' value as the "BIGSERIAL" +{- | Builds a 'FieldDefinition' that stores an 'Int64' value as the "BIGSERIAL" type. This can be used to create auto-incrementing columns. @since 1.0.0.0 @@ -517,8 +516,7 @@ FieldDefinition NotNull Int64 bigSerialField = fieldOfType SqlType.bigSerial -{- | - Builds a 'FieldDefinition' that stores a 'Double' value as the "DOUBLE +{- | Builds a 'FieldDefinition' that stores a 'Double' value as the "DOUBLE PRECISION" type. Note: PostgreSQL's "DOUBLE PRECISION" type only allows for up to 15 digits of precision, so some rounding may occur when values are stored in the database. @@ -531,8 +529,7 @@ FieldDefinition NotNull Double doubleField = fieldOfType SqlType.double -{- | - Builds a 'FieldDefinition' that stores Haskell 'Bool' values as the +{- | Builds a 'FieldDefinition' that stores Haskell 'Bool' values as the PostgreSQL "BOOLEAN" type. @since 1.0.0.0 @@ -543,8 +540,7 @@ FieldDefinition NotNull Bool booleanField = fieldOfType SqlType.boolean -{- | - Builds a 'FieldDefinition' that stores Haskell 'T.Text' values as the +{- | Builds a 'FieldDefinition' that stores Haskell 'T.Text' values as the PostgreSQL "TEXT" type. Note that this PostgreSQL has no particular limit on the length of text stored. @@ -556,8 +552,7 @@ FieldDefinition NotNull T.Text unboundedTextField = fieldOfType SqlType.unboundedText -{- | - Builds a 'FieldDefinition' that stores Haskell 'T.Text' values as the +{- | Builds a 'FieldDefinition' that stores Haskell 'T.Text' values as the PostgreSQL "VARCHAR" type. Attempting to store a value beyond the length specified will cause an error. @@ -571,8 +566,7 @@ FieldDefinition NotNull T.Text boundedTextField name len = fieldOfType (SqlType.boundedText len) name -{- | - Builds a 'FieldDefinition' that stores Haskell 'T.Text' values as the +{- | Builds a 'FieldDefinition' that stores Haskell 'T.Text' values as the PostgreSQL "CHAR" type. Attempting to store a value beyond the length specified will cause an error. Storing a value that is not the full length of the field will result in padding by the database. @@ -587,8 +581,7 @@ FieldDefinition NotNull T.Text fixedTextField name len = fieldOfType (SqlType.fixedText len) name -{- | - Builds a @FieldDefinition@ that stores PostgreSQL text search vector values. +{- | Builds a @FieldDefinition@ that stores PostgreSQL text search vector values. The values are represented as Haskell 'T.Text' values, but are interpreted as text search vector values by PostgreSQL when passed to it. @@ -600,8 +593,7 @@ textSearchVectorField :: String -> FieldDefinition NotNull T.Text textSearchVectorField = fieldOfType SqlType.textSearchVector -{- | - Builds a 'FieldDefinition' that stores Haskell 'T.Text' values as the +{- | Builds a 'FieldDefinition' that stores Haskell 'T.Text' values as the PostgreSQL "JSONB" type. @since 1.0.0.0 @@ -611,10 +603,13 @@ FieldDefinition NotNull T.Text jsonbField = fieldOfType SqlType.jsonb -{- | - Builds a 'FieldDefinition' that stores Haskell 'Time.Day' values as the +{- | Builds a 'FieldDefinition' that stores Haskell 'Time.Day' values as the PostgreSQL "DATE" type. + This field cannot represent the full range of 'Time.Day' values. PostgreSQL supports years + from -4731 to 5874897 inclusive for this field, and sending a 'Time.Day' with a year outside + of this range to the database will result in a PostgreSQL exception. + @since 1.0.0.0 -} dateField :: @@ -623,10 +618,13 @@ FieldDefinition NotNull Time.Day dateField = fieldOfType SqlType.date -{- | - Builds a 'FieldDefinition' that stores Haskell 'Time.UTCTime' values as the +{- | Builds a 'FieldDefinition' that stores Haskell 'Time.UTCTime' values as the PostgreSQL "TIMESTAMP with time zone" type. + This field cannot represent the full range of 'Time.UTCTime' values. PostgreSQL supports years + from -4731 to 294276 inclusive for this field, and sending a 'Time.UTCTime' with a year outside + of this range to the database will result in a PostgreSQL exception. + @since 1.0.0.0 -} utcTimestampField :: @@ -635,10 +633,13 @@ FieldDefinition NotNull Time.UTCTime utcTimestampField = fieldOfType SqlType.timestamp -{- | - Builds a 'FieldDefinition' that stores Haskell 'Time.UTCTime' values as the +{- | Builds a 'FieldDefinition' that stores Haskell 'Time.UTCTime' values as the PostgreSQL "TIMESTAMP without time zone" type. + This field cannot represent the full range of 'Time.LocalTime' values. PostgreSQL supports years + from -4731 to 294276 inclusive for this field, and sending a 'Time.LocalTime' with a year outside + of this range to the database will result in a PostgreSQL exception. + @since 1.0.0.0 -} localTimestampField :: @@ -647,8 +648,7 @@ FieldDefinition NotNull Time.LocalTime localTimestampField = fieldOfType SqlType.timestampWithoutZone -{- | - Builds a 'FieldDefinition' that stores Haskell 'UUID.UUID' values as the +{- | Builds a 'FieldDefinition' that stores Haskell 'UUID.UUID' values as the PostgreSQL "UUID" type. @since 1.0.0.0 @@ -659,8 +659,7 @@ FieldDefinition NotNull UUID.UUID uuidField = fieldOfType SqlType.uuid -{- | - Builds a 'FieldDefinition' that will use the given 'SqlType.SqlType' to +{- | Builds a 'FieldDefinition' that will use the given 'SqlType.SqlType' to determine the database representation of the field. If you have created a custom 'SqlType.SqlType', you can use this function to construct a helper like the other functions in this module for creating 'FieldDefinition's for @@ -682,13 +681,13 @@ , i_fieldDefaultValue = Nothing , i_fieldDescription = Nothing , i_fieldTableConstraints = mempty + , i_fieldIdentity = AllowedIdentityButNotSetGADT } -{- | - Makes a 'NotNull' field 'Nullable' by wrapping the Haskell type of the field - in 'Maybe'. The field will be marked as @NULL@ in the database schema and - the value 'Nothing' will be used to represent @NULL@ values when converting - to and from SQL. +{- | Makes a 'NotNull' field 'Nullable' by wrapping the Haskell type of the field in 'Maybe'. The + field will be marked as @NULL@ in the database schema and the value 'Nothing' will be used to + represent @NULL@ values when converting to and from SQL. If the field was previously an indentity + column, that will be removed. @since 1.0.0.0 -} @@ -713,10 +712,10 @@ , i_fieldDefaultValue = fmap DefaultValue.coerceDefaultValue (i_fieldDefaultValue field) , i_fieldDescription = fieldDescription field , i_fieldTableConstraints = i_fieldTableConstraints field + , i_fieldIdentity = NotIdentityGADT } -{- | - Adds a 'Maybe' wrapper to a field that is already nullable. (If your field is +{- | Adds a 'Maybe' wrapper to a field that is already nullable. (If your field is 'NotNull', you wanted 'nullableField' instead of this function). Note that fields created using this function have asymmetric encoding and decoding of @NULL@ values. Because the provided field is 'Nullable', @NULL@ values decoded @@ -737,7 +736,7 @@ nullableType sqlType = sqlType { SqlType.sqlTypeToSql = maybe SqlValue.sqlNull (SqlType.sqlTypeToSql sqlType) - , SqlType.sqlTypeFromSql = \sqlValue -> Just <$> SqlType.sqlTypeFromSql sqlType sqlValue + , SqlType.sqlTypeFromSql = fmap Just . SqlType.sqlTypeFromSql sqlType } in FieldDefinition @@ -747,10 +746,10 @@ , i_fieldDefaultValue = fmap DefaultValue.coerceDefaultValue (i_fieldDefaultValue field) , i_fieldDescription = fieldDescription field , i_fieldTableConstraints = i_fieldTableConstraints field + , i_fieldIdentity = i_fieldIdentity field } -{- | - Applies a 'SqlType.SqlType' conversion to a 'FieldDefinition'. You can +{- | Applies a 'SqlType.SqlType' conversion to a 'FieldDefinition'. You can use this function to create 'FieldDefinition's based on the primitive ones provided, but with more specific Haskell types. @@ -769,23 +768,21 @@ , i_fieldDefaultValue = fmap DefaultValue.coerceDefaultValue (i_fieldDefaultValue fieldDef) } -{- | - A specialization of 'convertField' that can be used with types that implement +{- | A specialization of 'convertField' that can be used with types that implement 'Coerce.Coercible'. This is particularly useful for newtype wrappers around primitive types. @since 1.0.0.0 -} coerceField :: - (Coerce.Coercible a b, Coerce.Coercible b a) => + Coerce.Coercible a b => FieldDefinition nullability a -> FieldDefinition nullability b coerceField = convertField (SqlType.convertSqlType Coerce.coerce Coerce.coerce) -{- | - Sets a default value for the field. The default value will be added as part +{- | Sets a default value for the field. The default value will be added as part of the column definition in the database. Because the default value is ultimately provided by the database, this can be used to add a not-null column safely to an existing table as long as a reasonable default value is @@ -802,8 +799,7 @@ { i_fieldDefaultValue = Just defaultValue } -{- | - Removes any default value that may have been set on a field via +{- | Removes any default value that may have been set on a field via @setDefaultValue@. @since 1.0.0.0 @@ -816,9 +812,28 @@ { i_fieldDefaultValue = Nothing } -{- | - Adds a prefix, followed by an underscore, to a field's name. +{- | Use the supplied options to mark a column as an identity column. +@since 1.1.0.0 +-} +markAsIdentity :: FieldIdentityGeneration -> FieldDefinition NotNull a -> FieldDefinition NotNull a +markAsIdentity identityGen fieldDef = + fieldDef + { i_fieldIdentity = IsIdentityGADT identityGen + } + +{- | Remove the identity portion of a field. Note that if a field + +@since 1.1.0.0 +-} +unmarkIdentity :: FieldDefinition NotNull a -> FieldDefinition NotNull a +unmarkIdentity fieldDef = + fieldDef + { i_fieldIdentity = AllowedIdentityButNotSetGADT + } + +{- | Adds a prefix, followed by an underscore, to a field's name. + @since 1.0.0.0 -} prefixField :: @@ -830,38 +845,33 @@ { i_fieldName = byteStringToFieldName (B8.pack prefix <> "_" <> fieldNameToByteString (fieldName fieldDef)) } -{- | - Constructs a 'Expr.SetClause' that will set the column named in the +{- | Constructs a 'Expr.SetClause' that will set the column named in the field definition to the given value. The value is converted to a SQL value using 'fieldValueToSqlValue'. @since 1.0.0.0 -} setField :: FieldDefinition nullability a -> a -> Expr.SetClause -setField fieldDef value = +setField fieldDef = Expr.setColumn - (fieldColumnName fieldDef) - (fieldValueToSqlValue fieldDef value) + (Expr.unqualified (fieldColumnName fieldDef)) + . fieldValueToSqlValue fieldDef -{- | - Operator alias for 'setField'. +{- | Operator alias for 'setField'. @since 1.0.0.0 -} (.:=) :: FieldDefinition nullability a -> a -> Expr.SetClause (.:=) = setField -{- | - Checks that the value in a field equals a particular value. +{- | Checks that the value in a field equals a particular value. @since 1.0.0.0 -} fieldEquals :: FieldDefinition nullability a -> a -> Expr.BooleanExpr -fieldEquals = - whereColumnComparison Expr.equals +fieldEquals = SqlComparable.equals -{- | - Operator alias for 'fieldEquals'. +{- | Operator alias for 'fieldEquals'. @since 1.0.0.0 -} @@ -870,17 +880,14 @@ infixl 9 .== -{- | - Checks that the value in a field does not equal a particular value. +{- | Checks that the value in a field does not equal a particular value. @since 1.0.0.0 -} fieldNotEquals :: FieldDefinition nullability a -> a -> Expr.BooleanExpr -fieldNotEquals = - whereColumnComparison Expr.notEquals +fieldNotEquals = SqlComparable.notEquals -{- | - Operator alias for 'fieldNotEquals'. +{- | Operator alias for 'fieldNotEquals'. @since 1.0.0.0 -} @@ -889,17 +896,28 @@ infixl 9 ./= -{- | - Checks that the value in a field is greater than a particular value. +{- | Checks that the value in a field is distinct from a particular value. +@since 1.1.0.0 +-} +fieldIsDistinctFrom :: FieldDefinition nullability a -> a -> Expr.BooleanExpr +fieldIsDistinctFrom = SqlComparable.isDistinctFrom + +{- | Checks that the value in a field is not distinct from a particular value. + +@since 1.1.0.0 +-} +fieldIsNotDistinctFrom :: FieldDefinition nullability a -> a -> Expr.BooleanExpr +fieldIsNotDistinctFrom = SqlComparable.isNotDistinctFrom + +{- | Checks that the value in a field is greater than a particular value. + @since 1.0.0.0 -} fieldGreaterThan :: FieldDefinition nullability a -> a -> Expr.BooleanExpr -fieldGreaterThan = - whereColumnComparison Expr.greaterThan +fieldGreaterThan = SqlComparable.greaterThan -{- | - Operator alias for 'fieldGreaterThan'. +{- | Operator alias for 'fieldGreaterThan'. @since 1.0.0.0 -} @@ -908,17 +926,14 @@ infixl 9 .> -{- | - Checks that the value in a field is less than a particular value. +{- | Checks that the value in a field is less than a particular value. @since 1.0.0.0 -} fieldLessThan :: FieldDefinition nullability a -> a -> Expr.BooleanExpr -fieldLessThan = - whereColumnComparison Expr.lessThan +fieldLessThan = SqlComparable.lessThan -{- | - Operator alias for 'fieldLessThan'. +{- | Operator alias for 'fieldLessThan'. @since 1.0.0.0 -} @@ -927,17 +942,14 @@ infixl 9 .< -{- | - Checks that the value in a field is greater than or equal to a particular value. +{- | Checks that the value in a field is greater than or equal to a particular value. @since 1.0.0.0 -} fieldGreaterThanOrEqualTo :: FieldDefinition nullability a -> a -> Expr.BooleanExpr -fieldGreaterThanOrEqualTo = - whereColumnComparison Expr.greaterThanOrEqualTo +fieldGreaterThanOrEqualTo = SqlComparable.greaterThanOrEqualTo -{- | - Operator alias for 'fieldGreaterThanOrEqualTo'. +{- | Operator alias for 'fieldGreaterThanOrEqualTo'. @since 1.0.0.0 -} @@ -946,17 +958,14 @@ infixl 9 .>= -{- | - Checks that the value in a field is less than or equal to a particular value. +{- | Checks that the value in a field is less than or equal to a particular value. @since 1.0.0.0 -} fieldLessThanOrEqualTo :: FieldDefinition nullability a -> a -> Expr.BooleanExpr -fieldLessThanOrEqualTo = - whereColumnComparison Expr.lessThanOrEqualTo +fieldLessThanOrEqualTo = SqlComparable.lessThanOrEqualTo -{- | - Operator alias for 'fieldLessThanOrEqualTo'. +{- | Operator alias for 'fieldLessThanOrEqualTo'. @since 1.0.0.0 -} @@ -965,59 +974,42 @@ infixl 9 .<= -{- | - Checks that the value in a field matches a like pattern. +{- | Checks that the value in a field matches a like pattern. @since 1.0.0.0 -} fieldLike :: FieldDefinition nullability a -> T.Text -> Expr.BooleanExpr -fieldLike fieldDef likePattern = - Expr.like - (fieldColumnReference fieldDef) - (Expr.valueExpression (SqlValue.fromText likePattern)) +fieldLike = SqlComparable.like -{- | - Checks that the value in a field matches a like pattern case insensitively. +{- | Checks that the value in a field matches a like pattern case insensitively. @since 1.0.0.0 -} fieldLikeInsensitive :: FieldDefinition nullability a -> T.Text -> Expr.BooleanExpr -fieldLikeInsensitive fieldDef likePattern = - Expr.likeInsensitive - (fieldColumnReference fieldDef) - (Expr.valueExpression (SqlValue.fromText likePattern)) +fieldLikeInsensitive = SqlComparable.likeInsensitive -{- | - Checks that the value in a field is null. +{- | Checks that the value in a field is null. @since 1.0.0.0 -} fieldIsNull :: FieldDefinition Nullable a -> Expr.BooleanExpr -fieldIsNull = - Expr.isNull . fieldColumnReference +fieldIsNull = SqlComparable.isNull -{- | - Checks that the value in a field is not null. +{- | Checks that the value in a field is not null. @since 1.0.0.0 -} fieldIsNotNull :: FieldDefinition Nullable a -> Expr.BooleanExpr -fieldIsNotNull = - Expr.isNotNull . fieldColumnReference +fieldIsNotNull = SqlComparable.isNotNull -{- | - Checks that a field matches a list of values. +{- | Checks that a field matches a list of values. @since 1.0.0.0 -} fieldIn :: FieldDefinition nullability a -> NonEmpty a -> Expr.BooleanExpr -fieldIn fieldDef values = - Expr.valueIn - (fieldColumnReference fieldDef) - (fmap (fieldValueToExpression fieldDef) values) +fieldIn = SqlComparable.isIn -{- | - Operator alias for 'fieldIn'. +{- | Operator alias for 'fieldIn'. @since 1.0.0.0 -} @@ -1026,19 +1018,14 @@ infixl 9 .<- -{- | - Checks that a field does not match a list of values. +{- | Checks that a field does not match a list of values. @since 1.0.0.0 -} fieldNotIn :: FieldDefinition nullability a -> NonEmpty a -> Expr.BooleanExpr -fieldNotIn fieldDef values = - Expr.valueNotIn - (fieldColumnReference fieldDef) - (fmap (fieldValueToExpression fieldDef) values) +fieldNotIn = SqlComparable.isNotIn -{- | - Operator alias for 'fieldNotIn'. +{- | Operator alias for 'fieldNotIn'. @since 1.0.0.0 -} @@ -1047,8 +1034,7 @@ infixl 9 . NonEmpty (a, b) -> Expr.BooleanExpr -fieldTupleIn fieldDefA fieldDefB values = - Expr.tupleIn - (fieldColumnReference fieldDefA :| [fieldColumnReference fieldDefB]) - (fmap (toSqlValueTuple fieldDefA fieldDefB) values) +fieldTupleIn = + SqlComparable.tupleIn -{- | - Checks that a tuple of two fields is not in the list of specified tuples. +{- | Checks that a tuple of two fields is not in the list of specified tuples. @since 1.0.0.0 -} @@ -1072,27 +1055,9 @@ FieldDefinition nullabilityB b -> NonEmpty (a, b) -> Expr.BooleanExpr -fieldTupleNotIn fieldDefA fieldDefB values = - Expr.tupleNotIn - (fieldColumnReference fieldDefA :| [fieldColumnReference fieldDefB]) - (fmap (toSqlValueTuple fieldDefA fieldDefB) values) - -{- | - Constructs a SqlValue "tuple" (i.e. NonEmpty list) for two fields. - -@since 1.0.0.0 --} -toSqlValueTuple :: - FieldDefinition nullabilityA a -> - FieldDefinition nullabilityB b -> - (a, b) -> - NonEmpty Expr.ValueExpression -toSqlValueTuple fieldDefA fieldDefB (a, b) = - fieldValueToExpression fieldDefA a - :| [fieldValueToExpression fieldDefB b] +fieldTupleNotIn = SqlComparable.tupleNotIn -{- | - Constructs a field-based 'Expr.BooleanExpr' using a function that +{- | Constructs a field-based 'Expr.BooleanExpr' using a function that builds a 'Expr.BooleanExpr'. @since 1.0.0.0 @@ -1100,17 +1065,143 @@ whereColumnComparison :: (Expr.ValueExpression -> Expr.ValueExpression -> Expr.BooleanExpr) -> (FieldDefinition nullability a -> a -> Expr.BooleanExpr) -whereColumnComparison columnComparison fieldDef a = +whereColumnComparison columnComparison fieldDef = columnComparison - (fieldColumnReference fieldDef) - (fieldValueToExpression fieldDef a) + (SqlComparable.referenceValueExpression fieldDef) + . fieldValueToExpression fieldDef -{-- | - Orders a query by the column name for the given field. ---} +{- | Orders a query by the column name for the given field. This is a type-specific +alias for 'SqlComparable.orderBySqlComparable' + +@since 1.0.0.0 +-} orderByField :: FieldDefinition nullability value -> Expr.OrderByDirection -> Expr.OrderByExpr orderByField = - Expr.orderByColumnName . fieldColumnName + SqlComparable.orderBySqlComparable + +{- | A type class that allows different types to be used as qualifiers for column names. +This is often used in conjuction with 'QualifiedFieldDefinition' to represent a +'FieldDefinition' whose reference needs to be qualified in a SQL query involving +multiple tables. + +Instances are provided for table 'TableIdentifier.TableIdentifier' and +'AliasName.AliasName' so that either can be used a qualifiers for fields. + +@since 1.1.0.0 +-} +class FieldQualifier qualifier where + qualifyColumnName :: qualifier -> Expr.ColumnName -> Expr.Qualified Expr.ColumnName + +{- | + +@since 1.1.0.0 +-} +instance FieldQualifier TableIdentifier.TableIdentifier where + qualifyColumnName tableId = + Expr.qualifyColumn + (TableIdentifier.tableIdSchemaName tableId) + (TableIdentifier.tableIdUnqualifiedName tableId) + +{- | + +@since 1.1.0.0 +-} +instance FieldQualifier AliasName.AliasName where + qualifyColumnName = + Expr.aliasQualifyColumn . AliasName.aliasNameToAliasExpr + +{- | A 'FieldDefinition' paired with a 'qualifier' so SQL references to the field +will be qualified. A 'SqlComparable.SqlComparable' instance is provided so that +'QualifiedFieldDefinition' can be used with the SQL comparison and ordering +functions offered by 'Sql.Comparable.SqlComparable'. + +See Also: 'qualifyField', 'FieldQualifier' + +@since 1.1.0.0 +-} +data QualifiedFieldDefinition qualifier nullability a = QualifiedFieldDefinition + { i_fieldQualifier :: qualifier + , i_unqualifiedDefinition :: FieldDefinition nullability a + } + +{- | Constructs a 'QualifiedFieldDefinition' that will qualify the field with +the specified qualifier. Generally speaking, the 'qualifier' will need to +provide an instance of 'FieldQualifier' for the constructed 'QualifiedFieldDefinition' +to be of use. + +@since 1.1.0.0 +-} +qualifyField :: + qualifier -> + FieldDefinition nullability a -> + QualifiedFieldDefinition qualifier nullability a +qualifyField = + QualifiedFieldDefinition + +{- | Generates the SQL expression to refer to the column represented by a +'QualifiedFieldDefinition'. The column will be qualified using the 'qualifier' +that was passed to 'qualifyField'. + +@since 1.1.0.0 +-} +qualifiedFieldColumnName :: + FieldQualifier qualifier => + QualifiedFieldDefinition qualifier nullability a -> + Expr.Qualified Expr.ColumnName +qualifiedFieldColumnName qualifiedFieldDef = + qualifyColumnName + (i_fieldQualifier qualifiedFieldDef) + (fieldColumnName (i_unqualifiedDefinition qualifiedFieldDef)) + +{- | + +@since 1.1.0.0 +-} +instance FieldQualifier qualifier => SqlComparable.SqlComparable (QualifiedFieldDefinition qualifier nullability a) a where + toComparableSqlValue = + toComparableSqlValue . i_unqualifiedDefinition + + referenceValueExpression = + Expr.columnReference . Expr.untrackQualified . qualifiedFieldColumnName + +{- | INTERNAL: This type is an internal tracking of if a column is an identity column. We tie this to + the nullability because a nullable column is not allowed to be an identity column. + +@since 1.1.0.0 +-} +data IdentityGADT nullability where + IsIdentityGADT :: FieldIdentityGeneration -> IdentityGADT NotNull + AllowedIdentityButNotSetGADT :: IdentityGADT NotNull + NotIdentityGADT :: IdentityGADT Nullable + +{- | Get the 'FieldIdentityGeneration', if there is one, of a 'FieldDefinition'. + +@since 1.1.0.0 +-} +fieldIdentityGeneration :: FieldDefinition nullability a -> Maybe FieldIdentityGeneration +fieldIdentityGeneration fieldDef = + case i_fieldIdentity fieldDef of + AllowedIdentityButNotSetGADT -> Nothing + NotIdentityGADT -> Nothing + IsIdentityGADT colId -> Just colId + +{- | Represents how the identity field be will generated. + +@since 1.1.0.0 +-} +data FieldIdentityGeneration + = -- | The field will always be generated, and user supplied values during write for it is expressly not allowed. + -- + -- @since 1.1.0.0 + GeneratedAlways + | -- | The field will be generated by default, allowing for user defined values for writes will be allowed. + -- + -- @since 1.1.0.0 + GeneratedByDefault + deriving + ( -- | @since 1.1.0.0 + Eq + ) diff --git a/src/Orville/PostgreSQL/Marshall/MarshallError.hs b/src/Orville/PostgreSQL/Marshall/MarshallError.hs --- a/src/Orville/PostgreSQL/Marshall/MarshallError.hs +++ b/src/Orville/PostgreSQL/Marshall/MarshallError.hs @@ -1,5 +1,5 @@ {- | -Copyright : Flipstone Technology Partners 2023 +Copyright : Flipstone Technology Partners 2023-2025 License : MIT Stability : Stable @@ -20,14 +20,14 @@ import Control.Exception (Exception) import qualified Data.ByteString.Char8 as B8 import qualified Data.List as List +import qualified Data.List.NonEmpty as NE import qualified Data.Set as Set import Orville.PostgreSQL.ErrorDetailLevel (ErrorDetailLevel, redactErrorMessage, redactIdentifierValue, redactNonIdentifierValue, redactSchemaName) import qualified Orville.PostgreSQL.Raw.PgTextFormatValue as PgTextFormatValue import qualified Orville.PostgreSQL.Raw.SqlValue as SqlValue -{- | - A 'MarshallError' may be returned from +{- | A 'MarshallError' may be returned from 'Orville.PostgreSQL.Marshall.marshallResultFromSql' when a row being decoded from the database doesn't meet the expectations of the 'Orville.PostgreSQL.Marshall.SqlMarshaller' that is decoding it. @@ -55,8 +55,7 @@ instance Exception MarshallError -{- | - Renders a 'MarshallError' to a string using the specified 'ErrorDetailLevel'. +{- | Renders a 'MarshallError' to a string using the specified 'ErrorDetailLevel'. This ignores any 'ErrorDetailLevel' that was captured by default from the Orville context and uses the specified level of detail instead. @@ -74,7 +73,7 @@ renderMarshallError detailLevel marshallError = let presentableRowId = - map + fmap (presentSqlColumnValue detailLevel redactIdentifierValue) (marshallErrorRowIdentifier marshallError) in @@ -85,8 +84,7 @@ , renderMarshallErrorDetails detailLevel (marshallErrorDetails marshallError) ] -{- | - A internal helper to present a redacted column name and sql value in an error +{- | A internal helper to present a redacted column name and sql value in an error message. The redacter function is passed as an argument here so that this function can be used to present either ID values or general values as required by the context of the caller. @@ -102,18 +100,17 @@ let sqlValueString = redacter detailLevel $ - case SqlValue.toPgValue sqlValue of - Nothing -> - "NULL" - Just pgValue -> - B8.unpack . PgTextFormatValue.toByteString $ pgValue + SqlValue.foldSqlValue + (B8.unpack . PgTextFormatValue.toByteString) + (\vals -> "(" <> List.intercalate ", " (NE.toList vals) <> ")") + "NULL" + sqlValue in redactSchemaName detailLevel (B8.unpack columnName) <> " = " <> sqlValueString -{- | - A 'MarshallErrorDetails' may be returned from +{- | A 'MarshallErrorDetails' may be returned from 'Orville.PostgreSQL.Marshall.marshallResultFromSql' if the result set being decoded from the database doesn't meet the expectations of the 'Orville.PostgreSQL.Marshall.SqlMarshaller' that is decoding it. @@ -127,8 +124,7 @@ | -- | Indicates that an expected column was not found in the result set. MissingColumnError MissingColumnErrorDetails -{- | - Renders a 'MarshallErrorDetails' to a 'String' with a specified +{- | Renders a 'MarshallErrorDetails' to a 'String' with a specified 'ErrorDetailLevel'. @since 1.0.0.0 @@ -139,8 +135,7 @@ DecodingError details -> renderDecodingErrorDetails detailLevel details MissingColumnError details -> renderMissingColumnErrorDetails detailLevel details -{- | - Details about an error that occurred while decoding values found in a SQL +{- | Details about an error that occurred while decoding values found in a SQL result set. @since 1.0.0.0 @@ -150,8 +145,7 @@ , decodingErrorMessage :: String } -{- | - Renders a 'DecodingErrorDetails' to a 'String' with a specified +{- | Renders a 'DecodingErrorDetails' to a 'String' with a specified 'ErrorDetailLevel'. @since 1.0.0.0 @@ -160,7 +154,7 @@ renderDecodingErrorDetails detailLevel details = let presentableErrorValues = - map + fmap (presentSqlColumnValue detailLevel redactNonIdentifierValue) (decodingErrorValues details) in @@ -172,19 +166,17 @@ , "]" ] -{- | - Details about a column that was found to be missing in a SQL result set +{- | Details about a column that was found to be missing in a SQL result set during decoding. @since 1.0.0.0 -} data MissingColumnErrorDetails = MissingColumnErrorDetails { missingColumnName :: B8.ByteString - , actualColumnNames :: (Set.Set B8.ByteString) + , actualColumnNames :: Set.Set B8.ByteString } -{- | - Renders a 'MissingColumnErrorDetails' to a 'String' with a specified +{- | Renders a 'MissingColumnErrorDetails' to a 'String' with a specified 'ErrorDetailLevel'. @since 1.0.0.0 @@ -193,7 +185,7 @@ renderMissingColumnErrorDetails detailLevel details = let presentableActualNames = - map + fmap (redactSchemaName detailLevel . B8.unpack) (Set.toList $ actualColumnNames details) in diff --git a/src/Orville/PostgreSQL/Marshall/SqlComparable.hs b/src/Orville/PostgreSQL/Marshall/SqlComparable.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Marshall/SqlComparable.hs @@ -0,0 +1,305 @@ +{-# LANGUAGE FunctionalDependencies #-} + +{- | +Copyright : Flipstone Technology Partners 2024-2025 +License : MIT +Stability : Stable + +@since 1.1.0.0 +-} +module Orville.PostgreSQL.Marshall.SqlComparable + ( SqlComparable (toComparableSqlValue, referenceValueExpression) + , toSqlValueTuple + , equals + , notEquals + , isDistinctFrom + , isNotDistinctFrom + , lessThan + , lessThanOrEqualTo + , greaterThan + , greaterThanOrEqualTo + , isIn + , isNotIn + , isNull + , isNotNull + , like + , likeInsensitive + , tupleIn + , tupleNotIn + , orderBySqlComparable + ) where + +import Data.List.NonEmpty (NonEmpty ((:|))) +import qualified Data.Text as T + +import qualified Orville.PostgreSQL.Expr as Expr +import qualified Orville.PostgreSQL.Raw.SqlValue as SqlValue + +{- | This provides a common interface to being able to produce a 'SqlValue.SqlValue' as well as having +a way to reference the item in SQL. This can be something like a field of a table, a field that +should be referenced via an alias, or a subquery. + +Here the first argument to the class should be some abstraction over some part of SQL that produces +a Haskell value. With the type of the Haskell value as the second argument. + +@since 1.1.0.0 +-} +class SqlComparable sqlAbstraction haskellValue | sqlAbstraction -> haskellValue where + -- | Uses the first argument to marshall a Haskell value its 'SqlValue.SqlValue' representation. + -- + -- @since 1.1.0.0 + toComparableSqlValue :: sqlAbstraction -> haskellValue -> SqlValue.SqlValue + + -- | Constructs the 'Expr.ValueExpression' for use in SQL expressions from the + -- "Orville.PostgreSQL.Expr" module. + -- + -- @since 1.1.0.0 + referenceValueExpression :: sqlAbstraction -> Expr.ValueExpression + +{- | Constructs a SqlValue "tuple" (i.e. NonEmpty list) for two items that can themselves be made to 'SqlValue.SqlValue'. + +@since 1.1.0.0 +-} +toSqlValueTuple :: + (SqlComparable a c, SqlComparable b d) => + a -> + b -> + (c, d) -> + NonEmpty Expr.ValueExpression +toSqlValueTuple a b (c, d) = + Expr.valueExpression (toComparableSqlValue a c) + :| [Expr.valueExpression $ toComparableSqlValue b d] + +{- | Checks that the referenced item from the first argument does not equal the SQL value of the + second argument. This is commonly used in a @WHERE@ clause such as @WHERE foo = 1@. Frequently you + would not want to use this directly, but instead use + 'Orville.PostgreSQL.Marshall.FieldDefinition.fieldEquals'. + +@since 1.1.0.0 +-} +equals :: SqlComparable a b => a -> b -> Expr.BooleanExpr +equals a = + Expr.equals + (referenceValueExpression a) + . Expr.valueExpression + . toComparableSqlValue a + +{- | Checks that the referenced item from the first argument does not equal the SQL value of the + second argument. This is commonly used with columns as you might in a @WHERE@ clause such as + @WHERE foo != 1@. Frequently you would not want to use this directly, but instead use + 'Orville.PostgreSQL.Marshall.FieldDefinition.fieldNotEquals'. + +@since 1.1.0.0 +-} +notEquals :: SqlComparable a b => a -> b -> Expr.BooleanExpr +notEquals a = + Expr.notEquals + (referenceValueExpression a) + . Expr.valueExpression + . toComparableSqlValue a + +{- | Checks that the referenced item from the first argument is distinct from the SQL value of the + second argument. This is commonly used with columns as you might in a @WHERE@ clause such as + @WHERE foo IS DISTINCT FROM 1@. Frequently you would not want to use this directly, but instead use + 'Orville.PostgreSQL.Marshall.FieldDefinition.fieldIsDistinctFrom'. + +@since 1.1.0.0 +-} +isDistinctFrom :: SqlComparable a b => a -> b -> Expr.BooleanExpr +isDistinctFrom a = + Expr.isDistinctFrom + (referenceValueExpression a) + . Expr.valueExpression + . toComparableSqlValue a + +{- | Checks that the referenced item from the first argument is not distinct from the SQL value of the + second argument. This is commonly used with columns as you might in a @WHERE@ clause such as + @WHERE foo IS NOT DISTINCT FROM 1@. Frequently you would not want to use this directly, but instead + use 'Orville.PostgreSQL.Marshall.FieldDefinition.fieldIsNotDistinctFrom'. + +@since 1.1.0.0 +-} +isNotDistinctFrom :: SqlComparable a b => a -> b -> Expr.BooleanExpr +isNotDistinctFrom a = + Expr.isNotDistinctFrom + (referenceValueExpression a) + . Expr.valueExpression + . toComparableSqlValue a + +{- | Checks that the referenced item from the first argument is less than the SQL value of the + second argument. This is commonly used with columns as you might in a @WHERE@ clause such as + @WHERE foo < 1@. Frequently you would not want to use this directly, but instead + use 'Orville.PostgreSQL.Marshall.FieldDefinition.fieldLessThan'. + +@since 1.1.0.0 +-} +lessThan :: SqlComparable a b => a -> b -> Expr.BooleanExpr +lessThan a = + Expr.lessThan + (referenceValueExpression a) + . Expr.valueExpression + . toComparableSqlValue a + +{- | Checks that the referenced item from the first argument is less than or equal to the SQL value of + the second argument. This is commonly used with columns as you might in a @WHERE@ clause such as + @WHERE foo <= 1@. Frequently you would not want to use this directly, but instead use + 'Orville.PostgreSQL.Marshall.FieldDefinition.fieldLessThanOrEqualTo'. + +@since 1.1.0.0 +-} +lessThanOrEqualTo :: SqlComparable a b => a -> b -> Expr.BooleanExpr +lessThanOrEqualTo a = + Expr.lessThanOrEqualTo + (referenceValueExpression a) + . Expr.valueExpression + . toComparableSqlValue a + +{- | Checks that the referenced item from the first argument is greater than the SQL value of the + second argument. This is commonly used with columns as you might in a @WHERE@ clause such as + @WHERE foo > 1@. Frequently you would not want to use this directly, but instead use + 'Orville.PostgreSQL.Marshall.FieldDefinition.fieldGreaterThan'. + +@since 1.1.0.0 +-} +greaterThan :: SqlComparable a b => a -> b -> Expr.BooleanExpr +greaterThan a = + Expr.greaterThan + (referenceValueExpression a) + . Expr.valueExpression + . toComparableSqlValue a + +{- | Checks that the referenced item from the first argument is greater than or equal to the SQL value + of the second argument. This is commonly used with columns as you might in a @WHERE@ clause such + as @WHERE foo >= 1@. Frequently you would not want to use this directly, but instead use + 'Orville.PostgreSQL.Marshall.FieldDefinition.fieldGreaterThanOrEqualTo'. + +@since 1.1.0.0 +-} +greaterThanOrEqualTo :: SqlComparable a b => a -> b -> Expr.BooleanExpr +greaterThanOrEqualTo a = + Expr.greaterThanOrEqualTo + (referenceValueExpression a) + . Expr.valueExpression + . toComparableSqlValue a + +{- | Checks that the referenced item from the first argument is in the list of the SQL values + of the second argument. This is commonly used with columns as you might in a @WHERE@ clause such + as @WHERE foo IN (1,2)@. Frequently you would not want to use this directly, but instead use + 'Orville.PostgreSQL.Marshall.FieldDefinition.fieldIn'. + +@since 1.1.0.0 +-} +isIn :: SqlComparable a b => a -> NonEmpty b -> Expr.BooleanExpr +isIn a = + Expr.valueIn + (referenceValueExpression a) + . fmap (Expr.valueExpression . toComparableSqlValue a) + +{- | Checks that the referenced item from the first argument is not in the list of the SQL values + of the second argument. This is commonly used with columns as you might in a @WHERE@ clause such + as @WHERE foo NOT IN (1,2)@. Frequently you would not want to use this directly, but instead use + 'Orville.PostgreSQL.Marshall.FieldDefinition.fieldNotIn'. + +@since 1.1.0.0 +-} +isNotIn :: SqlComparable a b => a -> NonEmpty b -> Expr.BooleanExpr +isNotIn a = + Expr.valueNotIn + (referenceValueExpression a) + . fmap (Expr.valueExpression . toComparableSqlValue a) + +{- | Checks that the referenced item is null. This is commonly used with columns as you might in a + @WHERE@ clause such as @WHERE foo IS NULL@. Frequently you would not want to use this directly, + but instead use 'Orville.PostgreSQL.Marshall.FieldDefinition.fieldIsNull'. + +@since 1.1.0.0 +-} +isNull :: SqlComparable a b => a -> Expr.BooleanExpr +isNull = + Expr.isNull . referenceValueExpression + +{- | Checks that the referenced item is not null. This is commonly used with columns as you might in a + @WHERE@ clause such as @WHERE foo IS NOT NULL@. Frequently you would not want to use this + directly, but instead use 'Orville.PostgreSQL.Marshall.FieldDefinition.fieldIsNotNull'. + +@since 1.1.0.0 +-} +isNotNull :: SqlComparable a b => a -> Expr.BooleanExpr +isNotNull = + Expr.isNotNull . referenceValueExpression + +{- | Checks that the referenced item matches the given like pattern case sensitively. This is + commonly used with columns as you might in a @WHERE@ clause such as @WHERE foo LIKE + 'bar'@. Frequently you would not want to use this directly, but instead use + 'Orville.PostgreSQL.Marshall.FieldDefinition.fieldLike'. + +@since 1.1.0.0 +-} +like :: SqlComparable a b => a -> T.Text -> Expr.BooleanExpr +like a = + Expr.like + (referenceValueExpression a) + . Expr.valueExpression + . SqlValue.fromText + +{- | Checks that the referenced item matches the given like pattern case insensitively. This is + commonly used with columns as you might in a @WHERE@ clause such as @WHERE foo ILIKE + 'bar'@. Frequently you would not want to use this directly, but instead use + 'Orville.PostgreSQL.Marshall.FieldDefinition.fieldLikeInsensitive'. + +@since 1.1.0.0 +-} +likeInsensitive :: SqlComparable a b => a -> T.Text -> Expr.BooleanExpr +likeInsensitive a = + Expr.likeInsensitive + (referenceValueExpression a) + . Expr.valueExpression + . SqlValue.fromText + +{- | Checks that the referenced items from the first two arguments are in the SQL values of the + given list of tuples. This is commonly used with columns as you might in a @WHERE@ clause such as + @WHERE (foo, bar) IN ((1,2), (3,4))@. Frequently you would not want to use this directly, but + instead use 'Orville.PostgreSQL.Marshall.FieldDefinition.fieldTupleIn'. + +@since 1.1.0.0 +-} +tupleIn :: + (SqlComparable a c, SqlComparable b d) => + a -> + b -> + NonEmpty (c, d) -> + Expr.BooleanExpr +tupleIn a b = + Expr.tupleIn + (referenceValueExpression a :| [referenceValueExpression b]) + . fmap (toSqlValueTuple a b) + +{- | Checks that the referenced items from the first two arguments are not in the SQL values of the + given list of tuples. This is commonly used with columns as you might in a @WHERE@ clause such as + @WHERE (foo, bar) IN ((1,2), (3,4))@. Frequently you would not want to use this directly, but + instead use 'Orville.PostgreSQL.Marshall.FieldDefinition.fieldTupleNotIn'. + +@since 1.1.0.0 +-} +tupleNotIn :: + (SqlComparable a c, SqlComparable b d) => + a -> + b -> + NonEmpty (c, d) -> + Expr.BooleanExpr +tupleNotIn a b = + Expr.tupleNotIn + (referenceValueExpression a :| [referenceValueExpression b]) + . fmap (toSqlValueTuple a b) + +{- | Orders a query by the 'referenceValueExpression' given by the 'comparable'. + +@since 1.1.0.0 +-} +orderBySqlComparable :: + SqlComparable comparable value => + comparable -> + Expr.OrderByDirection -> + Expr.OrderByExpr +orderBySqlComparable = + Expr.orderByValueExpression . referenceValueExpression diff --git a/src/Orville/PostgreSQL/Marshall/SqlMarshaller.hs b/src/Orville/PostgreSQL/Marshall/SqlMarshaller.hs --- a/src/Orville/PostgreSQL/Marshall/SqlMarshaller.hs +++ b/src/Orville/PostgreSQL/Marshall/SqlMarshaller.hs @@ -1,8 +1,10 @@ +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {- | -Copyright : Flipstone Technology Partners 2023 +Copyright : Flipstone Technology Partners 2023-2025 License : MIT Stability : Stable @@ -35,6 +37,7 @@ , marshallNested , marshallMaybe , marshallPartial + , marshallQualifyFields , prefixMarshaller , ReadOnlyColumnOption (IncludeReadOnlyColumns, ExcludeReadOnlyColumns) , collectFromField @@ -48,11 +51,22 @@ , applyRowSource , constRowSource , failRowSource + , marshallerEquals + , marshallerNotEquals + , marshallerIsDistinctFrom + , marshallerIsNotDistinctFrom + , marshallerLessThan + , marshallerLessThanOrEqualTo + , marshallerGreaterThan + , marshallerGreaterThanOrEqualTo + , marshallerIn + , marshallerNotIn ) where import Control.Monad (join) import qualified Data.ByteString.Char8 as B8 +import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes) import qualified Data.Set as Set @@ -61,14 +75,15 @@ import Orville.PostgreSQL.Execution.ExecutionResult (Column (Column), ExecutionResult, Row (Row)) import qualified Orville.PostgreSQL.Execution.ExecutionResult as Result import qualified Orville.PostgreSQL.Expr as Expr -import Orville.PostgreSQL.Marshall.FieldDefinition (FieldDefinition, FieldName, FieldNullability (NotNullField, NullableField), asymmetricNullableField, fieldColumnName, fieldName, fieldNameToByteString, fieldNameToColumnName, fieldNullability, fieldTableConstraints, fieldValueFromSqlValue, nullableField, prefixField, setField) +import Orville.PostgreSQL.Marshall.FieldDefinition (FieldDefinition, FieldName, FieldNullability (NotNullField, NullableField), FieldQualifier, asymmetricNullableField, fieldColumnName, fieldName, fieldNameToByteString, fieldNameToColumnName, fieldNullability, fieldTableConstraints, fieldValueFromSqlValue, nullableField, prefixField, qualifiedFieldColumnName, qualifyField, setField) import qualified Orville.PostgreSQL.Marshall.MarshallError as MarshallError -import Orville.PostgreSQL.Marshall.SyntheticField (SyntheticField, nullableSyntheticField, prefixSyntheticField, syntheticFieldAlias, syntheticFieldExpression, syntheticFieldValueFromSqlValue) +import qualified Orville.PostgreSQL.Marshall.SqlComparable as SqlComparable +import Orville.PostgreSQL.Marshall.SyntheticField (SyntheticField, nullableSyntheticField, prefixSyntheticField, syntheticFieldExpression, syntheticFieldName, syntheticFieldValueFromSqlValue) import qualified Orville.PostgreSQL.Raw.SqlValue as SqlValue import qualified Orville.PostgreSQL.Schema.ConstraintDefinition as ConstraintDefinition +import qualified Orville.PostgreSQL.Schema.TableIdentifier as TableIdentifier -{- | - An 'AnnotatedSqlMarshaller' is a 'SqlMarshaller' that contains extra +{- | An 'AnnotatedSqlMarshaller' is a 'SqlMarshaller' that contains extra annotations which cannot necessarily be determined from the data in the marshaller itself. In particular, it includes the names of fields that can be used to identify a row in the database when an error is encountered during @@ -88,8 +103,7 @@ , unannotatedSqlMarshaller :: SqlMarshaller writeEntity readEntity } -{- | - Creates an 'AnnotatedSqlMarshaller' that will use the given column names +{- | Creates an 'AnnotatedSqlMarshaller' that will use the given column names to identify rows in error messages when decoding fails. Any column names in the list that are not present in the result set will simply be omitted from the error message. @@ -103,8 +117,7 @@ annotateSqlMarshaller = AnnotatedSqlMarshaller -{- | - Creates an 'AnnotatedSqlMarshaller' that will identify rows in decoding +{- | Creates an 'AnnotatedSqlMarshaller' that will identify rows in decoding errors by any columns. This is the equivalent of @annotateSqlMarshaller []@. @since 1.0.0.0 @@ -115,8 +128,7 @@ annotateSqlMarshallerEmptyAnnotation = annotateSqlMarshaller [] -{- | - Applies the provided function to a 'SqlMarshaller' that has been annotated, +{- | Applies the provided function to a 'SqlMarshaller' that has been annotated, preserving the annotations. @since 1.0.0.0 @@ -128,8 +140,7 @@ mapSqlMarshaller f (AnnotatedSqlMarshaller rowIdFields marshaller) = AnnotatedSqlMarshaller rowIdFields (f marshaller) -{- | - 'SqlMarshaller' is how we group the lowest-level translation of single fields +{- | 'SqlMarshaller' is how we group the lowest-level translation of single fields into a higher-level marshalling of full SQL records into Haskell records. This is a flexible abstraction that allows us to ultimately model SQL tables and work with them as potentially nested Haskell records. We can then @@ -156,16 +167,64 @@ MarshallPartial :: SqlMarshaller a (Either String b) -> SqlMarshaller a b -- | Marshall a column that is read-only, like auto-incrementing ids. MarshallReadOnly :: SqlMarshaller a b -> SqlMarshaller c b + -- | Apply an qualifier to all the fields of a marshaller + MarshallQualifyFields :: + FieldQualifier qualifier => + qualifier -> + SqlMarshaller a b -> + SqlMarshaller a b +-- | @since 1.0.0.0 instance Functor (SqlMarshaller a) where - fmap f marsh = MarshallApply (MarshallPure f) marsh + fmap f = MarshallApply (MarshallPure f) +-- | @since 1.0.0.0 instance Applicative (SqlMarshaller a) where pure = MarshallPure (<*>) = MarshallApply -{- | - Returns a list of 'Expr.DerivedColumn' expressions that can be used in a +{- | Marshallers with no natural columns will result in @null@ 'SqlValue.SqlValue' and + 'Expr.ValueExpression' as the outputs of 'SqlComparable.toComparableSqlValue' and + 'SqlComparable.referenceValueExpression', respectively. + + Both methods exclude columns marshalled with 'marshallReadOnly'. + +@since 1.1.0.0 +-} +instance SqlComparable.SqlComparable (SqlMarshaller writeEntity readEntity) writeEntity where + toComparableSqlValue marshaller writeEntity = + let + collectSqlVals marshallerField vals = + case marshallerField of + Natural _ fieldDef (Just getField) -> + SqlComparable.toComparableSqlValue fieldDef (getField writeEntity) : vals + _ -> vals + in + maybe + SqlValue.sqlNull + SqlValue.fromRow + (NE.nonEmpty $ foldMarshallerFields marshaller [] collectSqlVals) + + referenceValueExpression marshaller = + let + colValExprs = + foldMarshallerFields marshaller [] $ + collectFromField + ExcludeReadOnlyColumns + ( \mbQualifier fieldDef -> + case mbQualifier of + Nothing -> SqlComparable.referenceValueExpression fieldDef + Just qualifier -> + SqlComparable.referenceValueExpression $ + qualifyField qualifier fieldDef + ) + in + maybe + (Expr.valueExpression SqlValue.sqlNull) + Expr.rowValueConstructor + (NE.nonEmpty colValExprs) + +{- | Returns a list of 'Expr.DerivedColumn' expressions that can be used in a select statement to select values from the database for the 'SqlMarshaller' decode. @@ -182,19 +241,27 @@ [Expr.DerivedColumn] collectDerivedColumn entry columns = case entry of - Natural fieldDef _ -> - (Expr.deriveColumn . Expr.columnReference . fieldColumnName $ fieldDef) - : columns + Natural mbQualifier fieldDef _ -> + let + colName = + case mbQualifier of + Nothing -> Expr.unqualified (fieldColumnName fieldDef) + Just qualifier -> + Expr.untrackQualified + . qualifiedFieldColumnName + . qualifyField qualifier + $ fieldDef + in + Expr.deriveColumn (Expr.columnReference colName) : columns Synthetic synthField -> Expr.deriveColumnAs (syntheticFieldExpression synthField) - (fieldNameToColumnName $ syntheticFieldAlias synthField) + (fieldNameToColumnName . syntheticFieldName $ synthField) : columns in foldMarshallerFields marshaller [] collectDerivedColumn -{- | - Returns the table constraints for all the 'FieldDefinition's used in the +{- | Returns the table constraints for all the 'FieldDefinition's used in the 'SqlMarshaller'. @since 1.0.0.0 @@ -210,7 +277,7 @@ ConstraintDefinition.TableConstraints collectTableConstraints entry constraints = case entry of - Natural fieldDef _ -> constraints <> fieldTableConstraints fieldDef + Natural _ fieldDef _ -> constraints <> fieldTableConstraints fieldDef Synthetic _synthField -> constraints in foldMarshallerFields @@ -218,19 +285,17 @@ ConstraintDefinition.emptyTableConstraints collectTableConstraints -{- | - Represents a primitive entry in a 'SqlMarshaller'. This type is used with +{- | Represents a primitive entry in a 'SqlMarshaller'. This type is used with 'foldMarshallerFields' to provided the entry from the marshaller to the folding function to be incorporated in the result of the fold. @since 1.0.0.0 -} data MarshallerField writeEntity where - Natural :: FieldDefinition nullability a -> Maybe (writeEntity -> a) -> MarshallerField writeEntity + Natural :: FieldQualifier qualifier => Maybe qualifier -> FieldDefinition nullability a -> Maybe (writeEntity -> a) -> MarshallerField writeEntity Synthetic :: SyntheticField a -> MarshallerField writeEntity -{- | - A fold function that can be used with 'foldMarshallerFields' to collect +{- | A fold function that can be used with 'foldMarshallerFields' to collect a value calculated from a 'FieldDefinition' via the given function. The calculated value is added to the list of values being built. @@ -242,23 +307,22 @@ -} collectFromField :: ReadOnlyColumnOption -> - (forall nullability a. FieldDefinition nullability a -> result) -> + (forall qualifier nullability a. FieldQualifier qualifier => Maybe qualifier -> FieldDefinition nullability a -> result) -> MarshallerField entity -> [result] -> [result] collectFromField readOnlyColumnOption fromField entry results = case entry of - Natural fieldDef (Just _) -> - fromField fieldDef : results - Natural fieldDef Nothing -> + Natural mbQualifier fieldDef (Just _) -> + fromField mbQualifier fieldDef : results + Natural mbQualifier fieldDef Nothing -> case readOnlyColumnOption of - IncludeReadOnlyColumns -> fromField fieldDef : results + IncludeReadOnlyColumns -> fromField mbQualifier fieldDef : results ExcludeReadOnlyColumns -> results Synthetic _ -> results -{- | - Uses the field definitions in the marshaller to construct SQL expressions +{- | Uses the field definitions in the marshaller to construct SQL expressions that will set columns of the field definitions to their corresponding values found in the Haskell @writeEntity@ value. @@ -274,8 +338,7 @@ [] (collectSetClauses writeEntity) -{- | - An internal helper function that collects the 'Expr.SetClause's to +{- | An internal helper function that collects the 'Expr.SetClause's to update all the fields contained in a 'SqlMarshaller' @since 1.0.0.0 @@ -287,15 +350,14 @@ [Expr.SetClause] collectSetClauses entity entry clauses = case entry of - Natural fieldDef (Just accessor) -> + Natural _ fieldDef (Just accessor) -> setField fieldDef (accessor entity) : clauses - Natural _ Nothing -> + Natural _ _ Nothing -> clauses Synthetic _ -> clauses -{- | - Specifies whether read-only fields should be included when using functions +{- | Specifies whether read-only fields should be included when using functions such as 'collectFromField'. @since 1.0.0.0 @@ -304,8 +366,7 @@ = IncludeReadOnlyColumns | ExcludeReadOnlyColumns -{- | - 'foldMarshallerFields' allows you to consume the 'FieldDefinition's that +{- | 'foldMarshallerFields' allows you to consume the 'FieldDefinition's that are contained within the 'SqlMarshaller' to process them however is required. This can be used to collect the names of all the fields, encode them to 'SqlValue.SqlValue', etc. @@ -318,10 +379,12 @@ (MarshallerField writeEntity -> result -> result) -> result foldMarshallerFields marshaller = - foldMarshallerFieldsPart marshaller (Just id) + foldMarshallerFieldsPart + (Nothing :: Maybe TableIdentifier.TableIdentifier) + marshaller + (Just id) -{- | - The internal helper function that actually implements 'foldMarshallerFields'. +{- | The internal helper function that actually implements 'foldMarshallerFields'. It takes with it a function that extracts the current nesting entity from the overall @writeEntity@ that the 'SqlMarshaller' is build on. 'MarshallNest' adds more nesting by composing its accessor with the one given here. @@ -329,36 +392,39 @@ @since 1.0.0.0 -} foldMarshallerFieldsPart :: + FieldQualifier qualifier => + Maybe qualifier -> SqlMarshaller entityPart readEntity -> Maybe (writeEntity -> entityPart) -> result -> (MarshallerField writeEntity -> result -> result) -> result -foldMarshallerFieldsPart marshaller getPart currentResult addToResult = +foldMarshallerFieldsPart mbQualifier marshaller getPart currentResult addToResult = case marshaller of MarshallPure _ -> currentResult MarshallApply submarshallerA submarshallerB -> let subresultB = - foldMarshallerFieldsPart submarshallerB getPart currentResult addToResult + foldMarshallerFieldsPart mbQualifier submarshallerB getPart currentResult addToResult in - foldMarshallerFieldsPart submarshallerA getPart subresultB addToResult + foldMarshallerFieldsPart mbQualifier submarshallerA getPart subresultB addToResult MarshallNest nestingFunction submarshaller -> - foldMarshallerFieldsPart submarshaller (fmap (nestingFunction .) getPart) currentResult addToResult + foldMarshallerFieldsPart mbQualifier submarshaller (fmap (nestingFunction .) getPart) currentResult addToResult MarshallField fieldDefinition -> - addToResult (Natural fieldDefinition getPart) currentResult + addToResult (Natural mbQualifier fieldDefinition getPart) currentResult MarshallSyntheticField syntheticField -> addToResult (Synthetic syntheticField) currentResult MarshallMaybeTag m -> - foldMarshallerFieldsPart m getPart currentResult addToResult + foldMarshallerFieldsPart mbQualifier m getPart currentResult addToResult MarshallPartial m -> - foldMarshallerFieldsPart m getPart currentResult addToResult + foldMarshallerFieldsPart mbQualifier m getPart currentResult addToResult MarshallReadOnly m -> - foldMarshallerFieldsPart m Nothing currentResult addToResult + foldMarshallerFieldsPart mbQualifier m Nothing currentResult addToResult + MarshallQualifyFields q m -> + foldMarshallerFieldsPart (Just q) m getPart currentResult addToResult -{- | - Decodes all the rows found in an execution result at once. The first row that +{- | Decodes all the rows found in an execution result at once. The first row that fails to decode will return the 'MarshallError.MarshallErrorDetails' that results, otherwise all decoded rows will be returned. @@ -380,8 +446,7 @@ (unannotatedSqlMarshaller marshallerWithMeta) result -{- | - Decodes all the rows found in a execution result at once. The first row that +{- | Decodes all the rows found in a execution result at once. The first row that fails to decode will return the 'MarshallError.MarshallErrorDetails' that results, otherwise all decoded rows will be returned. If an error occurs while decoding a row, the 'RowIdentityExtractor' will be used to extract @@ -430,8 +495,7 @@ Right bs -> pure (Right (b : bs)) -{- | - Attempts to decode a result set row that has already been fetched from the +{- | Attempts to decode a result set row that has already been fetched from the database server into a Haskell value. If the decoding fails, a 'MarshallError.MarshallError' will be returned. @@ -448,19 +512,18 @@ case result of Left err -> do rowId <- getRowId row - pure $ - Left $ - MarshallError.MarshallError - { MarshallError.marshallErrorDetailLevel = errorDetailLevel - , MarshallError.marshallErrorRowIdentifier = rowId - , MarshallError.marshallErrorDetails = err - } + pure + . Left + $ MarshallError.MarshallError + { MarshallError.marshallErrorDetailLevel = errorDetailLevel + , MarshallError.marshallErrorRowIdentifier = rowId + , MarshallError.marshallErrorDetails = err + } Right entity -> pure $ Right entity -{- | - A 'RowSource' can fetch and decode rows from a database result set. Using +{- | A 'RowSource' can fetch and decode rows from a database result set. Using a 'RowSource' gives random access to the rows in the result set, only attempting to decode them when they are requested by the user via 'decodeRow'. @@ -475,15 +538,16 @@ newtype RowSource readEntity = RowSource (Row -> IO (Either MarshallError.MarshallErrorDetails readEntity)) +-- | @since 1.0.0.0 instance Functor RowSource where fmap = mapRowSource +-- | @since 1.0.0.0 instance Applicative RowSource where pure = constRowSource (<*>) = applyRowSource -{- | - Adds a function to the decoding proocess to transform the value returned +{- | Adds a function to the decoding proocess to transform the value returned by a 'RowSource'. @since 1.0.0.0 @@ -492,8 +556,7 @@ mapRowSource f (RowSource decodeA) = RowSource $ \row -> fmap (fmap f) (decodeA row) -{- | - Creates a 'RowSource' that always returns the value given, rather than +{- | Creates a 'RowSource' that always returns the value given, rather than attempting to access the result set and decoding anything. @since 1.0.0.0 @@ -502,8 +565,7 @@ constRowSource = RowSource . const . pure . Right -{- | - Applies a function that will be decoded from the result set to another +{- | Applies a function that will be decoded from the result set to another value decoded from the result set. @since 1.0.0.0 @@ -520,8 +582,7 @@ eitherA <- decodeA row pure (fmap aToB eitherA) -{- | - Creates a 'RowSource' that will always fail to decode by returning the +{- | Creates a 'RowSource' that will always fail to decode by returning the provided error. This can be used in cases where a 'RowSource' must be provided but it is already known at run time that decoding is impossible. For instance, this is used internally when a 'FieldDefinition' references @@ -533,8 +594,7 @@ failRowSource = RowSource . const . pure . Left -{- | - Uses the 'SqlMarshaller' given to build a 'RowSource' that will decode +{- | Uses the 'SqlMarshaller' given to build a 'RowSource' that will decode from the given result set. The returned 'RowSource' can then be used to decode rows as desired by the user. Note that the entire result set is held in memory for potential decoding until the 'RowSource' is garbage @@ -551,8 +611,8 @@ columnMap <- prepareColumnMap result let - mkSource :: SqlMarshaller a b -> RowSource b - mkSource marshallerPart = + mkSource :: Maybe qualifier -> SqlMarshaller a b -> RowSource b + mkSource mbQualifier marshallerPart = -- Note, this case statement is evaluated before the row argument is -- ever passed to a 'RowSource' to ensure that a single 'RowSource' -- operation is build and re-used when decoding many rows. @@ -560,9 +620,9 @@ MarshallPure readEntity -> constRowSource readEntity MarshallApply marshallAToB marshallA -> - mkSource marshallAToB <*> mkSource marshallA + mkSource mbQualifier marshallAToB <*> mkSource mbQualifier marshallA MarshallNest _ someMarshaller -> - mkSource someMarshaller + mkSource mbQualifier someMarshaller MarshallField fieldDef -> mkFieldNameSource (fieldName fieldDef) @@ -571,27 +631,29 @@ result MarshallSyntheticField syntheticField -> mkFieldNameSource - (syntheticFieldAlias syntheticField) + (syntheticFieldName syntheticField) (syntheticFieldValueFromSqlValue syntheticField) columnMap result MarshallMaybeTag m -> - mkSource m + mkSource mbQualifier m MarshallPartial m -> let fieldNames = foldMarshallerFields m [] $ \marshallerField names -> case marshallerField of - Natural field _ -> + Natural _ field _ -> fieldName field : names Synthetic field -> - syntheticFieldAlias field : names + syntheticFieldName field : names in - partialRowSource fieldNames columnMap result (mkSource m) + partialRowSource fieldNames columnMap result (mkSource mbQualifier m) MarshallReadOnly m -> - mkSource m + mkSource mbQualifier m + MarshallQualifyFields q m -> + mkSource (Just q) m - pure . mkSource $ marshaller + pure . mkSource Nothing $ marshaller partialRowSource :: ExecutionResult result => @@ -629,8 +691,7 @@ Right (Right entity) -> pure $ Right entity -{- | - Builds a 'RowSource' that will retrieve and decode the name field from +{- | Builds a 'RowSource' that will retrieve and decode the name field from the result. @since 1.0.0.0 @@ -653,8 +714,7 @@ , MarshallError.actualColumnNames = Map.keysSet columnMap } -{- | - An internal helper function that finds all the column names in a result set +{- | An internal helper function that finds all the column names in a result set and associates them with the respective column numbers for easier lookup. @since 1.0.0.0 @@ -684,8 +744,7 @@ entries <- traverse mkNameEntry [Column 0 .. maxColumn] pure $ Map.fromList (catMaybes entries) -{- | - A internal helper function for to build a 'RowSource' that retrieves and +{- | A internal helper function for to build a 'RowSource' that retrieves and decodes a single column value form the result set. @since 1.0.0.0 @@ -714,8 +773,7 @@ in pure (Left $ MarshallError.DecodingError details) -{- | - A 'RowIdentityExtractor' is used to retrieve identifying information for a +{- | A 'RowIdentityExtractor' is used to retrieve identifying information for a row when a 'MarshallError.MarshallError' occurs reading it from the database. You should only need to worry about this type if you're using @@ -729,8 +787,7 @@ newtype RowIdentityExtractor = RowIdentityExtractor (Row -> IO [(B8.ByteString, SqlValue.SqlValue)]) -{- | - Constructs a 'RowIdentityExtractor' that will extract values for the given +{- | Constructs a 'RowIdentityExtractor' that will extract values for the given fields from the result set to identify rows in decoding errors. Any of the named fields that are missing from the result set will not be included in the extracted row identity. @@ -768,8 +825,7 @@ Just maxColumn -> fmap catMaybes $ traverse getIdentityValue [Column 0 .. maxColumn] -{- | - Builds a 'SqlMarshaller' that maps a single field of a Haskell entity to +{- | Builds a 'SqlMarshaller' that maps a single field of a Haskell entity to a single column in the database. That value to store in the database will be retrieved from the entity using a provided accessor function. This function is intended to be used inside of a stanza of 'Applicative' syntax that will @@ -797,8 +853,7 @@ marshallField accessor fieldDef = MarshallNest accessor (MarshallField fieldDef) -{- | - Builds a 'SqlMarshaller' that will include a SQL expression in select +{- | Builds a 'SqlMarshaller' that will include a SQL expression in select statements to calculate a value using the columns of the table being selected from. The columns being used in the calculation do not themselves need to be selected, though they must be present in the table so they can @@ -818,7 +873,7 @@ atLeast21Field = SyntheticField { syntheticFieldExpression = RawSql.unsafeSqlExpression "age >= 21" - , syntheticFieldAlias = Orville.stringToFieldName "over21" + , syntheticFieldName = Orville.stringToFieldName "over21" , syntheticFieldValueFromSqlValue = SqlValue.toBool } @ @@ -831,8 +886,7 @@ marshallSyntheticField = MarshallSyntheticField -{- | - Nests a 'SqlMarshaller' inside another, using the given accessor to retrieve +{- | Nests a 'SqlMarshaller' inside another, using the given accessor to retrieve values to be marshalled. The resulting marshaller can then be used in the same way as 'marshallField' within the applicative syntax of a larger marshaller. @@ -873,8 +927,7 @@ marshallNested = MarshallNest -{- | - Lifts a 'SqlMarshaller' to have both read/write entities be 'Maybe', +{- | Lifts a 'SqlMarshaller' to have both read/write entities be 'Maybe', and applies a tag to avoid double mapping. @since 1.0.0.0 @@ -907,9 +960,10 @@ MarshallPartial (fmap sequence $ go m) MarshallReadOnly m -> MarshallReadOnly (go m) + MarshallQualifyFields q m -> + MarshallQualifyFields q (go m) -{- | - Builds a 'SqlMarshaller' that will raise a decoding error when the value +{- | Builds a 'SqlMarshaller' that will raise a decoding error when the value produced is a 'Left'. @since 1.0.0.0 @@ -917,8 +971,22 @@ marshallPartial :: SqlMarshaller a (Either String b) -> SqlMarshaller a b marshallPartial = MarshallPartial -{- | - Adds a prefix, followed by an underscore, to the names of all of the fields +{- | Builds a 'SqlMarshaller' that will qualify references to the (non-synthetic) + fields it contains with the given qualifier. Any fields that have already been + qualified in the provided marshaller by a previous call to 'marshallQualifyFields' + will retain the qualifier they were previously given. + +@since 1.1.0.0 +-} +marshallQualifyFields :: + FieldQualifier qualifier => + qualifier -> + SqlMarshaller a b -> + SqlMarshaller a b +marshallQualifyFields = + MarshallQualifyFields + +{- | Adds a prefix, followed by an underscore, to the names of all of the fields and synthetic fields in a 'SqlMarshaller'. @since 1.0.0.0 @@ -943,9 +1011,9 @@ MarshallMaybeTag m -> MarshallMaybeTag $ go m MarshallPartial m -> MarshallPartial $ go m MarshallReadOnly m -> MarshallReadOnly $ go m + MarshallQualifyFields q m -> MarshallQualifyFields q $ go m -{- | - Marks a 'SqlMarshaller' as read-only so that it will not attempt to +{- | Marks a 'SqlMarshaller' as read-only so that it will not attempt to read any values from the @writeEntity@. You should use this if you have a group of fields which are populated by database rather than the application. @@ -954,8 +1022,7 @@ marshallReadOnly :: SqlMarshaller a b -> SqlMarshaller c b marshallReadOnly = MarshallReadOnly -{- | - A version of 'marshallField' that uses 'marshallReadOnly' to make a single +{- | A version of 'marshallField' that uses 'marshallReadOnly' to make a single read-only field. You will usually use this in conjunction with a 'FieldDefinition' like @serialField@ where the value is populated by the database. @@ -966,3 +1033,83 @@ FieldDefinition nullability fieldValue -> SqlMarshaller writeEntity fieldValue marshallReadOnlyField = MarshallReadOnly . MarshallField + +{- | Checks that the row value containing the write fields of the + 'SqlMarshaller' is equal to the given value encoded as a row. + +@since 1.1.0.0 +-} +marshallerEquals :: SqlMarshaller writeEntity x -> writeEntity -> Expr.BooleanExpr +marshallerEquals = SqlComparable.equals + +{- | Checks that the row value containing the write fields of the + 'SqlMarshaller' is not equal to the given value encoded as a row. + +@since 1.1.0.0 +-} +marshallerNotEquals :: SqlMarshaller writeEntity x -> writeEntity -> Expr.BooleanExpr +marshallerNotEquals = SqlComparable.notEquals + +{- | Checks that the row value containing the write fields of the + 'SqlMarshaller' is distinct from the given value encoded as a row. + +@since 1.1.0.0 +-} +marshallerIsDistinctFrom :: SqlMarshaller writeEntity x -> writeEntity -> Expr.BooleanExpr +marshallerIsDistinctFrom = SqlComparable.isDistinctFrom + +{- | Checks that the row value containing the write fields of the + 'SqlMarshaller' is not distinct from the given value encoded as a row. + +@since 1.1.0.0 +-} +marshallerIsNotDistinctFrom :: SqlMarshaller writeEntity x -> writeEntity -> Expr.BooleanExpr +marshallerIsNotDistinctFrom = SqlComparable.isNotDistinctFrom + +{- | Checks that the row value containing the write fields of the + 'SqlMarshaller' is less than the given value encoded as a row. + +@since 1.1.0.0 +-} +marshallerLessThan :: SqlMarshaller writeEntity x -> writeEntity -> Expr.BooleanExpr +marshallerLessThan = SqlComparable.lessThan + +{- | Checks that the row value containing the write fields of the + 'SqlMarshaller' is less than or equal to the given value encoded as a row. + +@since 1.1.0.0 +-} +marshallerLessThanOrEqualTo :: SqlMarshaller writeEntity x -> writeEntity -> Expr.BooleanExpr +marshallerLessThanOrEqualTo = SqlComparable.lessThanOrEqualTo + +{- | Checks that the row value containing the write fields of the + 'SqlMarshaller' is greater than the given value encoded as a row. + +@since 1.1.0.0 +-} +marshallerGreaterThan :: SqlMarshaller writeEntity x -> writeEntity -> Expr.BooleanExpr +marshallerGreaterThan = SqlComparable.greaterThan + +{- | Checks that the row value containing the write fields of the + 'SqlMarshaller' is greater than or equal to the given value encoded as a row. + +@since 1.1.0.0 +-} +marshallerGreaterThanOrEqualTo :: SqlMarshaller writeEntity x -> writeEntity -> Expr.BooleanExpr +marshallerGreaterThanOrEqualTo = SqlComparable.greaterThanOrEqualTo + +{- | Checks that the row value containing the write fields of the + 'SqlMarshaller' is in the given list of values encoded as a list of rows. + +@since 1.1.0.0 +-} +marshallerIn :: SqlMarshaller writeEntity x -> NE.NonEmpty writeEntity -> Expr.BooleanExpr +marshallerIn = SqlComparable.isIn + +{- | Checks that the row value containing the write fields of the + 'SqlMarshaller' is not in the given list of values encoded as a list of rows. + +@since 1.1.0.0 +-} +marshallerNotIn :: SqlMarshaller writeEntity x -> NE.NonEmpty writeEntity -> Expr.BooleanExpr +marshallerNotIn = SqlComparable.isNotIn diff --git a/src/Orville/PostgreSQL/Marshall/SqlType.hs b/src/Orville/PostgreSQL/Marshall/SqlType.hs --- a/src/Orville/PostgreSQL/Marshall/SqlType.hs +++ b/src/Orville/PostgreSQL/Marshall/SqlType.hs @@ -1,5 +1,5 @@ {- | -Copyright : Flipstone Technology Partners 2023 +Copyright : Flipstone Technology Partners 2023-2025 License : MIT Stability : Stable @@ -63,8 +63,7 @@ import Orville.PostgreSQL.Raw.SqlValue (SqlValue) import qualified Orville.PostgreSQL.Raw.SqlValue as SqlValue -{- | - SqlType defines the mapping of a Haskell type (@a@) to a SQL column type in the +{- | SqlType defines the mapping of a Haskell type (@a@) to a SQL column type in the database. This includes both how to convert the type to and from the raw values read from the database as well as the schema information required to create and migrate columns using the type. @@ -100,8 +99,7 @@ -- logic to ignore the default value rather than drop it as it normally would. } -{- | - 'integer' defines a 32-bit integer type. This corresponds to the "INTEGER" type in SQL. +{- | 'integer' defines a 32-bit integer type. This corresponds to the "INTEGER" type in SQL. @since 1.0.0.0 -} @@ -117,8 +115,7 @@ , sqlTypeDontDropImplicitDefaultDuringMigrate = False } -{- | - 'serial' defines a 32-bit auto-incrementing column type. This corresponds to +{- | 'serial' defines a 32-bit auto-incrementing column type. This corresponds to the "SERIAL" type in PostgreSQL. @since 1.0.0.0 @@ -135,8 +132,7 @@ , sqlTypeDontDropImplicitDefaultDuringMigrate = True } -{- | - 'bigInteger' defines a 64-bit integer type. This corresponds to the "BIGINT" +{- | 'bigInteger' defines a 64-bit integer type. This corresponds to the "BIGINT" type in SQL. @since 1.0.0.0 @@ -153,8 +149,7 @@ , sqlTypeDontDropImplicitDefaultDuringMigrate = False } -{- | - 'bigSerial' defines a 64-bit auto-incrementing column type. This corresponds to +{- | 'bigSerial' defines a 64-bit auto-incrementing column type. This corresponds to the "BIGSERIAL" type in PostgresSQL. @since 1.0.0.0 @@ -171,8 +166,7 @@ , sqlTypeDontDropImplicitDefaultDuringMigrate = True } -{- | - 'smallInteger' defines a 16-bit integer type. This corresponds to the "SMALLINT" type in SQL. +{- | 'smallInteger' defines a 16-bit integer type. This corresponds to the "SMALLINT" type in SQL. @since 1.0.0.0 -} @@ -188,10 +182,11 @@ , sqlTypeDontDropImplicitDefaultDuringMigrate = False } -{- | - 'double' defines a floating point numeric type. This corresponds to the +{- | 'double' defines a floating point numeric type. This corresponds to the "DOUBLE PRECISION" type in SQL. + Note that Infinity, -Infinity and NaN are not handled. + @since 1.0.0.0 -} double :: SqlType Double @@ -206,8 +201,7 @@ , sqlTypeDontDropImplicitDefaultDuringMigrate = False } -{- | - 'boolean' defines a True/False boolean type. This corresponds to the "BOOLEAN" +{- | 'boolean' defines a True/False boolean type. This corresponds to the "BOOLEAN" type in SQL. @since 1.0.0.0 @@ -224,10 +218,12 @@ , sqlTypeDontDropImplicitDefaultDuringMigrate = False } -{- | - 'unboundedText' defines an unbounded length text field type. This corresponds to a +{- | 'unboundedText' defines an unbounded length text field type. This corresponds to a "TEXT" type in PostgreSQL. + Note that values must not contain NULL codepoints, they are unsupported in + PostgreSQL. + @since 1.0.0.0 -} unboundedText :: SqlType Text @@ -242,10 +238,12 @@ , sqlTypeDontDropImplicitDefaultDuringMigrate = False } -{- | - 'fixedText' defines a fixed length text field type. This corresponds to a +{- | 'fixedText' defines a fixed length text field type. This corresponds to a "CHAR(len)" type in PostgreSQL. + Note that values must not contain NULL codepoints, they are unsupported in + PostgreSQL. + @since 1.0.0.0 -} fixedText :: Int32 -> SqlType Text @@ -260,10 +258,12 @@ , sqlTypeDontDropImplicitDefaultDuringMigrate = False } -{- | - 'boundedText' defines a variable length text field type. This corresponds to a +{- | 'boundedText' defines a variable length text field type. This corresponds to a "VARCHAR(len)" type in PostgreSQL. + Note that values must not contain NULL codepoints, they are unsupported in + PostgreSQL. + @since 1.0.0.0 -} boundedText :: Int32 -> SqlType Text @@ -278,10 +278,12 @@ , sqlTypeDontDropImplicitDefaultDuringMigrate = False } -{- | - 'textSearchVector' defines a type for indexed text searching. It corresponds to the +{- | 'textSearchVector' defines a type for indexed text searching. It corresponds to the "TSVECTOR" type in PostgreSQL. + Note that values must not contain NULL codepoints, they are unsupported in + PostgreSQL. + @since 1.0.0.0 -} textSearchVector :: SqlType Text @@ -296,8 +298,7 @@ , sqlTypeDontDropImplicitDefaultDuringMigrate = False } -{- | - 'uuid' defines a UUID type. It corresponds to the "UUID" type in PostgreSQL. +{- | 'uuid' defines a UUID type. It corresponds to the "UUID" type in PostgreSQL. @since 1.0.0.0 -} @@ -319,10 +320,13 @@ , sqlTypeDontDropImplicitDefaultDuringMigrate = False } -{- | - 'date' defines a type representing a calendar date (without time zone). It corresponds +{- | 'date' defines a type representing a calendar date (without time zone). It corresponds to the "DATE" type in SQL. + This type cannot represent the full range of 'Time.Day' values. PostgreSQL supports years + from -4731 to 5874897 inclusive for this type, and sending a 'Time.Day' with a year outside + of this range to the database will result in a PostgreSQL exception. + @since 1.0.0.0 -} date :: SqlType Time.Day @@ -337,11 +341,14 @@ , sqlTypeDontDropImplicitDefaultDuringMigrate = False } -{- | - 'timestamp' defines a type representing a particular point in time without time zone information, +{- | 'timestamp' defines a type representing a particular point in time without time zone information, but can be constructed with a time zone offset. It corresponds to the "TIMESTAMP with time zone" type in SQL. + This type cannot represent the full range of 'Time.UTCTime' values. PostgreSQL supports years + from -4731 to 294276 inclusive for this type, and sending a 'Time.UTCTime' with a year outside + of this range to the database will result in a PostgreSQL exception. + Note: This is NOT a typo. The "TIMESTAMP with time zone" type in SQL does not include any actual time zone information. For an excellent explanation of the complexities involving this type, please see Chris Clark's blog post about it: @@ -361,10 +368,13 @@ , sqlTypeDontDropImplicitDefaultDuringMigrate = False } -{- | - 'timestampWithoutZone' defines a type representing a particular point in time (without time zone). +{- | 'timestampWithoutZone' defines a type representing a particular point in time (without time zone). It corresponds to the "TIMESTAMP without time zone" type in SQL. + This type cannot represent the full range of 'Time.LocalTime' values. PostgreSQL supports years + from -4731 to 294276 inclusive for this type, and sending a 'Time.LocalTime' with a year outside + of this range to the database will result in a PostgreSQL exception. + http://blog.untrod.com/2016/08/actually-understanding-timezones-in-postgresql.html @since 1.0.0.0 @@ -381,10 +391,12 @@ , sqlTypeDontDropImplicitDefaultDuringMigrate = False } -{- | - 'jsonb' represents any type that can be converted To and From JSON. This corresponds +{- | 'jsonb' represents any type that can be converted To and From JSON. This corresponds to the "JSONB" type in PostgreSQL. + Note that strings contained within must not contain NULL codepoints, + as they are unsupported in PostgreSQL. + @since 1.0.0.0 -} jsonb :: SqlType Text @@ -399,8 +411,7 @@ , sqlTypeDontDropImplicitDefaultDuringMigrate = False } -{- | - 'oid' corresponds to the type used in PostgreSQL for identifying system +{- | 'oid' corresponds to the type used in PostgreSQL for identifying system objects. @since 1.0.0.0 @@ -417,8 +428,7 @@ , sqlTypeDontDropImplicitDefaultDuringMigrate = False } -{- | - 'foreignRefType' creates a 'SqlType' suitable for columns that will be +{- | 'foreignRefType' creates a 'SqlType' suitable for columns that will be foreign keys referencing a column of the given 'SqlType'. For most types, the underlying SQL type will be identical, but for special types (such as auto-incrementing primary keys), the type constructed by 'foreignRefType' will @@ -434,8 +444,7 @@ Nothing -> sqlType Just refExpr -> sqlType {sqlTypeExpr = refExpr, sqlTypeReferenceExpr = Nothing} -{- | - 'tryConvertSqlType' changes the Haskell type used by a 'SqlType' which +{- | 'tryConvertSqlType' changes the Haskell type used by a 'SqlType' which changes the column type that will be used in the database schema. The functions given will be used to convert the now Haskell type to and from the original type when reading and writing values from the database. When reading @@ -453,8 +462,7 @@ aToB a } -{- | - 'convertSqlType' changes the Haskell type used by a 'SqlType' in the same manner +{- | 'convertSqlType' changes the Haskell type used by a 'SqlType' in the same manner as 'tryConvertSqlType' in cases where an @a@ can always be converted to a @b@. @since 1.0.0.0 diff --git a/src/Orville/PostgreSQL/Marshall/SyntheticField.hs b/src/Orville/PostgreSQL/Marshall/SyntheticField.hs --- a/src/Orville/PostgreSQL/Marshall/SyntheticField.hs +++ b/src/Orville/PostgreSQL/Marshall/SyntheticField.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {- | -Copyright : Flipstone Technology Partners 2023 +Copyright : Flipstone Technology Partners 2023-2025 License : MIT Stability : Stable @@ -11,63 +13,90 @@ ( SyntheticField , syntheticFieldExpression , syntheticFieldAlias + , syntheticFieldName , syntheticFieldValueFromSqlValue , syntheticField , nullableSyntheticField , prefixSyntheticField + , orderBySyntheticField ) where import qualified Data.ByteString.Char8 as B8 import qualified Orville.PostgreSQL.Expr as Expr -import Orville.PostgreSQL.Marshall.FieldDefinition (FieldName, byteStringToFieldName, fieldNameToByteString, stringToFieldName) +import Orville.PostgreSQL.Internal.FieldName (FieldName, byteStringToFieldName, fieldNameToByteString, stringToFieldName) +import qualified Orville.PostgreSQL.Marshall.SqlComparable as SqlComparable +import qualified Orville.PostgreSQL.Marshall.SqlType as SqlType import qualified Orville.PostgreSQL.Raw.SqlValue as SqlValue -{- | - A 'SyntheticField' can be used to evaluate a SQL expression based on the +{- | A 'SyntheticField' can be used to evaluate a SQL expression based on the columns of a table when records are selected from the database. Synthetic fields are inherently read-only. @since 1.0.0.0 -} data SyntheticField a = SyntheticField - { _syntheticFieldExpression :: Expr.ValueExpression - , _syntheticFieldAlias :: FieldName - , _syntheticFieldValueFromSqlValue :: SqlValue.SqlValue -> Either String a + { i_syntheticFieldExpression :: Expr.ValueExpression + , i_syntheticFieldName :: FieldName + , i_syntheticFieldType :: SqlType.SqlType a } -{- | - Returns the SQL expression that should be used in select statements to +{- | Marshalls a Haskell value to be in the field to its 'SqlValue.SqlValue' + representation. + +@since 1.1.0.0 +-} +instance SqlComparable.SqlComparable (SyntheticField a) a where + toComparableSqlValue field = SqlType.sqlTypeToSql (syntheticFieldType field) + referenceValueExpression = syntheticFieldExpression + +{- | Returns the SQL expression that should be used in select statements to calculate the synthetic field. @since 1.0.0.0 -} syntheticFieldExpression :: SyntheticField a -> Expr.ValueExpression syntheticFieldExpression = - _syntheticFieldExpression + i_syntheticFieldExpression -{- | - Returns the alias that should be used in select statements to name the +{- | Returns the alias that should be used in select statements to name the synthetic field. @since 1.0.0.0 -} +{-# DEPRECATED syntheticFieldAlias "Use syntheticFieldName instead" #-} syntheticFieldAlias :: SyntheticField a -> FieldName syntheticFieldAlias = - _syntheticFieldAlias + i_syntheticFieldName -{- | - Decodes a calculated value selected from the database to its expected +{- | Returns the name that should be used in select statements to name the + synthetic field. + +@since 1.1.0.0 +-} +syntheticFieldName :: SyntheticField a -> FieldName +syntheticFieldName = + i_syntheticFieldName + +{- | Decodes a calculated value selected from the database to its expected Haskell type. Returns a 'Left' with an error message if the decoding fails. @since 1.0.0.0 -} syntheticFieldValueFromSqlValue :: SyntheticField a -> SqlValue.SqlValue -> Either String a syntheticFieldValueFromSqlValue = - _syntheticFieldValueFromSqlValue + SqlType.sqlTypeFromSql . syntheticFieldType -{- | - Constructs a 'SyntheticField' that will select a SQL expression using +{- | The 'SqlType.SqlType' for the 'SyntheticField' determines the PostgreSQL + data type used to define the field as well as how to marshall Haskell values + from the database. + +@since 1.1.0.0 +-} +syntheticFieldType :: SyntheticField a -> SqlType.SqlType a +syntheticFieldType = i_syntheticFieldType + +{- | Constructs a 'SyntheticField' that will select a SQL expression using the given alias. @since 1.0.0.0 @@ -77,32 +106,39 @@ Expr.ValueExpression -> -- | The alias to be used to name the calculation in SQL expressions. String -> - -- | A function to decode the expression result from a 'SqlValue.SqlValue'. - (SqlValue.SqlValue -> Either String a) -> + -- | The 'SqlType.SqlType' to be used for comparisons + SqlType.SqlType a -> SyntheticField a -syntheticField expression alias fromSqlValue = +syntheticField expression alias sqlType = SyntheticField - { _syntheticFieldExpression = expression - , _syntheticFieldAlias = stringToFieldName alias - , _syntheticFieldValueFromSqlValue = fromSqlValue + { i_syntheticFieldExpression = expression + , i_syntheticFieldName = stringToFieldName alias + , i_syntheticFieldType = sqlType } -{- | - Modifies a 'SyntheticField' to allow it to decode @NULL@ values. +{- | Modifies a 'SyntheticField' to allow it to decode @NULL@ values. @since 1.0.0.0 -} nullableSyntheticField :: SyntheticField a -> SyntheticField (Maybe a) nullableSyntheticField synthField = - synthField - { _syntheticFieldValueFromSqlValue = \sqlValue -> - if SqlValue.isSqlNull sqlValue - then Right Nothing - else Just <$> syntheticFieldValueFromSqlValue synthField sqlValue - } + let + nullableType :: SqlType.SqlType a -> SqlType.SqlType (Maybe a) + nullableType sqlType = + sqlType + { SqlType.sqlTypeToSql = maybe SqlValue.sqlNull (SqlType.sqlTypeToSql sqlType) + , SqlType.sqlTypeFromSql = + \sqlValue -> + if SqlValue.isSqlNull sqlValue + then Right Nothing + else fmap Just $ SqlType.sqlTypeFromSql sqlType sqlValue + } + in + synthField + { i_syntheticFieldType = nullableType (syntheticFieldType synthField) + } -{- | - Adds a prefix, followed by an underscore, to the alias used to name the +{- | Adds a prefix, followed by an underscore, to the alias used to name the synthetic field. @since 1.0.0.0 @@ -113,5 +149,13 @@ SyntheticField a prefixSyntheticField prefix synthField = synthField - { _syntheticFieldAlias = byteStringToFieldName (B8.pack prefix <> "_" <> fieldNameToByteString (syntheticFieldAlias synthField)) + { i_syntheticFieldName = byteStringToFieldName (B8.pack prefix <> "_" <> fieldNameToByteString (syntheticFieldName synthField)) } + +{- | Orders a query by the alias for the given synthetic field. + +@since 1.1.0.0 +-} +orderBySyntheticField :: SyntheticField a -> Expr.OrderByDirection -> Expr.OrderByExpr +orderBySyntheticField = + Expr.orderByColumnName . Expr.unqualified . Expr.fromIdentifier . Expr.identifierFromBytes . fieldNameToByteString . syntheticFieldName diff --git a/src/Orville/PostgreSQL/Monad/HasOrvilleState.hs b/src/Orville/PostgreSQL/Monad/HasOrvilleState.hs --- a/src/Orville/PostgreSQL/Monad/HasOrvilleState.hs +++ b/src/Orville/PostgreSQL/Monad/HasOrvilleState.hs @@ -18,8 +18,7 @@ import Orville.PostgreSQL.OrvilleState (OrvilleState) -{- | - 'HasOrvilleState' is the typeclass that Orville uses to access and manange +{- | 'HasOrvilleState' is the typeclass that Orville uses to access and manange the connection pool and state tracking when it is being executed inside an unknown Monad. It is a specialized version of the Reader interface so that it can be easily implemented by application Monads that already have a Reader @@ -53,19 +52,17 @@ @since 1.0.0.0 -} class HasOrvilleState m where - -- | - -- Fetches the current 'OrvilleState' from the host Monad context. The - -- equivalent of 'ask' for 'ReaderT OrvilleState'. + -- | Fetches the current 'OrvilleState' from the host Monad context. The + -- equivalent of 'ask' for 'ReaderT OrvilleState'. -- -- @since 1.0.0.0 askOrvilleState :: m OrvilleState - -- | - -- Applies a modification to the 'OrvilleState' that is local to the given - -- monad operation. Calls to 'askOrvilleState' made within the 'm a' provided - -- must return the modified state. The modified state must only apply to - -- the given 'm a' and not be persisted beyond it. The equivalent of 'local' - -- for 'ReaderT OrvilleState'. + -- | Applies a modification to the 'OrvilleState' that is local to the given + -- monad operation. Calls to 'askOrvilleState' made within the 'm a' provided + -- must return the modified state. The modified state must only apply to + -- the given 'm a' and not be persisted beyond it. The equivalent of 'local' + -- for 'ReaderT OrvilleState'. -- -- @since 1.0.0.0 localOrvilleState :: @@ -75,10 +72,12 @@ m a -> m a +-- | @since 1.0.0.0 instance Monad m => HasOrvilleState (ReaderT OrvilleState m) where askOrvilleState = ask localOrvilleState = local +-- | @since 1.0.0.0 instance {-# OVERLAPS #-} (Monad m, HasOrvilleState m) => HasOrvilleState (ReaderT r m) where askOrvilleState = lift askOrvilleState localOrvilleState f = mapReaderT (localOrvilleState f) diff --git a/src/Orville/PostgreSQL/Monad/Orville.hs b/src/Orville/PostgreSQL/Monad/Orville.hs --- a/src/Orville/PostgreSQL/Monad/Orville.hs +++ b/src/Orville/PostgreSQL/Monad/Orville.hs @@ -24,8 +24,7 @@ import qualified Orville.PostgreSQL.OrvilleState as OrvilleState import Orville.PostgreSQL.Raw.Connection (ConnectionPool) -{- | - The 'Orville' Monad provides an easy starter implementation of +{- | The 'Orville' Monad provides an easy starter implementation of 'MonadOrville.MonadOrville' when you don't have a monad specific to your application that you need to use. @@ -49,8 +48,7 @@ , ExSafe.MonadCatch ) -{- | - Runs an 'Orville' operation in the 'IO' monad using the given connection +{- | Runs an 'Orville' operation in the 'IO' monad using the given connection pool. This will run the 'Orville' operation with the @@ -66,8 +64,7 @@ runOrvilleWithState . OrvilleState.newOrvilleState ErrorDetailLevel.defaultErrorDetailLevel -{- | - Runs an 'Orville' operation in the 'IO' monad, starting from the provided +{- | Runs an 'Orville' operation in the 'IO' monad, starting from the provided 'OrvilleState.OrvilleState'. Caution: If you harvest an 'OrvilleState.OrvilleState' from inside a diff --git a/src/Orville/PostgreSQL/PgCatalog.hs b/src/Orville/PostgreSQL/PgCatalog.hs --- a/src/Orville/PostgreSQL/PgCatalog.hs +++ b/src/Orville/PostgreSQL/PgCatalog.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -Wno-missing-import-lists #-} {- | -Copyright : Flipstone Technology Partners 2023 +Copyright : Flipstone Technology Partners 2023-2024 License : MIT Stability : Stable @@ -18,6 +18,10 @@ import Orville.PostgreSQL.PgCatalog.PgAttributeDefault as Export import Orville.PostgreSQL.PgCatalog.PgClass as Export import Orville.PostgreSQL.PgCatalog.PgConstraint as Export +import Orville.PostgreSQL.PgCatalog.PgDescription as Export +import Orville.PostgreSQL.PgCatalog.PgExtension as Export import Orville.PostgreSQL.PgCatalog.PgIndex as Export import Orville.PostgreSQL.PgCatalog.PgNamespace as Export +import Orville.PostgreSQL.PgCatalog.PgProc as Export import Orville.PostgreSQL.PgCatalog.PgSequence as Export +import Orville.PostgreSQL.PgCatalog.PgTrigger as Export diff --git a/src/Orville/PostgreSQL/PgCatalog/DatabaseDescription.hs b/src/Orville/PostgreSQL/PgCatalog/DatabaseDescription.hs --- a/src/Orville/PostgreSQL/PgCatalog/DatabaseDescription.hs +++ b/src/Orville/PostgreSQL/PgCatalog/DatabaseDescription.hs @@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-} {- | -Copyright : Flipstone Technology Partners 2023 +Copyright : Flipstone Technology Partners 2023-2024 License : MIT Stability : Stable @@ -18,7 +18,10 @@ , lookupRelationOfKind , lookupAttribute , lookupAttributeDefault - , describeDatabaseRelations + , lookupAttributeComment + , lookupProcedure + , lookupExtension + , describeDatabase ) where @@ -27,6 +30,7 @@ import Control.Applicative (liftA2) #endif import qualified Data.Map.Strict as Map +import qualified Data.Text as T import qualified Database.PostgreSQL.LibPQ as LibPQ import qualified Orville.PostgreSQL as Orville @@ -35,26 +39,33 @@ import Orville.PostgreSQL.PgCatalog.PgAttributeDefault (PgAttributeDefault (pgAttributeDefaultAttributeNumber), attributeDefaultRelationOidField, pgAttributeDefaultTable) import Orville.PostgreSQL.PgCatalog.PgClass (PgClass (pgClassNamespaceOid, pgClassOid, pgClassRelationName), RelationKind, RelationName, namespaceOidField, pgClassRelationKind, pgClassTable, relationNameField, relationNameToString) import Orville.PostgreSQL.PgCatalog.PgConstraint (PgConstraint (pgConstraintForeignKey, pgConstraintForeignRelationOid, pgConstraintKey), constraintRelationOidField, pgConstraintTable) +import Orville.PostgreSQL.PgCatalog.PgDescription (ObjectSubId, PgDescription (pgDescriptionObjSubId), objOidField, objectSubIdFromAttributeNumber, objectSubIdZero, pgDescriptionDescription, pgDescriptionTable) +import Orville.PostgreSQL.PgCatalog.PgExtension (ExtensionName, PgExtension, extensionNameField, pgExtensionTable) import Orville.PostgreSQL.PgCatalog.PgIndex (PgIndex (pgIndexAttributeNumbers, pgIndexPgClassOid), indexIsLiveField, indexRelationOidField, pgIndexTable) import Orville.PostgreSQL.PgCatalog.PgNamespace (NamespaceName, PgNamespace (pgNamespaceOid), namespaceNameField, pgNamespaceTable) +import Orville.PostgreSQL.PgCatalog.PgProc (PgProc, ProcName, pgProcTable, procNameField, procNamespaceOidField) import Orville.PostgreSQL.PgCatalog.PgSequence (PgSequence, pgSequenceTable, sequencePgClassOidField) +import Orville.PostgreSQL.PgCatalog.PgTrigger (PgTrigger, pgTriggerTable, triggerRelationOidField) import qualified Orville.PostgreSQL.Plan as Plan import qualified Orville.PostgreSQL.Plan.Many as Many import qualified Orville.PostgreSQL.Plan.Operation as Op -{- | - A description of selected items from a single PostgreSQL database. - 'describeDatabaseRelations' can be used to load the descriptions of request +{- | A description of selected items from a single PostgreSQL database. + 'describeDatabase' can be used to load the descriptions of request items. @since 1.0.0.0 -} data DatabaseDescription = DatabaseDescription { databaseRelations :: Map.Map (NamespaceName, RelationName) RelationDescription + -- ^ @since 1.0.0.0 + , databaseProcedures :: Map.Map (NamespaceName, ProcName) PgProc + -- ^ @since 1.1.0.0 + , databaseExtensions :: Map.Map ExtensionName PgExtension + -- ^ @since 1.1.0.0 } -{- | - Lookup a relation by its qualified name in the @pg_catalog@ schema. +{- | Lookup a relation by its qualified name in the @pg_catalog@ schema. @since 1.0.0.0 -} @@ -65,8 +76,29 @@ lookupRelation key = Map.lookup key . databaseRelations -{- | - Lookup a relation by its qualified name in the @pg_catalog@ schema. If the +{- | Lookup a procedure by its qualified name in the @pg_catalog@ schema. + +@since 1.1.0.0 +-} +lookupProcedure :: + (NamespaceName, ProcName) -> + DatabaseDescription -> + Maybe PgProc +lookupProcedure key = + Map.lookup key . databaseProcedures + +{- | Lookup an extension by its name in the @pg_catalog@ schema. + +@since 1.1.0.0 +-} +lookupExtension :: + ExtensionName -> + DatabaseDescription -> + Maybe PgExtension +lookupExtension key = + Map.lookup key . databaseExtensions + +{- | Lookup a relation by its qualified name in the @pg_catalog@ schema. If the relation is not of the expected kind, 'Nothing' is returned. @since 1.0.0.0 @@ -85,23 +117,33 @@ Nothing -> Nothing -{- | - A description of a particular relation in the PostgreSQL database, including +{- | A description of a particular relation in the PostgreSQL database, including the attributes of the relation. @since 1.0.0.0 -} data RelationDescription = RelationDescription { relationRecord :: PgClass + -- ^ @since 1.0.0.0 , relationAttributes :: Map.Map AttributeName PgAttribute + -- ^ @since 1.0.0.0 , relationAttributeDefaults :: Map.Map AttributeNumber PgAttributeDefault + -- ^ @since 1.0.0.0 , relationConstraints :: [ConstraintDescription] + -- ^ @since 1.0.0.0 , relationIndexes :: [IndexDescription] + -- ^ @since 1.0.0.0 + , relationTriggers :: [PgTrigger] + -- ^ @since 1.1.0.0 , relationSequence :: Maybe PgSequence + -- ^ @since 1.0.0.0 + , relationComment :: Maybe T.Text + -- ^ @since 1.1.0.0 + , relationAttributeComments :: Map.Map AttributeName T.Text + -- ^ @since 1.1.0.0 } -{- | - Find an attribute by name from the 'RelationDescription'. +{- | Find an attribute by name from the 'RelationDescription'. @since 1.0.0.0 -} @@ -112,8 +154,7 @@ lookupAttribute key = Map.lookup key . relationAttributes -{- | - Find an attribute default from the 'RelationDescription'. +{- | Find an attribute default from the 'RelationDescription'. @since 1.0.0.0 -} @@ -124,8 +165,18 @@ lookupAttributeDefault attr = Map.lookup (pgAttributeNumber attr) . relationAttributeDefaults -{- | - A description of a particular constraint in the PostgreSQL database, including +{- | Find an attribute comment by name from the 'RelationDescription' + +@since 1.1.0.0 +-} +lookupAttributeComment :: + AttributeName -> + RelationDescription -> + Maybe T.Text +lookupAttributeComment key = + Map.lookup key . relationAttributeComments + +{- | A description of a particular constraint in the PostgreSQL database, including the attributes and relations that it references. @since 1.0.0.0 @@ -137,8 +188,7 @@ , constraintForeignKey :: Maybe [PgAttribute] } -{- | - A description of a relation in the PostgreSQL database that is referenced by +{- | A description of a relation in the PostgreSQL database that is referenced by a foreign key constraint, including the namespace that the relation belongs to. @since 1.0.0.0 @@ -148,8 +198,7 @@ , foreignRelationNamespace :: PgNamespace } -{- | - A description of an index in the PostgreSQL database, including the names of +{- | A description of an index in the PostgreSQL database, including the names of the attributes included in the index and the 'PgClass' record of the index itself (NOT the 'PgClass' of the table that the index is for). @@ -161,8 +210,7 @@ , indexMembers :: [IndexMember] } -{- | - A description of an index member in the PostgreSQL database. If the member +{- | A description of an index member in the PostgreSQL database. If the member is a simple attribute, the 'PgAttribute' for that is provided. If it is an index over an expression, no further description is currently provided. @@ -172,35 +220,47 @@ = IndexAttribute PgAttribute | IndexExpression -{- | - Describes the requested relations in the current database. If any of the +{- | Describes the requested relations in the current database. If any of the relations do not exist, they will not have an entry in the returned description. Each 'RelationDescription' will contain all the attributes that currently exist for that relation, according to the @pg_catalog@ tables. -@since 1.0.0.0 +@since 1.1.0.0 -} -describeDatabaseRelations :: +describeDatabase :: Orville.MonadOrville m => [(NamespaceName, RelationName)] -> + [(NamespaceName, ProcName)] -> + [ExtensionName] -> m DatabaseDescription -describeDatabaseRelations relations = do +describeDatabase relations procedures extensions = do manyRelations <- Plan.execute (Plan.planMany describeRelationByName) relations + manyProcedures <- + Plan.execute + (Plan.planMany describeProcedureByName) + procedures + + manyExtensions <- + Plan.execute + (Plan.planMany describeExtensionByName) + extensions + let - relationsMap = - Map.mapMaybe id - . Many.toMap - $ manyRelations + mkMap :: Ord k => Many.Many k (Maybe v) -> Map.Map k v + mkMap = + Map.mapMaybe id . Many.toMap pure $ DatabaseDescription - { databaseRelations = relationsMap + { databaseRelations = mkMap manyRelations + , databaseProcedures = mkMap manyProcedures + , databaseExtensions = mkMap manyExtensions } describeRelationByName :: Plan.Plan scope (NamespaceName, RelationName) (Maybe RelationDescription) @@ -219,25 +279,29 @@ describeRelationByClass = Plan.bind Plan.askParam $ \pgClass -> Plan.bind findClassAttributes $ \attributes -> - let - classAndAttributes = - mkPgClassAndAttributes + Plan.bind findClassDescriptions $ \descriptions -> + let + classAndAttributes = + mkPgClassAndAttributes + <$> Plan.use pgClass + <*> Plan.use attributes + in + RelationDescription <$> Plan.use pgClass - <*> Plan.use attributes - in - RelationDescription - <$> Plan.use pgClass - <*> Plan.use (fmap (indexBy pgAttributeName) attributes) - <*> fmap (indexBy pgAttributeDefaultAttributeNumber) findClassAttributeDefaults - <*> Plan.chain classAndAttributes findClassConstraints - <*> Plan.chain classAndAttributes findClassIndexes - <*> Plan.using pgClass findClassSequence + <*> Plan.use (fmap (indexBy pgAttributeName) attributes) + <*> fmap (indexBy pgAttributeDefaultAttributeNumber) findClassAttributeDefaults + <*> Plan.chain classAndAttributes findClassConstraints + <*> Plan.chain classAndAttributes findClassIndexes + <*> Plan.using pgClass findClassTriggers + <*> Plan.using pgClass findClassSequence + <*> fmap (Map.lookup objectSubIdZero) (Plan.use descriptions) + <*> liftA2 mkAttributeCommentMap (Plan.use descriptions) (Plan.use attributes) findRelation :: Plan.Plan scope (PgNamespace, RelationName) (Maybe PgClass) findRelation = - Plan.focusParam (\(ns, relname) -> (pgNamespaceOid ns, relname)) $ - Plan.planOperation $ - Op.findOne pgClassTable byNamespaceOidAndRelationName + Plan.focusParam (\(ns, relname) -> (pgNamespaceOid ns, relname)) + . Plan.planOperation + $ Op.findOne pgClassTable byNamespaceOidAndRelationName byNamespaceOidAndRelationName :: Op.WherePlanner (LibPQ.Oid, RelationName) byNamespaceOidAndRelationName = @@ -327,9 +391,9 @@ LibPQ.Oid 0 -> Nothing nonZero -> Just nonZero in - Plan.focusParam relationId $ - Plan.planMaybe $ - Plan.findOne pgClassTable oidField + Plan.focusParam relationId + . Plan.planMaybe + $ Plan.findOne pgClassTable oidField findClassIndexes :: Plan.Plan scope PgClassAndAttributes [IndexDescription] findClassIndexes = @@ -429,6 +493,61 @@ findClassSequence = Plan.focusParam pgClassOid $ Plan.findMaybeOne pgSequenceTable sequencePgClassOidField + +findClassDescriptions :: Plan.Plan scope PgClass (Map.Map ObjectSubId T.Text) +findClassDescriptions = + let + mkObjectSubIdMap = + Map.fromList + . fmap + ( \pgDescription -> + (pgDescriptionObjSubId pgDescription, pgDescriptionDescription pgDescription) + ) + in + fmap mkObjectSubIdMap . Plan.focusParam pgClassOid $ Plan.findAll pgDescriptionTable objOidField + +mkAttributeCommentMap :: Map.Map ObjectSubId T.Text -> [PgAttribute] -> Map.Map AttributeName T.Text +mkAttributeCommentMap descriptionMap = + foldMap + ( \attribute -> + maybe + mempty + (Map.singleton (pgAttributeName attribute)) + ( Map.lookup + (objectSubIdFromAttributeNumber $ pgAttributeNumber attribute) + descriptionMap + ) + ) + +findClassTriggers :: Plan.Plan scope PgClass [PgTrigger] +findClassTriggers = + Plan.focusParam pgClassOid $ + Plan.findAll pgTriggerTable triggerRelationOidField + +describeProcedureByName :: Plan.Plan scope (NamespaceName, ProcName) (Maybe PgProc) +describeProcedureByName = + Plan.bind (fst <$> Plan.askParam) $ \namespaceName -> + Plan.bind (snd <$> Plan.askParam) $ \procName -> + Plan.bind (Plan.using namespaceName findNamespace) $ \namespace -> + let + namespaceAndProcName = + (,) <$> Plan.use namespace <*> Plan.use procName + in + Plan.chain namespaceAndProcName findProc + +findProc :: Plan.Plan scope (PgNamespace, ProcName) (Maybe PgProc) +findProc = + Plan.focusParam (\(ns, procName) -> (pgNamespaceOid ns, procName)) + . Plan.planOperation + $ Op.findOne pgProcTable byNamespaceOidAndProcName + +byNamespaceOidAndProcName :: Op.WherePlanner (LibPQ.Oid, ProcName) +byNamespaceOidAndProcName = + Op.byFieldTuple procNamespaceOidField procNameField + +describeExtensionByName :: Plan.Plan scope ExtensionName (Maybe PgExtension) +describeExtensionByName = + Plan.findMaybeOne pgExtensionTable extensionNameField indexBy :: Ord key => (row -> key) -> [row] -> Map.Map key row indexBy rowKey = diff --git a/src/Orville/PostgreSQL/PgCatalog/OidField.hs b/src/Orville/PostgreSQL/PgCatalog/OidField.hs --- a/src/Orville/PostgreSQL/PgCatalog/OidField.hs +++ b/src/Orville/PostgreSQL/PgCatalog/OidField.hs @@ -16,8 +16,7 @@ import qualified Orville.PostgreSQL as Orville import qualified Orville.PostgreSQL.Marshall.SqlType as SqlType -{- | - The @oid@ field found on many (but not all!) @pg_catalog@ tables. +{- | The @oid@ field found on many (but not all!) @pg_catalog@ tables. @since 1.0.0.0 -} @@ -25,8 +24,7 @@ oidField = oidTypeField "oid" -{- | - Builds a 'Orville.FieldDefinition' with the given column name that stores +{- | Builds a 'Orville.FieldDefinition' with the given column name that stores an @oid@ value. @since 1.0.0.0 diff --git a/src/Orville/PostgreSQL/PgCatalog/PgAttribute.hs b/src/Orville/PostgreSQL/PgCatalog/PgAttribute.hs --- a/src/Orville/PostgreSQL/PgCatalog/PgAttribute.hs +++ b/src/Orville/PostgreSQL/PgCatalog/PgAttribute.hs @@ -37,10 +37,10 @@ import qualified Database.PostgreSQL.LibPQ as LibPQ import qualified Orville.PostgreSQL as Orville +import qualified Orville.PostgreSQL.Marshall as Marshall import Orville.PostgreSQL.PgCatalog.OidField (oidTypeField) -{- | - The Haskell representation of data read from the @pg_catalog.pg_attribute@ +{- | The Haskell representation of data read from the @pg_catalog.pg_attribute@ table. Rows in this table correspond to table columns, but also to attributes of other items from the @pg_class@ table. @@ -65,14 +65,15 @@ , pgAttributeTypeModifier :: Int32 -- ^ Type-specific data supplied at creation time, such as the maximum length -- of a @varchar@ column. + , pgAttributeIdentity :: Maybe Marshall.FieldIdentityGeneration + -- ^ Indicates whether the column is an identity and how it is generated if at all. , pgAttributeIsDropped :: Bool -- ^ Indicates whether the column has been dropped and is not longer valid. , pgAttributeIsNotNull :: Bool -- ^ Indicates whether the column has a not-null constraint. } -{- | - Returns the maximum length for an attribute with a variable length type, +{- | Returns the maximum length for an attribute with a variable length type, or 'Nothing' if the length of the type is not variable. @since 1.0.0.0 @@ -108,8 +109,7 @@ then Just typeMod else Nothing -{- | - Determines whether the attribute represents a system column by inspecting +{- | Determines whether the attribute represents a system column by inspecting the attribute\'s 'AttributeNumber'. Ordinary columns have attribute numbers starting at 1. @@ -119,17 +119,24 @@ isOrdinaryColumn attr = pgAttributeNumber attr > AttributeNumber 0 -{- | - A Haskell type for the name of the attribute represented by a 'PgAttribute'. +{- | A Haskell type for the name of the attribute represented by a 'PgAttribute'. @since 1.0.0.0 -} newtype AttributeName = AttributeName T.Text - deriving (Show, Eq, Ord, String.IsString) + deriving + ( -- | @since 1.0.0.0 + Show + , -- | @since 1.0.0.0 + Eq + , -- | @since 1.0.0.0 + Ord + , -- | @since 1.0.0.0 + String.IsString + ) -{- | - Converts an 'AttributeName' to a plain 'String'. +{- | Converts an 'AttributeName' to a plain 'String'. @since 1.0.0.0 -} @@ -137,29 +144,44 @@ attributeNameToString (AttributeName txt) = T.unpack txt -{- | - A Haskell type for the number of the attribute represented by a 'PgAttribute'. +{- | A Haskell type for the number of the attribute represented by a 'PgAttribute'. @since 1.0.0.0 -} newtype AttributeNumber = AttributeNumber Int16 - deriving (Show, Eq, Ord, Enum, Num, Integral, Real) + deriving + ( -- | @since 1.0.0.0 + Show + , -- | @since 1.0.0.0 + Eq + , -- | @since 1.0.0.0 + Ord + , -- | @since 1.0.0.0 + Enum + , -- | @since 1.0.0.0 + Num + , -- | @since 1.0.0.0 + Integral + , -- | @since 1.0.0.0 + Real + ) -{- | - Converts an 'AttributeNumber' to an integer. +{- | Converts an 'AttributeNumber' to an integer. + +@since 1.0.0.0 -} attributeNumberToInt16 :: AttributeNumber -> Int16 attributeNumberToInt16 (AttributeNumber int) = int -{- | - Converts an integer to an 'AttributeNumber'. +{- | Converts an integer to an 'AttributeNumber'. + +@since 1.0.0.0 -} attributeNumberFromInt16 :: Int16 -> AttributeNumber attributeNumberFromInt16 = AttributeNumber -{- | - Attoparsec parser for 'AttributeNumber'. +{- | Attoparsec parser for 'AttributeNumber'. @since 1.0.0.0 -} @@ -167,8 +189,7 @@ attributeNumberParser = AttoText.signed AttoText.decimal -{- | - Encodes an 'AttributeNumber' to lazy text as a builder. +{- | Encodes an 'AttributeNumber' to lazy text as a builder. @since 1.0.0.0 -} @@ -176,8 +197,7 @@ attributeNumberTextBuilder = LTBI.decimal . attributeNumberToInt16 -{- | - An Orville 'Orville.TableDefinition' for querying the +{- | An Orville 'Orville.TableDefinition' for querying the @pg_catalog.pg_attribute@ table. @since 1.0.0.0 @@ -198,11 +218,11 @@ <*> Orville.marshallField pgAttributeTypeOid attributeTypeOidField <*> Orville.marshallField pgAttributeLength attributeLengthField <*> Orville.marshallField pgAttributeTypeModifier attributeTypeModifierField + <*> Orville.marshallField pgAttributeIdentity attributeIdentityField <*> Orville.marshallField pgAttributeIsDropped attributeIsDroppedField <*> Orville.marshallField pgAttributeIsNotNull attributeIsNotNullField -{- | - The @attrelid@ column of the @pg_catalog.pg_attribute@ table. +{- | The @attrelid@ column of the @pg_catalog.pg_attribute@ table. @since 1.0.0.0 -} @@ -210,8 +230,7 @@ attributeRelationOidField = oidTypeField "attrelid" -{- | - The @attname@ column of the @pg_catalog.pg_attribute@ table. +{- | The @attname@ column of the @pg_catalog.pg_attribute@ table. @since 1.0.0.0 -} @@ -220,8 +239,7 @@ Orville.coerceField $ Orville.unboundedTextField "attname" -{- | - The @attnum@ column of the @pg_catalog.pg_attribute@ table. +{- | The @attnum@ column of the @pg_catalog.pg_attribute@ table. @since 1.0.0.0 -} @@ -229,8 +247,7 @@ attributeNumberField = attributeNumberTypeField "attnum" -{- | - Builds a 'Orville.FieldDefinition' for a field with type 'AttributeNumber'. +{- | Builds a 'Orville.FieldDefinition' for a field with type 'AttributeNumber'. @since 1.0.0.0 -} @@ -238,8 +255,7 @@ attributeNumberTypeField = Orville.coerceField . Orville.smallIntegerField -{- | - The @atttypid@ column of the @pg_catalog.pg_attribute@ table. +{- | The @atttypid@ column of the @pg_catalog.pg_attribute@ table. @since 1.0.0.0 -} @@ -247,8 +263,7 @@ attributeTypeOidField = oidTypeField "atttypid" -{- | - The @attlen@ column of the @pg_catalog.pg_attribute@ table. +{- | The @attlen@ column of the @pg_catalog.pg_attribute@ table. @since 1.0.0.0 -} @@ -256,8 +271,7 @@ attributeLengthField = Orville.smallIntegerField "attlen" -{- | - The @atttypmod@ column of the @pg_catalog.pg_attribute@ table. +{- | The @atttypmod@ column of the @pg_catalog.pg_attribute@ table. @since 1.0.0.0 -} @@ -265,20 +279,56 @@ attributeTypeModifierField = Orville.integerField "atttypmod" -{- | - The @attisdropped@ column of the @pg_catalog.pg_attribute@ table. +{- | The @attidentity@ column of the @pg_catalog.pg_attribute@ table. +@since 1.1.0.0 +-} +attributeIdentityField :: + Orville.FieldDefinition + Orville.NotNull + (Maybe Marshall.FieldIdentityGeneration) +attributeIdentityField = + Orville.convertField + (Orville.tryConvertSqlType columnIdentityToPgText pgTextToColumnIdentity) + (Orville.fixedTextField "attidentity" 1) + +{- | The @attisdropped@ column of the @pg_catalog.pg_attribute@ table. + @since 1.0.0.0 -} attributeIsDroppedField :: Orville.FieldDefinition Orville.NotNull Bool attributeIsDroppedField = Orville.booleanField "attisdropped" -{- | - The @attnotnull@ column of the @pg_catalog.pg_attribute@ table. +{- | The @attnotnull@ column of the @pg_catalog.pg_attribute@ table. @since 1.0.0.0 -} attributeIsNotNullField :: Orville.FieldDefinition Orville.NotNull Bool attributeIsNotNullField = Orville.booleanField "attnotnull" + +{- | Internal, convert a 'T.Text' to a 'Maybe Marshall.FieldIdentityGeneration', allowing for the empty text case + to be Nothing. + +@since 1.1.0.0 +-} +pgTextToColumnIdentity :: T.Text -> Either String (Maybe Marshall.FieldIdentityGeneration) +pgTextToColumnIdentity text = + case T.unpack text of + "" -> Right Nothing + "a" -> Right (Just Marshall.GeneratedAlways) + "d" -> Right (Just Marshall.GeneratedByDefault) + attid -> Left ("Unrecognized PostgreSQL attribute identity: " <> attid) + +{- | Internal, convert a 'Maybe Expr.ColumnIdentity' to a 'T.Text', allowing for the Nothing case to + be the empty text. + +@since 1.1.0.0 +-} +columnIdentityToPgText :: Maybe Marshall.FieldIdentityGeneration -> T.Text +columnIdentityToPgText attid = + T.pack $ case attid of + Nothing -> "" + (Just Marshall.GeneratedAlways) -> "a" + (Just Marshall.GeneratedByDefault) -> "d" diff --git a/src/Orville/PostgreSQL/PgCatalog/PgAttributeDefault.hs b/src/Orville/PostgreSQL/PgCatalog/PgAttributeDefault.hs --- a/src/Orville/PostgreSQL/PgCatalog/PgAttributeDefault.hs +++ b/src/Orville/PostgreSQL/PgCatalog/PgAttributeDefault.hs @@ -1,5 +1,5 @@ {- | -Copyright : Flipstone Technology Partners 2023 +Copyright : Flipstone Technology Partners 2023-2024 License : MIT Stability : Stable @@ -16,13 +16,12 @@ import qualified Database.PostgreSQL.LibPQ as LibPQ import qualified Orville.PostgreSQL as Orville +import qualified Orville.PostgreSQL.Marshall as Marshall import Orville.PostgreSQL.PgCatalog.OidField (oidField, oidTypeField) import Orville.PostgreSQL.PgCatalog.PgAttribute (AttributeNumber, attributeNumberTypeField) import qualified Orville.PostgreSQL.Raw.RawSql as RawSql -import qualified Orville.PostgreSQL.Raw.SqlValue as SqlValue -{- | - The Haskell representation of data read from the @pg_catalog.pg_attrdef@ +{- | The Haskell representation of data read from the @pg_catalog.pg_attrdef@ table. @since 1.0.0.0 @@ -41,8 +40,7 @@ -- @adbin@ column using the PostgreSQL @pg_get_expr@ function. } -{- | - An Orville 'Orville.TableDefinition' for querying the +{- | An Orville 'Orville.TableDefinition' for querying the @pg_catalog.pg_attrdef@ table. @since 1.0.0.0 @@ -62,8 +60,7 @@ <*> Orville.marshallField pgAttributeDefaultAttributeNumber attributeDefaultAttributeNumberField <*> Orville.marshallSyntheticField attributeDefaultExpressionField -{- | - The @adrelid@ column of the @pg_catalog.pg_attrdef@ table. +{- | The @adrelid@ column of the @pg_catalog.pg_attrdef@ table. @since 1.0.0.0 -} @@ -71,8 +68,7 @@ attributeDefaultRelationOidField = oidTypeField "adrelid" -{- | - The @adnum@ column of the @pg_catalog.pg_attrdef@ table. +{- | The @adnum@ column of the @pg_catalog.pg_attrdef@ table. @since 1.0.0.0 -} @@ -80,8 +76,7 @@ attributeDefaultAttributeNumberField = attributeNumberTypeField "adnum" -{- | - A syntheticField for selecting the default expression by decompiling the +{- | A syntheticField for selecting the default expression by decompiling the @adbin@ column of the @pg_catalog.pg_attrdef@ table. The @pg_node_tree@ found in the column is decompiled by selecting the expression @pg_get_expr(adbin,adrelid)@. @@ -93,4 +88,4 @@ Orville.syntheticField (RawSql.unsafeSqlExpression "pg_get_expr(adbin,adrelid)") "expression" - SqlValue.toText + Marshall.unboundedText diff --git a/src/Orville/PostgreSQL/PgCatalog/PgClass.hs b/src/Orville/PostgreSQL/PgCatalog/PgClass.hs --- a/src/Orville/PostgreSQL/PgCatalog/PgClass.hs +++ b/src/Orville/PostgreSQL/PgCatalog/PgClass.hs @@ -26,8 +26,7 @@ import qualified Orville.PostgreSQL as Orville import Orville.PostgreSQL.PgCatalog.OidField (oidField, oidTypeField) -{- | - The Haskell representation of data read from the @pg_catalog.pg_class@ +{- | The Haskell representation of data read from the @pg_catalog.pg_class@ table. Rows in this table correspond to tables, indexes, sequences, views, materialized views, composite types and TOAST tables. @@ -45,17 +44,24 @@ -- ^ The kind of relation (table, view, etc). } -{- | - A Haskell type for the name of the relation represented by a 'PgClass'. +{- | A Haskell type for the name of the relation represented by a 'PgClass'. @since 1.0.0.0 -} newtype RelationName = RelationName T.Text - deriving (Show, Eq, Ord, String.IsString) + deriving + ( -- | @since 1.0.0.0 + Show + , -- | @since 1.0.0.0 + Eq + , -- | @since 1.0.0.0 + Ord + , -- | @since 1.0.0.0 + String.IsString + ) -{- | - Convert a 'RelationName' to a plain 'String'. +{- | Convert a 'RelationName' to a plain 'String'. @since 1.0.0.0 -} @@ -63,8 +69,7 @@ relationNameToString (RelationName text) = T.unpack text -{- | - The kind of relation represented by a 'PgClass', as described at +{- | The kind of relation represented by a 'PgClass', as described at https://www.postgresql.org/docs/13/catalog-pg-class.html. @since 1.0.0.0 @@ -80,10 +85,14 @@ | ForeignTable | PartitionedTable | PartitionedIndex - deriving (Show, Eq) + deriving + ( -- | @since 1.0.0.0 + Show + , -- | @since 1.0.0.0 + Eq + ) -{- | - An Orville 'Orville.TableDefinition' for querying the +{- | An Orville 'Orville.TableDefinition' for querying the @pg_catalog.pg_class@ table. @since 1.0.0.0 @@ -104,8 +113,7 @@ <*> Orville.marshallField pgClassRelationName relationNameField <*> Orville.marshallField pgClassRelationKind relationKindField -{- | - The @relnamespace@ column of the @pg_catalog.pg_class@ table. +{- | The @relnamespace@ column of the @pg_catalog.pg_class@ table. @since 1.0.0.0 -} @@ -113,8 +121,7 @@ namespaceOidField = oidTypeField "relnamespace" -{- | - The @relname@ column of the @pg_catalog.pg_class@ table. +{- | The @relname@ column of the @pg_catalog.pg_class@ table. @since 1.0.0.0 -} @@ -123,8 +130,7 @@ Orville.coerceField $ Orville.unboundedTextField "relname" -{- | - The @relkind@ column of the @pg_catalog.pg_class@ table. +{- | The @relkind@ column of the @pg_catalog.pg_class@ table. @since 1.0.0.0 -} @@ -134,8 +140,7 @@ (Orville.tryConvertSqlType relationKindToPgText pgTextToRelationKind) (Orville.unboundedTextField "relkind") -{- | - Converts a 'RelationKind' to the corresponding single character text +{- | Converts a 'RelationKind' to the corresponding single character text representation used by PostgreSQL. See also 'pgTextToRelationKind' @@ -157,8 +162,7 @@ PartitionedTable -> "p" PartitionedIndex -> "I" -{- | - Attempts to parse a PostgreSQL single character textual value as a +{- | Attempts to parse a PostgreSQL single character textual value as a 'RelationKind'. See also 'relationKindToPgText' diff --git a/src/Orville/PostgreSQL/PgCatalog/PgConstraint.hs b/src/Orville/PostgreSQL/PgCatalog/PgConstraint.hs --- a/src/Orville/PostgreSQL/PgCatalog/PgConstraint.hs +++ b/src/Orville/PostgreSQL/PgCatalog/PgConstraint.hs @@ -29,8 +29,7 @@ import Orville.PostgreSQL.PgCatalog.OidField (oidField, oidTypeField) import Orville.PostgreSQL.PgCatalog.PgAttribute (AttributeNumber, attributeNumberParser, attributeNumberTextBuilder) -{- | - The Haskell representation of data read from the @pg_catalog.pg_constraint@ +{- | The Haskell representation of data read from the @pg_catalog.pg_constraint@ table. Rows in this table correspond to check, primary key, unique, foreign key and exclusion constraints on tables. @@ -69,18 +68,25 @@ -- ^ For foreign key constraints, the on delete action type. } -{- | - A Haskell type for the name of the constraint represented by a +{- | A Haskell type for the name of the constraint represented by a 'PgConstraint'. @since 1.0.0.0 -} newtype ConstraintName = ConstraintName T.Text - deriving (Show, Eq, Ord, String.IsString) + deriving + ( -- | @since 1.0.0.0 + Show + , -- | @since 1.0.0.0 + Eq + , -- | @since 1.0.0.0 + Ord + , -- | @since 1.0.0.0 + String.IsString + ) -{- | - Converts a 'ConstraintName' to a plain 'String'. +{- | Converts a 'ConstraintName' to a plain 'String'. @since 1.0.0.0 -} @@ -88,8 +94,7 @@ constraintNameToString (ConstraintName txt) = T.unpack txt -{- | - The type of constraint that a 'PgConstraint' represents, as described at +{- | The type of constraint that a 'PgConstraint' represents, as described at https://www.postgresql.org/docs/13/catalog-pg-constraint.html. @since 1.0.0.0 @@ -101,10 +106,14 @@ | UniqueConstraint | ConstraintTrigger | ExclusionConstraint - deriving (Show, Eq) + deriving + ( -- | @since 1.0.0.0 + Show + , -- | @since 1.0.0.0 + Eq + ) -{- | - Converts a 'ConstraintType' to the corresponding single character text +{- | Converts a 'ConstraintType' to the corresponding single character text representation used by PostgreSQL. See also 'pgTextToConstraintType' @@ -122,8 +131,7 @@ ConstraintTrigger -> "t" ExclusionConstraint -> "x" -{- | - Attempts to parse a PostgreSQL single character textual value as a +{- | Attempts to parse a PostgreSQL single character textual value as a 'ConstraintType' See also 'constraintTypeToPgText' @@ -141,8 +149,7 @@ "x" -> Right ExclusionConstraint typ -> Left ("Unrecognized PostgreSQL constraint type: " <> typ) -{- | - Converts a 'Maybe Orville.ForeignKeyAction' to the corresponding single character +{- | Converts a 'Maybe Orville.ForeignKeyAction' to the corresponding single character text representation used by PostgreSQL. See also 'pgTextToForeignKeyAction' @@ -160,8 +167,7 @@ Just Orville.SetDefault -> "d" Nothing -> " " -{- | - Attempts to parse a PostgreSQL single character textual value as a +{- | Attempts to parse a PostgreSQL single character textual value as a 'Maybe Orville.ForeignKeyAction' See also 'foreignKeyActionToPgText' @@ -179,8 +185,7 @@ " " -> Right Nothing typ -> Left ("Unrecognized PostgreSQL foreign key action type: " <> typ) -{- | - An Orville 'Orville.TableDefinition' for querying the +{- | An Orville 'Orville.TableDefinition' for querying the @pg_catalog.pg_constraint@ table. @since 1.0.0.0 @@ -208,8 +213,7 @@ <*> Orville.marshallField pgConstraintForeignKeyOnUpdateType constraintForeignKeyOnUpdateTypeField <*> Orville.marshallField pgConstraintForeignKeyOnDeleteType constraintForeignKeyOnDeleteTypeField -{- | - The @conname@ column of the @pg_constraint@ table. +{- | The @conname@ column of the @pg_constraint@ table. @since 1.0.0.0 -} @@ -218,8 +222,7 @@ Orville.coerceField $ Orville.unboundedTextField "conname" -{- | - The @connamespace@ column of the @pg_constraint@ table. +{- | The @connamespace@ column of the @pg_constraint@ table. @since 1.0.0.0 -} @@ -227,8 +230,7 @@ constraintNamespaceOidField = oidTypeField "connamespace" -{- | - The @contype@ column of the @pg_constraint@ table. +{- | The @contype@ column of the @pg_constraint@ table. @since 1.0.0.0 -} @@ -238,8 +240,7 @@ (Orville.tryConvertSqlType constraintTypeToPgText pgTextToConstraintType) (Orville.unboundedTextField "contype") -{- | - The @conrelid@ column of the @pg_constraint@ table. +{- | The @conrelid@ column of the @pg_constraint@ table. @since 1.0.0.0 -} @@ -247,8 +248,7 @@ constraintRelationOidField = oidTypeField "conrelid" -{- | - The @conindid@ column of the @pg_constraint@ table. +{- | The @conindid@ column of the @pg_constraint@ table. @since 1.0.0.0 -} @@ -256,8 +256,7 @@ constraintIndexOidField = oidTypeField "conindid" -{- | - The @conkey@ column of the @pg_constraint@ table. +{- | The @conkey@ column of the @pg_constraint@ table. @since 1.0.0.0 -} @@ -268,8 +267,7 @@ (Orville.tryConvertSqlType attributeNumberListToPgArrayText pgArrayTextToAttributeNumberList) (Orville.unboundedTextField "conkey") -{- | - The @confrelid@ column of the @pg_constraint@ table. +{- | The @confrelid@ column of the @pg_constraint@ table. @since 1.0.0.0 -} @@ -277,8 +275,7 @@ constraintForeignRelationOidField = oidTypeField "confrelid" -{- | - The @confkey@ column of the @pg_constraint@ table. +{- | The @confkey@ column of the @pg_constraint@ table. @since 1.0.0.0 -} diff --git a/src/Orville/PostgreSQL/PgCatalog/PgDescription.hs b/src/Orville/PostgreSQL/PgCatalog/PgDescription.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/PgCatalog/PgDescription.hs @@ -0,0 +1,103 @@ +{- | +Copyright : Flipstone Technology Partners 2023 +License : MIT +Stability : Stable + +@since 1.1.0.0 +-} +module Orville.PostgreSQL.PgCatalog.PgDescription + ( PgDescription (..) + , ObjectSubId + , objectSubIdFromAttributeNumber + , objectSubIdZero + , pgDescriptionTable + , objOidField + , objSubIdField + , descriptionField + ) where + +import Data.Int (Int32) +import qualified Data.Text as T +import qualified Database.PostgreSQL.LibPQ as LibPQ + +import qualified Orville.PostgreSQL as Orville +import Orville.PostgreSQL.PgCatalog.OidField (oidTypeField) +import Orville.PostgreSQL.PgCatalog.PgAttribute (AttributeNumber, attributeNumberToInt16) + +{- | The Haskell representation of data read from the @pg_catalog.pg_description@ + table. + +@since 1.1.0.0 +-} +data PgDescription = PgDescription + { pgDescriptionObjOid :: LibPQ.Oid + -- ^ @since 1.1.0.0 + , pgDescriptionClassOid :: LibPQ.Oid + -- ^ @since 1.1.0.0 + , pgDescriptionObjSubId :: ObjectSubId + -- ^ @since 1.1.0.0 + , pgDescriptionDescription :: T.Text + -- ^ @since 1.1.0.0 + } + +{- | Represents the value in the @objsubid@ field. For tables, this corresponds to the + 'AttributeNumber' of the column and indicates that the @description@ field contains + the comment for that column. + + Note that the @objsubid@ field is an @int4@ as opposed to an @int2@ like the @attnum@ + field in @pg_attribute@. + +@since 1.1.0.0 +-} +newtype ObjectSubId = ObjectSubId Int32 + deriving + ( -- | @since 1.1.0.0 + Eq + , -- | @since 1.1.0.0 + Ord + ) + +{- | Convert an 'AttributeNumber' to an 'ObjectSubId' + +@since 1.1.0.0 +-} +objectSubIdFromAttributeNumber :: AttributeNumber -> ObjectSubId +objectSubIdFromAttributeNumber = ObjectSubId . fromIntegral . attributeNumberToInt16 + +{- | A 'ObjectSubId' of 0 in the @objsubid@ field for a table corresponds to the + comment on the table. + +@since 1.1.0.0 +-} +objectSubIdZero :: ObjectSubId +objectSubIdZero = ObjectSubId 0 + +-- | @since 1.1.0.0 +pgDescriptionTable :: Orville.TableDefinition (Orville.HasKey LibPQ.Oid) PgDescription PgDescription +pgDescriptionTable = + Orville.mkTableDefinition "pg_description" (Orville.primaryKey objOidField) pgDescriptionMarshaller + +-- | @since 1.1.0.0 +pgDescriptionMarshaller :: Orville.SqlMarshaller PgDescription PgDescription +pgDescriptionMarshaller = + PgDescription + <$> Orville.marshallField pgDescriptionObjOid objOidField + <*> Orville.marshallField pgDescriptionClassOid classOidField + <*> Orville.marshallField pgDescriptionObjSubId objSubIdField + <*> Orville.marshallField pgDescriptionDescription descriptionField + +-- | @since 1.1.0.0 +objOidField :: Orville.FieldDefinition Orville.NotNull LibPQ.Oid +objOidField = oidTypeField "objoid" + +-- | @since 1.1.0.0 +classOidField :: Orville.FieldDefinition Orville.NotNull LibPQ.Oid +classOidField = oidTypeField "classoid" + +-- | @since 1.1.0.0 +objSubIdField :: Orville.FieldDefinition Orville.NotNull ObjectSubId +objSubIdField = Orville.coerceField $ Orville.integerField "objsubid" + +-- | @since 1.1.0.0 +descriptionField :: Orville.FieldDefinition Orville.NotNull T.Text +descriptionField = Orville.unboundedTextField "description" diff --git a/src/Orville/PostgreSQL/PgCatalog/PgExtension.hs b/src/Orville/PostgreSQL/PgCatalog/PgExtension.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/PgCatalog/PgExtension.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{- | +Copyright : Flipstone Technology Partners 2024 +License : MIT +Stability : Stable + +@since 1.1.0.0 +-} +module Orville.PostgreSQL.PgCatalog.PgExtension + ( PgExtension (..) + , ExtensionName + , pgExtensionTable + , extensionNameField + ) +where + +import qualified Data.String as String +import qualified Data.Text as T + +import qualified Orville.PostgreSQL as Orville + +{- | The Haskell representation of data read from the @pg_catalog.pg_extension@ table. + Rows in this table contain extended information about extensions. + +@since 1.1.0.0 +-} +newtype PgExtension = PgExtension + { pgExtensionName :: ExtensionName + -- ^ The PostgreSQL name for this extension. + } + +{- | A Haskell type for the name of the extension represented by a 'PgExtension'. + +@since 1.1.0.0 +-} +newtype ExtensionName + = ExtensionName T.Text + deriving + ( -- | @since 1.1.0.0 + Show + , -- | @since 1.1.0.0 + Eq + , -- | @since 1.1.0.0 + Ord + , -- | @since 1.1.0.0 + String.IsString + ) + +{- | An Orville 'Orville.TableDefinition' for querying the + @pg_catalog.pg_extension@ table. + +@since 1.0.0.0 +-} +pgExtensionTable :: Orville.TableDefinition Orville.NoKey PgExtension PgExtension +pgExtensionTable = + Orville.setTableSchema "pg_catalog" $ + Orville.mkTableDefinitionWithoutKey + "pg_extension" + pgExtensionMarshaller + +pgExtensionMarshaller :: Orville.SqlMarshaller PgExtension PgExtension +pgExtensionMarshaller = + PgExtension + <$> Orville.marshallField pgExtensionName extensionNameField + +{- | The @extname@ column of the @pg_extension@ table. + +@since 1.1.0.0 +-} +extensionNameField :: Orville.FieldDefinition Orville.NotNull ExtensionName +extensionNameField = + Orville.coerceField $ + Orville.boundedTextField "extname" 63 diff --git a/src/Orville/PostgreSQL/PgCatalog/PgIndex.hs b/src/Orville/PostgreSQL/PgCatalog/PgIndex.hs --- a/src/Orville/PostgreSQL/PgCatalog/PgIndex.hs +++ b/src/Orville/PostgreSQL/PgCatalog/PgIndex.hs @@ -24,8 +24,7 @@ import Orville.PostgreSQL.PgCatalog.OidField (oidTypeField) import Orville.PostgreSQL.PgCatalog.PgAttribute (AttributeNumber, attributeNumberParser, attributeNumberTextBuilder) -{- | - The Haskell representation of data read from the @pg_catalog.pg_index@ table. +{- | The Haskell representation of data read from the @pg_catalog.pg_index@ table. Rows in this table contain extended information about indices. Information about indices is also contained in the @pg_catalog.pg_class@ table as well. @@ -54,8 +53,7 @@ -- dropped and should be ignored. } -{- | - An Orville 'Orville.TableDefinition' for querying the +{- | An Orville 'Orville.TableDefinition' for querying the @pg_catalog.pg_index@ table. @since 1.0.0.0 @@ -77,8 +75,7 @@ <*> Orville.marshallField pgIndexIsPrimary indexIsPrimaryField <*> Orville.marshallField pgIndexIsLive indexIsLiveField -{- | - The @indexrelid@ column of the @pg_index@ table. +{- | The @indexrelid@ column of the @pg_index@ table. @since 1.0.0.0 -} @@ -86,8 +83,7 @@ indexPgClassOidField = oidTypeField "indexrelid" -{- | - The @indrelid@ column of the @pg_index@ table. +{- | The @indrelid@ column of the @pg_index@ table. @since 1.0.0.0 -} @@ -95,8 +91,7 @@ indexRelationOidField = oidTypeField "indrelid" -{- | - The @indkey@ column of the @pg_index@ table. +{- | The @indkey@ column of the @pg_index@ table. @since 1.0.0.0 -} @@ -106,8 +101,7 @@ (Orville.tryConvertSqlType attributeNumberListToPgVectorText pgVectorTextToAttributeNumberList) (Orville.unboundedTextField "indkey") -{- | - The @indisunique@ column of the @pg_index@ table. +{- | The @indisunique@ column of the @pg_index@ table. @since 1.0.0.0 -} @@ -115,8 +109,7 @@ indexIsUniqueField = Orville.booleanField "indisunique" -{- | - The @indisprimary@ column of the @pg_index@ table. +{- | The @indisprimary@ column of the @pg_index@ table. @since 1.0.0.0 -} @@ -124,8 +117,7 @@ indexIsPrimaryField = Orville.booleanField "indisprimary" -{- | - The @indislive@ column of the @pg_index@ table. +{- | The @indislive@ column of the @pg_index@ table. @since 1.0.0.0 -} diff --git a/src/Orville/PostgreSQL/PgCatalog/PgNamespace.hs b/src/Orville/PostgreSQL/PgCatalog/PgNamespace.hs --- a/src/Orville/PostgreSQL/PgCatalog/PgNamespace.hs +++ b/src/Orville/PostgreSQL/PgCatalog/PgNamespace.hs @@ -23,8 +23,7 @@ import qualified Orville.PostgreSQL as Orville import Orville.PostgreSQL.PgCatalog.OidField (oidField) -{- | - The Haskell representation of data read from the @pg_catalog.pg_namespace@ +{- | The Haskell representation of data read from the @pg_catalog.pg_namespace@ table. Namespaces in @pg_catalog@ correspond to "schema" concept in database organization. @@ -38,17 +37,24 @@ -- ^ The name of the namespace. } -{- | - A Haskell type for the name of a namespace. +{- | A Haskell type for the name of a namespace. @since 1.0.0.0 -} newtype NamespaceName = NamespaceName T.Text - deriving (Show, Eq, Ord, String.IsString) + deriving + ( -- | @since 1.0.0.0 + Show + , -- | @since 1.0.0.0 + Eq + , -- | @since 1.0.0.0 + Ord + , -- | @since 1.0.0.0 + String.IsString + ) -{- | - Convert a 'NamespaceName' to a plain 'String'. +{- | Convert a 'NamespaceName' to a plain 'String'. @since 1.0.0.0 -} @@ -56,8 +62,7 @@ namespaceNameToString (NamespaceName text) = T.unpack text -{- | - An Orville 'Orville.TableDefinition' for querying the +{- | An Orville 'Orville.TableDefinition' for querying the @pg_catalog.pg_namespace@ table. @since 1.0.0.0 @@ -76,8 +81,7 @@ <$> Orville.marshallField pgNamespaceOid oidField <*> Orville.marshallField pgNamespaceName namespaceNameField -{- | - The @nspname@ column of the @pg_catalog.pg_namespace@ table. +{- | The @nspname@ column of the @pg_catalog.pg_namespace@ table. @since 1.0.0.0 -} diff --git a/src/Orville/PostgreSQL/PgCatalog/PgProc.hs b/src/Orville/PostgreSQL/PgCatalog/PgProc.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/PgCatalog/PgProc.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{- | +Copyright : Flipstone Technology Partners 2024 +License : MIT +Stability : Stable + +@since 1.1.0.0 +-} +module Orville.PostgreSQL.PgCatalog.PgProc + ( PgProc (..) + , ProcName + , pgProcTable + , procNameField + , procNamespaceOidField + ) where + +import qualified Data.String as String +import qualified Data.Text as T + +import qualified Database.PostgreSQL.LibPQ as LibPQ +import qualified Orville.PostgreSQL as Orville +import Orville.PostgreSQL.PgCatalog.OidField (oidField, oidTypeField) + +{- | The Haskell representation of data read from the @pg_catalog.pg_proc@ table. + Rows in this table reperesent functions, procedures, aggregate functions, and + window functions (collectively also known as routines), such as those created + via @CREATE FUNCTION@ or @CREATE PROCEDUCE. + +@since 1.1.0.0 +-} +data PgProc = PgProc + { pgProcOid :: LibPQ.Oid + -- ^ The PostgreSQL @oid@ for the relation. + , pgProcNamespaceOid :: LibPQ.Oid + -- ^ The PostgreSQL @oid@ of the namespace that the relation belongs to. + -- References @pg_namespace.oid@. + , pgProcName :: ProcName + -- ^ The name of the proceduce or function. + , pgProcSource :: T.Text + -- ^ How the function is executed by the PostgreSQL function handler. This + -- made the actual source code for interpreted languages, but could be almost + -- anything depending on the language. + } + +{- | A Haskell type for the name of the trigger represented by a 'PgProc'. + +@since 1.1.0.0 +-} +newtype ProcName + = ProcName T.Text + deriving + ( -- | @since 1.1.0.0 + Show + , -- | @since 1.1.0.0 + Eq + , -- | @since 1.1.0.0 + Ord + , -- | @since 1.1.0.0 + String.IsString + ) + +{- | An Orville 'Orville.TableDefinition' for querying the + @pg_catalog.pg_proc@ table. + +@since 1.1.0.0 +-} +pgProcTable :: Orville.TableDefinition Orville.NoKey PgProc PgProc +pgProcTable = + Orville.setTableSchema "pg_catalog" $ + Orville.mkTableDefinitionWithoutKey + "pg_proc" + pgProcMarshaller + +pgProcMarshaller :: Orville.SqlMarshaller PgProc PgProc +pgProcMarshaller = + PgProc + <$> Orville.marshallField pgProcOid oidField + <*> Orville.marshallField pgProcNamespaceOid procNamespaceOidField + <*> Orville.marshallField pgProcName procNameField + <*> Orville.marshallField pgProcSource procSourceField + +{- | The @pronamespace@ column of the @pg_catalog.pg_proc@ table. + +@since 1.0.0.0 +-} +procNamespaceOidField :: Orville.FieldDefinition Orville.NotNull LibPQ.Oid +procNamespaceOidField = + oidTypeField "pronamespace" + +{- | The @proname@ column of the @pg_catalog.pg_proc@ table. + +@since 1.1.0.0 +-} +procNameField :: Orville.FieldDefinition Orville.NotNull ProcName +procNameField = + Orville.coerceField $ + Orville.unboundedTextField "proname" + +{- | The @prosrc@ column of the @pg_catalog.pg_proc@ table. + +@since 1.1.0.0 +-} +procSourceField :: Orville.FieldDefinition Orville.NotNull T.Text +procSourceField = + Orville.unboundedTextField "prosrc" diff --git a/src/Orville/PostgreSQL/PgCatalog/PgSequence.hs b/src/Orville/PostgreSQL/PgCatalog/PgSequence.hs --- a/src/Orville/PostgreSQL/PgCatalog/PgSequence.hs +++ b/src/Orville/PostgreSQL/PgCatalog/PgSequence.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - {- | Copyright : Flipstone Technology Partners 2023 License : MIT @@ -20,8 +18,7 @@ import qualified Orville.PostgreSQL as Orville import Orville.PostgreSQL.PgCatalog.OidField (oidField, oidTypeField) -{- | - The Haskell representation of data read from the @pg_catalog.pg_sequence@ +{- | The Haskell representation of data read from the @pg_catalog.pg_sequence@ table. Rows in this table are sequences in PostgreSQL. @since 1.0.0.0 @@ -46,8 +43,7 @@ -- ^ Whether the sequence cycles. } -{- | - An Orville 'Orville.TableDefinition' for querying the +{- | An Orville 'Orville.TableDefinition' for querying the @pg_catalog.pg_sequence@ table. @since 1.0.0.0 @@ -72,8 +68,7 @@ <*> Orville.marshallField pgSequenceCache sequenceCacheField <*> Orville.marshallField pgSequenceCycle sequenceCycleField -{- | - The @seqrelid@ column of the @pg_cataglog.pg_sequence@ table. +{- | The @seqrelid@ column of the @pg_cataglog.pg_sequence@ table. @since 1.0.0.0 -} @@ -81,8 +76,7 @@ sequencePgClassOidField = oidTypeField "seqrelid" -{- | - The @seqtypid@ column of the @pg_catalog.pg_sequence@ table. +{- | The @seqtypid@ column of the @pg_catalog.pg_sequence@ table. @since 1.0.0.0 -} @@ -90,8 +84,7 @@ sequenceTypeOidField = oidTypeField "seqtypid" -{- | - The @seqstart@ column of the @pg_catalog.pg_sequence@ table. +{- | The @seqstart@ column of the @pg_catalog.pg_sequence@ table. @since 1.0.0.0 -} @@ -99,8 +92,7 @@ sequenceStartField = Orville.bigIntegerField "seqstart" -{- | - The @seqincrement@ column of the @pg_catalog.pg_sequence@ table. +{- | The @seqincrement@ column of the @pg_catalog.pg_sequence@ table. @since 1.0.0.0 -} @@ -108,8 +100,7 @@ sequenceIncrementField = Orville.bigIntegerField "seqincrement" -{- | - The @seqmax@ column of the @pg_catalog.pg_sequence@ table. +{- | The @seqmax@ column of the @pg_catalog.pg_sequence@ table. @since 1.0.0.0 -} @@ -117,8 +108,7 @@ sequenceMaxField = Orville.bigIntegerField "seqmax" -{- | - The @seqmin@ column of the @pg_catalog.pg_sequence@ table. +{- | The @seqmin@ column of the @pg_catalog.pg_sequence@ table. @since 1.0.0.0 -} @@ -126,8 +116,7 @@ sequenceMinField = Orville.bigIntegerField "seqmin" -{- | - The @seqcache@ column of the @pg_catalog.pg_sequence@ table. +{- | The @seqcache@ column of the @pg_catalog.pg_sequence@ table. @since 1.0.0.0 -} @@ -135,8 +124,7 @@ sequenceCacheField = Orville.bigIntegerField "seqcache" -{- | - The @seqcycle@ column of the @pg_catalog.pg_sequence@ table. +{- | The @seqcycle@ column of the @pg_catalog.pg_sequence@ table. @since 1.0.0.0 -} diff --git a/src/Orville/PostgreSQL/PgCatalog/PgTrigger.hs b/src/Orville/PostgreSQL/PgCatalog/PgTrigger.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/PgCatalog/PgTrigger.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{- | +Copyright : Flipstone Technology Partners 2024 +License : MIT +Stability : Stable + +@since 1.1.0.0 +-} +module Orville.PostgreSQL.PgCatalog.PgTrigger + ( PgTrigger (..) + , TriggerName + , triggerNameToString + , pgTriggerTable + , triggerRelationOidField + ) where + +import qualified Data.String as String +import qualified Data.Text as T + +import qualified Database.PostgreSQL.LibPQ as LibPQ +import qualified Orville.PostgreSQL as Orville +import Orville.PostgreSQL.PgCatalog.OidField (oidField, oidTypeField) + +{- | The Haskell representation of data read from the @pg_catalog.pg_trigger@ + table. Rows in this table correspond to triggers created on tables and views. +@since 1.1.0.0 +-} +data PgTrigger = PgTrigger + { pgTriggerOid :: LibPQ.Oid + -- ^ The PostgreSQL @oid@ for the relation. + , pgTriggerRelationOid :: LibPQ.Oid + -- ^ The PostgreSQL @oid@ of the relation that the trigger is onto. + -- References @pg_class.oid@. + , pgTriggerName :: TriggerName + -- ^ The name of the trigger. + , pgTriggerIsInternal :: Bool + -- ^ The whether the trigger is internal accounting to PostgreSQL. + } + +{- | A Haskell type for the name of the trigger represented by a 'PgTrigger'. + +@since 1.1.0.0 +-} +newtype TriggerName + = TriggerName T.Text + deriving + ( -- | @since 1.1.0.0 + Show + , -- | @since 1.1.0.0 + Eq + , -- | @since 1.1.0.0 + Ord + , -- | @since 1.1.0.0 + String.IsString + ) + +{- | Convert a 'TriggerName' to a plain 'String'. + +@since 1.1.0.0 +-} +triggerNameToString :: TriggerName -> String +triggerNameToString (TriggerName name) = + T.unpack name + +{- | An Orville 'Orville.TableDefinition' for querying the + @pg_catalog.pg_trigger@ table. + +@since 1.1.0.0 +-} +pgTriggerTable :: Orville.TableDefinition Orville.NoKey PgTrigger PgTrigger +pgTriggerTable = + Orville.setTableSchema "pg_catalog" $ + Orville.mkTableDefinitionWithoutKey + "pg_trigger" + pgTriggerMarshaller + +pgTriggerMarshaller :: Orville.SqlMarshaller PgTrigger PgTrigger +pgTriggerMarshaller = + PgTrigger + <$> Orville.marshallField pgTriggerOid oidField + <*> Orville.marshallField pgTriggerRelationOid triggerRelationOidField + <*> Orville.marshallField pgTriggerName triggerNameField + <*> Orville.marshallField pgTriggerIsInternal triggerIsInternalField + +{- | The @tgrelid@ column of the @pg_trigger@ table. + +@since 1.1.0.0 +-} +triggerRelationOidField :: Orville.FieldDefinition Orville.NotNull LibPQ.Oid +triggerRelationOidField = + oidTypeField "tgrelid" + +{- | The @tgname@ column of the @pg_catalog.pg_trigger@ table. + +@since 1.1.0.0 +-} +triggerNameField :: Orville.FieldDefinition Orville.NotNull TriggerName +triggerNameField = + Orville.coerceField $ + Orville.unboundedTextField "tgname" + +{- | The @tgisinternal@ column of the @pg_catalog.pg_trigger@ table. + +@since 1.1.0.0 +-} +triggerIsInternalField :: Orville.FieldDefinition Orville.NotNull Bool +triggerIsInternalField = + Orville.booleanField "tgisinternal" diff --git a/src/Orville/PostgreSQL/Plan.hs b/src/Orville/PostgreSQL/Plan.hs --- a/src/Orville/PostgreSQL/Plan.hs +++ b/src/Orville/PostgreSQL/Plan.hs @@ -1,5 +1,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {- | Copyright : Flipstone Technology Partners 2023 @@ -21,13 +22,21 @@ -- * Making a Plan to find rows in the database , findMaybeOne + , findMaybeOneByMarshaller , findMaybeOneWhere + , findMaybeOneWhereByMarshaller , findOne + , findOneByMarshaller , findOneShowVia + , findOneShowViaByMarshaller , findOneWhere + , findOneWhereByMarshaller , findOneWhereShowVia + , findOneWhereShowViaByMarshaller , findAll + , findAllByMarshaller , findAllWhere + , findAllWhereByMarshaller -- * Creating a multi-step Plan from other Plan values , bind @@ -38,6 +47,7 @@ , apply , planMany , planList + , planTraversable , focusParam , planEither , planMaybe @@ -53,7 +63,9 @@ import Control.Exception (throwIO) import Control.Monad (join) import qualified Control.Monad.IO.Class as MIO +import qualified Data.Bifunctor as Bifunctor import Data.Either (partitionEithers) +import qualified Data.Foldable as Foldable import qualified Data.List.NonEmpty as NEL import Orville.PostgreSQL.Execution (Select) @@ -66,34 +78,28 @@ import qualified Orville.PostgreSQL.Plan.Operation as Op import qualified Orville.PostgreSQL.Schema as Schema -{- | - A 'Plan' is an executable set of queries that can be executed to load data - from the database, using the results of prior queries as input parameters to - following queries in controlled ways. In particular, the "controlled" aspect - of this allows plans that take a single input to be adapted to take multiple - input parameters in a list without the resulting plan executing N+1 queries. - This restriction means that while query results can be used as input - parameters to later queries, they cannot be used to decide to run completely - different queries based on other query results. Allowing this would prevent - the 'Plan' structure from eliminating N+1 query loops. +{- | A 'Plan' is an executable set of queries that can be executed to load data from the database, + using the results of prior queries as input parameters to following queries in controlled ways. In + particular, the "controlled" aspect of this allows plans that take a single input to be adapted to + take multiple input parameters in a list without the resulting plan executing N+1 queries. This + restriction means that while query results can be used as input parameters to later queries, they + cannot be used to decide to run completely different queries based on other query + results. Allowing this would prevent the 'Plan' structure from eliminating N+1 query loops. - Note that during execution, queries are never combined across tables to form - joins or subqueries. Queries are still executed in the same sequence as - specified in the plan, just on all the inputs at once rather than in a loop. - If you need to do a join with a plan, you can always construct your own - custom 'Op.Operation' and use 'planOperation' to incorporate it into a plan. + Note that during execution, queries are never combined across tables to form joins or + subqueries. Queries are still executed in the same sequence as specified in the plan, just on all + the inputs at once rather than in a loop. If you need to do a join with a plan, you can always + construct your own custom 'Op.Operation' and use 'planOperation' to incorporate it into a plan. - The @param@ type variable indicates what type of value is expected as input - when the plan is executed. + The @param@ type variable indicates what type of value is expected as input when the plan is + executed. - The @result@ type for a plan indicates what Haskell type is produced - when the plan is executed. + The @result@ type for a plan indicates what Haskell type is produced when the plan is executed. - The @scope@ type is used internally by Orville to track how the plan is - currently executed against a single input or multiple inputs. This type - parameter should never be specified as a concrete type in user code, but must - be exposed as a variable to ensure that execute scope is tracked correctly - through usages of 'bind'. + The @scope@ type is used internally by Orville to track how the plan is currently executed against + a single input or multiple inputs. This type parameter should never be specified as a concrete + type in user code, but must be exposed as a variable to ensure that execute scope is tracked + correctly through usages of 'bind'. @since 1.0.0.0 -} @@ -121,45 +127,40 @@ Plan scope b c -> Plan scope a c +-- | @since 1.0.0.0 instance Functor (Plan scope param) where fmap f = Apply (Pure f) +-- | @since 1.0.0.0 instance Applicative (Plan scope param) where pure = Pure (<*>) = Apply -{- | - 'Execute' is a tag type used as the @scope@ variable for 'Plan' values when - executing them via the 'execute' function. +{- | 'Execute' is a tag type used as the @scope@ variable for 'Plan' values when executing them via + the 'execute' function. @since 1.0.0.0 -} data Execute -{- | - 'ExecuteMany' is an internal tag type used by as the @scope@ variable for - 'Plan' values when executing them against multiple inputs via the - 'executeMany' internal function. +{- | 'ExecuteMany' is an internal tag type used by as the @scope@ variable for 'Plan' values when + executing them against multiple inputs via the 'executeMany' internal function. @since 1.0.0.0 -} data ExecuteMany -{- | - A 'Planned' value is a wrapper around the results of previously-run queries - when using the 'bind' function. At the time that you are writing a plan, you - do not know whether the 'Plan' will be run with a single input or multiple - inputs. A 'Planned' value may end up being either an individual item or a - list of items. Due to this, your ability to interact with the value is - limited to the use of 'fmap' to extract (or build) other values from the - results. 'Planned' values can be used together with the 'use' function to - make a 'Plan' that produces the extracted value. +{- | A 'Planned' value is a wrapper around the results of previously-run queries when using the 'bind' + function. At the time that you are writing a plan, you do not know whether the 'Plan' will be run + with a single input or multiple inputs. A 'Planned' value may end up being either an individual + item or a list of items. Due to this, your ability to interact with the value is limited to the + use of 'fmap' to extract (or build) other values from the results. 'Planned' values can be used + together with the 'use' function to make a 'Plan' that produces the extracted value. - Note that while 'Planned' could provide an 'Applicative' instance as well, it - does not to avoid confusion with the 'Applicative' instance for 'Plan' - itself. If you need to build a value from several 'Planned' values using - 'Applicative', you should call 'use' on each of the values and use the - 'Applicative' instance for 'Plan'. + Note that while 'Planned' could provide an 'Applicative' instance as well, it does not to avoid + confusion with the 'Applicative' instance for 'Plan' itself. If you need to build a value from + several 'Planned' values using 'Applicative', you should call 'use' on each of the values and use + the 'Applicative' instance for 'Plan'. @since 1.0.0.0 -} @@ -171,10 +172,8 @@ instance Functor (Planned scope param) where fmap = mapPlanned -{- | - 'mapPlanned' applies a function to what value or values have been produced by - the plan. This function can also be called as 'fmap' or '<$>' thorugh the - 'Functor' instance for 'Planned'. +{- | 'mapPlanned' applies a function to what value or values have been produced by the plan. This + function can also be called as 'fmap' or '<$>' thorugh the 'Functor' instance for 'Planned'. @since 1.0.0.0 -} @@ -188,28 +187,25 @@ PlannedExplain -> PlannedExplain -{- | - 'resolveOne' resolves a 'Planned' value that is known to be in the 'Execute' - scope to its single wrapped value. +{- | 'resolveOne' resolves a 'Planned' value that is known to be in the 'Execute' scope to its single + wrapped value. @since 1.0.0.0 -} resolveOne :: Planned Execute param a -> a resolveOne (PlannedOne a) = a -{- | - 'resolveMany resolves a 'Planned' value that is known to be in the - 'ExecuteMany' scope to the 'Many' value wrapped inside it. +{- | 'resolveMany resolves a 'Planned' value that is known to be in the 'ExecuteMany' scope to the + 'Many' value wrapped inside it. @since 1.0.0.0 -} resolveMany :: Planned ExecuteMany k a -> Many k a resolveMany (PlannedMany as) = as -{- | - 'planOperation' allows any primitive 'Op.Operation' to be used as an atomic step - in a plan. When the plan is executed, the appropriate 'Op.Operation' functions - will be used depending on the execution context. +{- | 'planOperation' allows any primitive 'Op.Operation' to be used as an atomic step in a plan. When + the plan is executed, the appropriate 'Op.Operation' functions will be used depending on the + execution context. @since 1.0.0.0 -} @@ -219,11 +215,10 @@ planOperation = PlanOp -{- | - 'planSelect' allows any Orville 'Select' query to be incorporated into a - plan. Note that the 'Select' cannot depend on the plan's input parameters in - this case. If the plan is executed with multiple inputs, the same set of all - the results will be used as the results for each of the input parameters. +{- | 'planSelect' allows any Orville 'Select' query to be incorporated into a plan. Note that the + 'Select' cannot depend on the plan's input parameters in this case. If the plan is executed with + multiple inputs, the same set of all the results will be used as the results for each of the input + parameters. @since 1.0.0.0 -} @@ -231,10 +226,9 @@ planSelect select = planOperation (Op.findSelect select) -{- | - 'askParam' allows the input parameter for the plan to be retrieved as the - result of the plan. Together with 'bind' you can use this to get access to - the input parameter as a 'Planned' value. +{- | 'askParam' allows the input parameter for the plan to be retrieved as the result of the + plan. Together with 'bind' you can use this to get access to the input parameter as a 'Planned' + value. @since 1.0.0.0 -} @@ -242,10 +236,8 @@ askParam = planOperation Op.askParam -{- | - 'findMaybeOne' constructs a 'Plan' that will find at most one row from - the given table where the plan's input value matches the given database - field. +{- | 'findMaybeOne' constructs a 'Plan' that will find at most one row from the given table where the + plan's input value matches the given database field. @since 1.0.0.0 -} @@ -257,11 +249,22 @@ findMaybeOne tableDef fieldDef = planOperation (Op.findOne tableDef (Op.byField fieldDef)) -{- | - 'findMaybeOneWhere' is similar to 'findMaybeOne', but allows a - 'Expr.BooleanExpr' to be specified to restrict which rows are matched by the - database query. +{- | Construct a plan that will find at most one row from the given table where the plan's input value + matches the fields in the provided 'Marshall.SqlMarshaller'. +@since 1.1.0.0 +-} +findMaybeOneByMarshaller :: + Ord param => + Schema.TableDefinition key writeEntity readEntity -> + Marshall.SqlMarshaller param param -> + Plan scope param (Maybe readEntity) +findMaybeOneByMarshaller tableDef paramMarshaller = + planOperation (Op.findOne tableDef (Op.byMarshaller paramMarshaller)) + +{- | 'findMaybeOneWhere' is similar to 'findMaybeOne', but allows a 'Expr.BooleanExpr' to be specified + to restrict which rows are matched by the database query. + @since 1.0.0.0 -} findMaybeOneWhere :: @@ -273,13 +276,25 @@ findMaybeOneWhere tableDef fieldDef cond = planOperation (Op.findOneWhere tableDef (Op.byField fieldDef) cond) -{- | - 'findOneShowVia' is similar to 'findMaybeOne', but it expects that there will - always be a row found matching the plan's input value. If no row is found, an - 'Op.AssertionFailed' exception will be thrown. This is a useful convenience - when looking up foreign-key associations that are expected to be enforced by - the database itself. +{- | Similar to 'findMaybeOneByMarshaller', but allows a 'Expr.BooleanExpr' to be specified to + restrict which rows are matched by the database query. +@since 1.1.0.0 +-} +findMaybeOneWhereByMarshaller :: + Ord param => + Schema.TableDefinition key writeEntity readEntity -> + Marshall.SqlMarshaller param param -> + Expr.BooleanExpr -> + Plan scope param (Maybe readEntity) +findMaybeOneWhereByMarshaller tableDef paramMarshaller cond = + planOperation (Op.findOneWhere tableDef (Op.byMarshaller paramMarshaller) cond) + +{- | 'findOneShowVia' is similar to 'findMaybeOne', but it expects that there will always be a row + found matching the plan's input value. If no row is found, an 'Op.AssertionFailed' exception will + be thrown. This is a useful convenience when looking up foreign-key associations that are expected + to be enforced by the database itself. + @since 1.0.0.0 -} findOneShowVia :: @@ -293,11 +308,27 @@ (assertFound showParam tableDef fieldDef) (findMaybeOne tableDef fieldDef) -{- | - 'findOne' is an alias to 'findOneShowVia' that uses the 'Show' instance of - @fieldValue@ when producing a failure message in the event that the entity - cannot be found. +{- | Similar to 'findMaybeOneByMarshaller', but expects that there will always be a row found matching + the plan's input value. If no row is found, an 'Op.AssertionFailed' exception will be thrown. This + is a useful convenience when looking up foreign-key associations that are expected to be enforced + by the database itself. +@since 1.1.0.0 +-} +findOneShowViaByMarshaller :: + Ord param => + (param -> String) -> + Schema.TableDefinition key writeEntity readEntity -> + Marshall.SqlMarshaller param param -> + Plan scope param readEntity +findOneShowViaByMarshaller showParam tableDef paramMarshaller = + assert + (assertFoundByMarshaller showParam tableDef) + (findMaybeOneByMarshaller tableDef paramMarshaller) + +{- | 'findOne' is an alias to 'findOneShowVia' that uses the 'Show' instance of @fieldValue@ when + producing a failure message in the event that the entity cannot be found. + @since 1.0.0.0 -} findOne :: @@ -307,11 +338,21 @@ Plan scope fieldValue readEntity findOne = findOneShowVia show -{- | - 'findOneWhereShowVia' is similar to 'findOneShowVia', but allows a - 'Expr.BooleanExpr' to be specified to restrict which rows are matched by the - database query. +{- | An alias for 'findOneShowViaByMarshaller' that uses the 'Show' instance of @param@ when producing + a failure message in the event that the entity cannot be found. +@since 1.1.0.0 +-} +findOneByMarshaller :: + (Show param, Ord param) => + Schema.TableDefinition key writeEntity readEntity -> + Marshall.SqlMarshaller param param -> + Plan scope param readEntity +findOneByMarshaller = findOneShowViaByMarshaller show + +{- | 'findOneWhereShowVia' is similar to 'findOneShowVia', but allows a 'Expr.BooleanExpr' to be + specified to restrict which rows are matched by the database query. + @since 1.0.0.0 -} findOneWhereShowVia :: @@ -326,11 +367,26 @@ (assertFound showParam tableDef fieldDef) (findMaybeOneWhere tableDef fieldDef cond) -{- | - 'findOneWhere' is an alias to 'findOneWhereShowVia' that uses the 'Show' - instance of @fieldValue@ when producing a failure message in the event that - the entity cannot be found. +{- | Similar to 'findOneShowViaByMarshaller', but allows a 'Expr.BooleanExpr' to be specified to + restrict which rows are matched by the database query. +@since 1.1.0.0 +-} +findOneWhereShowViaByMarshaller :: + Ord param => + (param -> String) -> + Schema.TableDefinition key writeEntity readEntity -> + Marshall.SqlMarshaller param param -> + Expr.BooleanExpr -> + Plan scope param readEntity +findOneWhereShowViaByMarshaller showParam tableDef paramMarshaller cond = + assert + (assertFoundByMarshaller showParam tableDef) + (findMaybeOneWhereByMarshaller tableDef paramMarshaller cond) + +{- | 'findOneWhere' is an alias to 'findOneWhereShowVia' that uses the 'Show' instance of @fieldValue@ + when producing a failure message in the event that the entity cannot be found. + @since 1.0.0.0 -} findOneWhere :: @@ -341,10 +397,21 @@ Plan scope fieldValue readEntity findOneWhere = findOneWhereShowVia show -{- | - 'assertFound' is an internal helper that checks that row was found where - one was expected. +{- | An alias for 'findOneWhereShowViaByMarshaller' that uses the 'Show' instance of @param@ when + producing a failure message in the event that the entity cannot be found. +@since 1.1.0.0 +-} +findOneWhereByMarshaller :: + (Show param, Ord param) => + Schema.TableDefinition key writeEntity readEntity -> + Marshall.SqlMarshaller param param -> + Expr.BooleanExpr -> + Plan scope param readEntity +findOneWhereByMarshaller = findOneWhereShowViaByMarshaller show + +{- | 'assertFound' is an internal helper that checks that row was found where one was expected. + @since 1.0.0.0 -} assertFound :: @@ -369,10 +436,32 @@ , showParam param ] -{- | - 'findAll' constructs a 'Plan' that will find all the rows from the given - table where the plan's input value matches the given database field. +{- | An internal helper that checks that a row was found and produces an error message otherwise. +@since 1.1.0.0 +-} +assertFoundByMarshaller :: + (param -> String) -> + Schema.TableDefinition key writeEntity readEntity -> + param -> + Maybe result -> + Either String result +assertFoundByMarshaller showParam tableDef param maybeRecord = + case maybeRecord of + Just a -> + Right a + Nothing -> + Left $ + unwords + [ "Failed to find record in table " + , Schema.tableIdToString $ Schema.tableIdentifier tableDef + , " where param marshaller fields = " + , showParam param + ] + +{- | 'findAll' constructs a 'Plan' that will find all the rows from the given table where the plan's + input value matches the given database field. + @since 1.0.0.0 -} findAll :: @@ -383,10 +472,22 @@ findAll tableDef fieldDef = planOperation (Op.findAll tableDef (Op.byField fieldDef)) -{- | - 'findAllWhere' is similar to 'findAll', but allows a 'Expr.BooleanExpr' to be - specified to restrict which rows are matched by the database query. +{- | Construct a 'Plan' that will find all the rows from the given table where the plan's input value + matches the fields in the provided 'Marshall.SqlMarshaller'. +@since 1.1.0.0 +-} +findAllByMarshaller :: + Ord param => + Schema.TableDefinition key writeEntity readEntity -> + Marshall.SqlMarshaller param param -> + Plan scope param [readEntity] +findAllByMarshaller tableDef paramMarshaller = + planOperation (Op.findAll tableDef (Op.byMarshaller paramMarshaller)) + +{- | 'findAllWhere' is similar to 'findAll', but allows a 'Expr.BooleanExpr' to be specified to + restrict which rows are matched by the database query. + @since 1.0.0.0 -} findAllWhere :: @@ -398,13 +499,25 @@ findAllWhere tableDef fieldDef cond = planOperation (Op.findAllWhere tableDef (Op.byField fieldDef) cond) -{- | - 'planMany' adapts a plan that takes a single input parameter to work on - multiple input parameters. When the new plan is executed, each query will - execute in the same basic order, but with adjusted conditions to find all the - rows for all inputs at once rather than running the planned queries once for - each input. +{- | Similar to 'findAllByMarshaller', but allows a 'Expr.BooleanExpr' to be specified to restrict + which rows are matched by the database query. +@since 1.1.0.0 +-} +findAllWhereByMarshaller :: + Ord param => + Schema.TableDefinition key writeEntity readEntity -> + Marshall.SqlMarshaller param param -> + Expr.BooleanExpr -> + Plan scope param [readEntity] +findAllWhereByMarshaller tableDef paramMarshaller cond = + planOperation (Op.findAllWhere tableDef (Op.byMarshaller paramMarshaller) cond) + +{- | 'planMany' adapts a plan that takes a single input parameter to work on multiple input + parameters. When the new plan is executed, each query will execute in the same basic order, but + with adjusted conditions to find all the rows for all inputs at once rather than running the + planned queries once for each input. + @since 1.0.0.0 -} planMany :: @@ -413,19 +526,15 @@ planMany = PlanMany -{- | - 'planList' lifts a plan so both its param and result become lists. This saves - you from having to fmap in 'Many.elems' when all you want back from a 'Many' - is the list of results inside it. +{- | 'planList' lifts a plan so both its param and result become lists. This saves you from having to + fmap in 'Many.elems' when all you want back from a 'Many' is the list of results inside it. - There will always be the same number of elements in the @[result]@ list as - there are in the @[param]@ list, even if there are duplicate values in the - input parameters. This may be counter-intuitive in the trivial case where a - plan that queries a single table is passed to 'planList' but cannot be - avoided due to more complicated situations where the original plan executes - queries against multiple tables. When a plan that queries multiple tables is - passed, the query results must be correlated based on the input parameters to - build each @result@ value. + There will always be the same number of elements in the @[result]@ list as there are in the + @[param]@ list, even if there are duplicate values in the input parameters. This may be + counter-intuitive in the trivial case where a plan that queries a single table is passed to + 'planList' but cannot be avoided due to more complicated situations where the original plan + executes queries against multiple tables. When a plan that queries multiple tables is passed, the + query results must be correlated based on the input parameters to build each @result@ value. @since 1.0.0.0 -} @@ -435,29 +544,42 @@ planList plan = Many.elems <$> planMany plan -{- | - 'focusParam' builds a plan from a function and an existing plan, taking the - result of that function as input. This is especially useful when there is - some structure, and a plan that only needs a part of that structure as input. - The function argument can access part of the structure for the plan argument - to use, so the final returned plan can take the entire structure as input. +{- | Similar to 'planList', but generalized to work with any 'Traversable'. +@since 1.1.0.0 +-} +planTraversable :: + forall t tScope param result. + Traversable t => + (forall scope. Plan scope param result) -> + Plan tScope (t param) (t result) +planTraversable plan = + let + lookupAll :: t param -> Many param result -> Either String (t result) + lookupAll t m = + traverse (Bifunctor.first (const "planTraversable invariant violated: Missing Key") . flip Many.lookup m) t + in + assert lookupAll $ chain (fmap Foldable.toList askParam) (planMany plan) + +{- | 'focusParam' builds a plan from a function and an existing plan, taking the result of that + function as input. This is especially useful when there is some structure, and a plan that only + needs a part of that structure as input. The function argument can access part of the structure + for the plan argument to use, so the final returned plan can take the entire structure as input. + @since 1.0.0.0 -} focusParam :: (a -> b) -> Plan scope b result -> Plan scope a result -focusParam focuser plan = - chain (focuser <$> askParam) plan +focusParam focuser = + chain (fmap focuser askParam) -{- | - 'planEither' lets you construct a plan that branches by executing a different - plan for the 'Left' and 'Right' sides of an 'Either' value. When used with a - single input parameter, only one of the two plans will be used, based on the - input parameter. When used on multiple input parameters, each of the two - plans will be executed only once with all the 'Left' and 'Right' values - provided as input parameters respectively. +{- | 'planEither' lets you construct a plan that branches by executing a different plan for the 'Left' + and 'Right' sides of an 'Either' value. When used with a single input parameter, only one of the + two plans will be used, based on the input parameter. When used on multiple input parameters, each + of the two plans will be executed only once with all the 'Left' and 'Right' values provided as + input parameters respectively. @since 1.0.0.0 -} @@ -468,10 +590,9 @@ planEither = PlanEither -{- | - 'planMaybe' lifts a plan so both its param and result become 'Maybe's. This is - useful when modifying an existing plan to deal with optionality. Writing just - one plan can then easily produce both the required and optional versions. +{- | 'planMaybe' lifts a plan so both its param and result become 'Maybe's. This is useful when + modifying an existing plan to deal with optionality. Writing just one plan can then easily produce + both the required and optional versions. @since 1.0.0.0 -} @@ -480,21 +601,17 @@ focusParam (maybe (Left ()) Right) $ either id id <$> planEither (pure Nothing) (Just <$> plan) -{- | - 'bind' gives access to the results of a plan to use as input values to future - plans. The plan result is given the input parameter to the provided function, - which must produce the remaining 'Plan' to be executed. The value will be - wrapped in the 'Planned' type, which may represent either a result or - multiple results, depending on whether one plan is currently being executed - with one and multiple input parameters. This ensures that the caller produces - only a single remaining 'Plan' to be used for all inputs when there are - multiple to eliminate the need to possibly run different queries for - different inputs (which would an introduce N+1 query execution). +{- | 'bind' gives access to the results of a plan to use as input values to future plans. The plan + result is given the input parameter to the provided function, which must produce the remaining + 'Plan' to be executed. The value will be wrapped in the 'Planned' type, which may represent either + a result or multiple results, depending on whether one plan is currently being executed with one + and multiple input parameters. This ensures that the caller produces only a single remaining + 'Plan' to be used for all inputs when there are multiple to eliminate the need to possibly run + different queries for different inputs (which would an introduce N+1 query execution). - The 'Planned' value (or values) provided by 'bind' have actually been - retrieved from the database, so the value can be used multiple times when - constructing the remaining 'Plan' without fear of causing the query to run - multiple times. + The 'Planned' value (or values) provided by 'bind' have actually been retrieved from the database, + so the value can be used multiple times when constructing the remaining 'Plan' without fear of + causing the query to run multiple times. Also see 'use' for how to lift a 'Planned' value back into a 'Plan'. @@ -507,9 +624,8 @@ bind = Bind -{- | - 'use' constructs a 'Plan' that always produces the 'Planned' value - as its result, regardless of the parameter given as input to the plan. +{- | 'use' constructs a 'Plan' that always produces the 'Planned' value as its result, regardless of + the parameter given as input to the plan. @since 1.0.0.0 -} @@ -517,10 +633,8 @@ use = Use -{- | - 'using' uses a 'Planned' value in the input to another 'Plan'. The - resulting plan will ignore its input and use the 'Planned' value as - the input to produce its result instead. +{- | 'using' uses a 'Planned' value in the input to another 'Plan'. The resulting plan will ignore its + input and use the 'Planned' value as the input to produce its result instead. @since 1.0.0.0 -} @@ -528,13 +642,11 @@ Planned scope param a -> Plan scope a b -> Plan scope param b -using planned plan = - chain (use planned) plan +using planned = + chain (use planned) -{- | - 'apply' applies a function produced by a plan to the value produced - by another plan. This is usually used via the '<*>' operator through - the 'Applicative' instance for 'Plan'. +{- | 'apply' applies a function produced by a plan to the value produced by another plan. This is + usually used via the '<*>' operator through the 'Applicative' instance for 'Plan'. @since 1.0.0.0 -} @@ -545,9 +657,8 @@ apply = Apply -{- | - 'chain' connects the output of one plan to the input of another to form a - larger plan that will execute the first followed by the second. +{- | 'chain' connects the output of one plan to the input of another to form a larger plan that will + execute the first followed by the second. @since 1.0.0.0 -} @@ -558,10 +669,8 @@ chain = Chain -{- | - 'chainMaybe' connects two plans that both yield Maybes. - If the first plan yields no result, the second is skipped. - See also 'chain'. +{- | 'chainMaybe' connects two plans that both yield Maybes. If the first plan yields no result, the + second is skipped. See also 'chain'. @since 1.0.0.0 -} @@ -569,7 +678,7 @@ Plan scope a (Maybe b) -> Plan scope b (Maybe c) -> Plan scope a (Maybe c) -chainMaybe a b = +chainMaybe aPlan bPlan = let optionalInput :: Plan scope a (Maybe b) -> @@ -577,14 +686,12 @@ optionalInput = fmap join . planMaybe in - Chain a (optionalInput b) + Chain aPlan (optionalInput bPlan) -{- | - 'assert' allows you to make an assertion about a plan's result that will - throw an 'Op.AssertionFailed' exception during execution if it proves to be - false. The first parameter is the assertion function, which should return - either an error message to be given in the exception or the value to be used - as the plan's result. +{- | 'assert' allows you to make an assertion about a plan's result that will throw an + 'Op.AssertionFailed' exception during execution if it proves to be false. The first parameter is + the assertion function, which should return either an error message to be given in the exception + or the value to be used as the plan's result. @since 1.0.0.0 -} @@ -601,14 +708,12 @@ in chain eitherPlan (PlanOp Op.assertRight) -{- | - 'execute' accepts the input parameter (or parameters) expected by a 'Plan' - and runs the plan to completion, either throwing an 'Op.AssertionFailed' - exception in the monad @m@ or producing the expected result. +{- | 'execute' accepts the input parameter (or parameters) expected by a 'Plan' and runs the plan to + completion, either throwing an 'Op.AssertionFailed' exception in the monad @m@ or producing the + expected result. - If you have a plan that takes one input and want to provide a list of - input, use 'planMany' to adapt it to a multple-input plan before calling - 'execute'. + If you have a plan that takes one input and want to provide a list of input, use 'planMany' to + adapt it to a multple-input plan before calling 'execute'. @since 1.0.0.0 -} @@ -617,12 +722,11 @@ Plan Execute param result -> param -> m result -execute plan param = - executeOne plan param +execute = + executeOne -{- | - 'executeOne' is an internal helper that executes a 'Plan' with a concrete - @scope@ type to ensure all 'Planned' values are built with 'PlannedOne'. +{- | 'executeOne' is an internal helper that executes a 'Plan' with a concrete @scope@ type to ensure + all 'Planned' values are built with 'PlannedOne'. @since 1.0.0.0 -} @@ -664,9 +768,8 @@ b <- executeOne planAB param executeOne planBC b -{- | - 'executeMany' is an internal helper that executes a 'Plan' with a concrete - @scope@ type to ensure all 'Planned' values are built with 'PlannedMany'. +{- | 'executeMany' is an internal helper that executes a 'Plan' with a concrete @scope@ type to ensure + all 'Planned' values are built with 'PlannedMany'. @since 1.0.0.0 -} @@ -735,9 +838,8 @@ cs <- executeMany planBC (Many.elems bs) pure $ Many.compose cs bs -{- | - 'Explain' is a tag type used as the @scope@ variable when explaining a 'Plan' - via the 'explain' function. +{- | 'Explain' is a tag type used as the @scope@ variable when explaining a 'Plan' via the 'explain' + function. @since 1.0.0.0 -} @@ -745,11 +847,9 @@ = ExplainOne | ExplainMany -{- | - 'explain' produces a textual description of the steps outlined by - a 'Plan' -- in most cases example SQL queries. If you want to see - the explanation of how the plan will run with multiple input parameters, - you can use 'planMany' to adapt it before calling 'explain'. +{- | 'explain' produces a textual description of the steps outlined by a 'Plan' -- in most cases + example SQL queries. If you want to see the explanation of how the plan will run with multiple + input parameters, you can use 'planMany' to adapt it before calling 'explain'. @since 1.0.0.0 -} @@ -758,10 +858,8 @@ Exp.explanationSteps $ explainPlan ExplainOne plan -{- | - 'explainPlan' is an internal helper to executes a plan with the - @scope@ type fixed to 'Explain' to ensure that all 'Planned' - values are constructed with the 'PlannedExplain' constructor. +{- | 'explainPlan' is an internal helper to executes a plan with the @scope@ type fixed to 'Explain' + to ensure that all 'Planned' values are constructed with the 'PlannedExplain' constructor. @since 1.0.0.0 -} diff --git a/src/Orville/PostgreSQL/Plan/Explanation.hs b/src/Orville/PostgreSQL/Plan/Explanation.hs --- a/src/Orville/PostgreSQL/Plan/Explanation.hs +++ b/src/Orville/PostgreSQL/Plan/Explanation.hs @@ -13,8 +13,7 @@ ) where -{- | - An 'Explanation' represents an example sequence of queries showing the steps +{- | An 'Explanation' represents an example sequence of queries showing the steps would be executed by an Orville 'Orville.PostgreSQL.Plan.Operation.Operation'. @since 1.0.0.0 @@ -22,14 +21,15 @@ newtype Explanation = Explanation ([String] -> [String]) +-- | @since 1.0.0.0 instance Semigroup Explanation where (<>) = appendExplanation +-- | @since 1.0.0.0 instance Monoid Explanation where mempty = noExplanation -{- | -Appends two 'Explanation's with the steps from the first argument being shown +{- | Appends two 'Explanation's with the steps from the first argument being shown first. @since 1.0.0.0 @@ -38,8 +38,7 @@ appendExplanation (Explanation front) (Explanation back) = Explanation (front . back) -{- | -Constructs an empty 'Explanation'. +{- | Constructs an empty 'Explanation'. @since 1.0.0.0 -} @@ -47,8 +46,7 @@ noExplanation = Explanation id -{- | -Constructs an 'Explanation' with a single step. +{- | Constructs an 'Explanation' with a single step. @since 1.0.0.0 -} @@ -56,8 +54,7 @@ explainStep str = Explanation (str :) -{- | -Retrieves the steps contained in the 'Explanation'. +{- | Retrieves the steps contained in the 'Explanation'. @since 1.0.0.0 -} diff --git a/src/Orville/PostgreSQL/Plan/Many.hs b/src/Orville/PostgreSQL/Plan/Many.hs --- a/src/Orville/PostgreSQL/Plan/Many.hs +++ b/src/Orville/PostgreSQL/Plan/Many.hs @@ -1,5 +1,5 @@ {- | -Copyright : Flipstone Technology Partners 2023 +Copyright : Flipstone Technology Partners 2023-2025 License : MIT Stability : Stable @@ -25,8 +25,7 @@ import qualified Data.Map as Map import qualified Data.Maybe as Maybe -{- | - 'NotAKey' is returned from various 'Many' related functions when presented +{- | 'NotAKey' is returned from various 'Many' related functions when presented with an input parameter that was not one of the original inputs that the 'Many' was constructed with. @@ -35,8 +34,7 @@ data NotAKey = NotAKey -{- | - A 'Many k a' represents a group of values keyed by list of parameters and +{- | A 'Many k a' represents a group of values keyed by list of parameters and is used to return the results of executing an Orville Plan with a list of input parameters. If you need to find the result of the query associated with a particular input parameter, you can use 'lookup' to find it. If you @@ -48,11 +46,11 @@ data Many k a = Many [k] (k -> Either NotAKey a) +-- | @since 1.0.0.0 instance Functor (Many k) where fmap = map -{- | - 'fromKeys' constructs a 'Many' value from a list of keys and a function that +{- | 'fromKeys' constructs a 'Many' value from a list of keys and a function that maps them to their values. The order and duplication of keys in the list will be preserved by the 'Many' type in the relevant functions. The mapping function provided should be a total function -- i.e. it should not produce a @@ -67,8 +65,7 @@ fromKeys = Many -{- | - 'map' calls a function on all the values found in a 'Many' collection. +{- | 'map' calls a function on all the values found in a 'Many' collection. @since 1.0.0.0 -} @@ -76,8 +73,7 @@ map f (Many ks keyToValue) = Many ks (fmap f . keyToValue) -{- | - 'apply' allows you to apply many functions to many values. The function +{- | 'apply' allows you to apply many functions to many values. The function associated with each parameter is applied to the value associated with the same paremeter. @@ -90,16 +86,15 @@ -} apply :: (Many param (a -> b)) -> - (Many param a) -> - (Many param b) + Many param a -> + Many param b apply manyFs manyAs = fromKeys (keys manyFs) applyF where applyF param = lookup param manyFs <*> lookup param manyAs -{- | - 'compose' uses the values of a 'Many' value as keys to a second 'Many' to +{- | 'compose' uses the values of a 'Many' value as keys to a second 'Many' to create a 'Many' mapping from the original keys to the final values. @since 1.0.0.0 @@ -112,8 +107,7 @@ b <- lookup a manyAB lookup b manyBC -{- | - 'keys' fetches the list of keys from a 'Many'. Note that is a list and not +{- | 'keys' fetches the list of keys from a 'Many'. Note that is a list and not a set. 'Many' preserves the order and duplication of any key values that were in the key list at the time of construction. @@ -123,8 +117,7 @@ keys (Many ks _) = ks -{- | - 'elems' returns all the values that correspond to the keys of the 'Many'. The +{- | 'elems' returns all the values that correspond to the keys of the 'Many'. The values will be returned in the same order that the keys were present at the time of creation, though if you truly care about this it's probably better to use 'lookup' to make that correspondence explicit. @@ -135,8 +128,7 @@ elems (Many ks keyToValue) = Either.rights $ fmap keyToValue ks -{- | - 'toMap' converts the 'Many' into a 'Map.Map' value. If all you wanted to do +{- | 'toMap' converts the 'Many' into a 'Map.Map' value. If all you wanted to do was find the value for a specific key, you should probably use 'lookup' instead. @@ -153,8 +145,7 @@ Right value -> Just (k, value) -{- | - 'lookup' returns the value for the given parameter. If the given @k@ is +{- | 'lookup' returns the value for the given parameter. If the given @k@ is not one of the original input values that the 'Many' was constructed with, the mapping function given at the contructor will determine what value to return. Often this will be whatever a reasonable empty or default value for diff --git a/src/Orville/PostgreSQL/Plan/Operation.hs b/src/Orville/PostgreSQL/Plan/Operation.hs --- a/src/Orville/PostgreSQL/Plan/Operation.hs +++ b/src/Orville/PostgreSQL/Plan/Operation.hs @@ -2,7 +2,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {- | -Copyright : Flipstone Technology Partners 2023 +Copyright : Flipstone Technology Partners 2023-2025 License : MIT Stability : Stable @@ -15,6 +15,7 @@ , WherePlanner (..) , byField , byFieldTuple + , byMarshaller , findOne , findOneWhere , findAll @@ -47,8 +48,7 @@ import qualified Orville.PostgreSQL.Raw.RawSql as RawSql import qualified Orville.PostgreSQL.Schema as Schema -{- | - 'Operation' provides a stucture for building primitive operations that can be +{- | 'Operation' provides a stucture for building primitive operations that can be incorporated into a 'Database.Orville.PostgreSQL.Plan.Plan'. An 'Operation' provides base case implementations of the various plan execution functions. You only need to care about this type if you want to create new custom @@ -89,8 +89,7 @@ -- interesting IO interactions should generally return an empty explanation. } -{- | - 'AssertionFailed' may be returned from the execute functions of an +{- | 'AssertionFailed' may be returned from the execute functions of an 'Operation' to indicate that some expected invariant has failed. For example, following a foreign key that is enforced by the database only to find that no record exists. When an 'Operation' returns an 'AssertionFailed' value during @@ -102,10 +101,12 @@ -} newtype AssertionFailed = AssertionFailed String - deriving (Show) + deriving + ( -- | @since 1.0.0.0 + Show + ) -{- | - 'mkAssertionFailed' builds an 'AssertionFailed' error from an error message. +{- | 'mkAssertionFailed' builds an 'AssertionFailed' error from an error message. @since 1.0.0.0 -} @@ -113,10 +114,10 @@ mkAssertionFailed = AssertionFailed +-- | @since 1.0.0.0 instance Exception AssertionFailed -{- | - 'askParam' simply returns the parameter given from the plan. +{- | 'askParam' simply returns the parameter given from the plan. @since 1.0.0.0 -} @@ -129,8 +130,7 @@ , explainOperationMany = Exp.noExplanation } -{- | - 'assertRight' returns the value on the 'Right' side of an 'Either'. If +{- | 'assertRight' returns the value on the 'Right' side of an 'Either'. If the 'Either' is a 'Left', it raises 'AssertionFailed' with the message from the 'Left' side of the 'Either'. @@ -169,8 +169,7 @@ , explainOperationMany = Exp.noExplanation } -{- | - The functions below ('findOne', 'findAll', etc) accept a 'WherePlanner' +{- | The functions below ('findOne', 'findAll', etc) accept a 'WherePlanner' to determine how to build the where conditions for executing a 'Exec.Select' statement as part of a plan operation. @@ -209,8 +208,7 @@ -- either an example or dummy value. } -{- | - Builds a 'WherePlanner' that will match on a single +{- | Builds a 'WherePlanner' that will match on a single 'FieldDefinition.FieldDefinition'. The resulting 'WherePlanner' can be used with functions such as 'findOne' and 'findAll' to construct an 'Operation'. @@ -227,14 +225,13 @@ in WherePlanner { paramMarshaller = flip Marshall.marshallField fieldDef - , executeOneWhereCondition = \fieldValue -> Marshall.fieldEquals fieldDef fieldValue - , executeManyWhereCondition = \fieldValues -> Marshall.fieldIn fieldDef (dedupeFieldValues fieldValues) + , executeOneWhereCondition = Marshall.fieldEquals fieldDef + , executeManyWhereCondition = Marshall.fieldIn fieldDef . dedupeFieldValues , explainOneWhereCondition = Marshall.fieldEquals stringyField $ T.pack "EXAMPLE VALUE" , explainManyWhereCondition = Marshall.fieldIn stringyField $ fmap T.pack ("EXAMPLE VALUE 1" :| ["EXAMPLE VALUE 2"]) } -{- | - Builds a 'WherePlanner' that will match on a 2-tuple of +{- | Builds a 'WherePlanner' that will match on a 2-tuple of 'FieldDefinition.FieldDefinition's. The resulting 'WherePlanner' can be used with functions such as 'findOne' and 'findAll' to construct an 'Operation'. @@ -262,13 +259,14 @@ <$> Marshall.marshallField (fst . accessor) fieldDefA <*> Marshall.marshallField (snd . accessor) fieldDefB + packAll :: NonEmpty (String, String) -> NonEmpty (T.Text, T.Text) packAll = fmap (\(a, b) -> (T.pack a, T.pack b)) in WherePlanner { paramMarshaller = marshaller , executeOneWhereCondition = \fieldValue -> Marshall.fieldTupleIn fieldDefA fieldDefB (fieldValue :| []) - , executeManyWhereCondition = \fieldValues -> Marshall.fieldTupleIn fieldDefA fieldDefB (dedupeFieldValues fieldValues) + , executeManyWhereCondition = Marshall.fieldTupleIn fieldDefA fieldDefB . dedupeFieldValues , explainOneWhereCondition = Marshall.fieldTupleIn stringyFieldA @@ -278,9 +276,35 @@ Marshall.fieldTupleIn stringyFieldA stringyFieldB - (packAll $ (("EXAMPLE VALUE A 1", "EXAMPLE VALUE B 1") :| [("EXAMPLE VALUE A 2", "EXAMPLE VALUE B 2")])) + (packAll (("EXAMPLE VALUE A 1", "EXAMPLE VALUE B 1") :| [("EXAMPLE VALUE A 2", "EXAMPLE VALUE B 2")])) } +{- | Builds a 'WherePlanner' that will match on the writable fields of a + 'Marshall.SqlMarshaller'. The resulting 'WherePlanner' can be used with + functions such as 'findOne' and 'findAll' to construct an 'Operation'. + +@since 1.1.0.0 +-} +byMarshaller :: + Ord param => + Marshall.SqlMarshaller param param -> + WherePlanner param +byMarshaller marshaller = + let + (fieldCount, stringyMarshaller) = stringifyMarshaller marshaller + examples = fmap (\i -> T.pack $ "EXAMPLE VALUE " <> show i) [1 .. fieldCount] + in + WherePlanner + { paramMarshaller = flip Marshall.marshallNested marshaller + , executeOneWhereCondition = Marshall.marshallerEquals marshaller + , executeManyWhereCondition = Marshall.marshallerIn marshaller . dedupeFieldValues + , explainOneWhereCondition = Marshall.marshallerEquals stringyMarshaller examples + , explainManyWhereCondition = + Marshall.marshallerIn + stringyMarshaller + (fmap (<> T.pack " A") examples :| [fmap (<> T.pack " B") examples]) + } + dedupeFieldValues :: Ord a => NonEmpty a -> NonEmpty a dedupeFieldValues (first :| rest) = let @@ -292,8 +316,7 @@ in first :| dedupedWithoutFirst -{- | - 'findOne' builds a planning primitive that finds (at most) one row from the +{- | 'findOne' builds a planning primitive that finds (at most) one row from the given table where the column value for the provided 'Core.FieldDefinition' matches the plan's input parameter. When executed on multiple parameters, it fetches all rows where the field matches the inputs and arbitrarily picks at @@ -309,8 +332,7 @@ findOne tableDef wherePlanner = findOneWithOpts tableDef wherePlanner mempty -{- | - 'findOneWhere' is similar to 'findOne' but allows a 'Expr.BooleanExpr' to be +{- | 'findOneWhere' is similar to 'findOne' but allows a 'Expr.BooleanExpr' to be specified that is added to the database query to restrict which rows are returned. @@ -325,8 +347,7 @@ findOneWhere tableDef wherePlanner cond = findOneWithOpts tableDef wherePlanner (Exec.where_ cond) -{- | - 'findOneWithOpts' is a internal helper used by 'findOne' and 'findOneWhere'. +{- | 'findOneWithOpts' is a internal helper used by 'findOne' and 'findOneWhere'. @since 1.0.0.0 -} @@ -367,8 +388,7 @@ ) (Schema.tableMarshaller tableDef) -{- | - 'findAll' builds a planning primitive that finds all the rows from the given +{- | 'findAll' builds a planning primitive that finds all the rows from the given table where the column value for the provided field matches the plan's input parameter. When executed on multiple parameters, all rows are fetched in a single query and then associated with their respective inputs after being @@ -384,8 +404,7 @@ findAll tableDef wherePlanner = findAllWithOpts tableDef wherePlanner mempty -{- | - 'findAllWhere' is similar to 'findAll' but allows a 'Expr.BooleanExpr' to be +{- | 'findAllWhere' is similar to 'findAll' but allows a 'Expr.BooleanExpr' to be specified that is added to the database query to restrict which rows are returned. @@ -400,8 +419,7 @@ findAllWhere tableDef wherePlanner cond = findAllWithOpts tableDef wherePlanner (Exec.where_ cond) -{- | - 'findAllWithOpts' is an internal helper used by 'findAll' and 'findAllWhere'. +{- | 'findAllWithOpts' is an internal helper used by 'findAll' and 'findAllWhere'. @since 1.0.0.0 -} @@ -442,8 +460,7 @@ ) (Schema.tableMarshaller tableDef) -{- | - 'stringifyField' arbitrarily re-labels the 'Marshall.SqlType' of a field +{- | 'stringifyField' arbitrarily re-labels the 'Marshall.SqlType' of a field definition as text. It is an internal helper function that is used for constructing 'Expr.BooleanExpr' clauses used to generate sql when explaining how a plan will be executed. Relabeling the type as 'T.Text' allows us to use @@ -457,8 +474,48 @@ stringifyField = Marshall.convertField (const Marshall.unboundedText) -{- | - 'SelectOperation' is a helper type for building 'Operation' primitives that +{- | 'stringifyMarshaller' arbitrarily re-labels the 'Marshall.SqlType' of all the + writable fields in a marshaller as 'T.Text'. Used internally to generate SQL + for explanations. Also returns the number of re-labled fields to facilitate + generating a list of example values. + +@since 1.1.0.0 +-} +stringifyMarshaller :: + Marshall.SqlMarshaller a b -> + (Int, Marshall.SqlMarshaller [T.Text] [T.Text]) +stringifyMarshaller marshaller = + let + mkFieldMarshaller :: + Marshall.FieldQualifier qualifier => + Maybe qualifier -> + Marshall.FieldDefinition nullability a -> + (Int -> Marshall.SqlMarshaller [T.Text] T.Text) + mkFieldMarshaller mbQualifier fieldDef = + \idx -> + maybe id Marshall.marshallQualifyFields mbQualifier $ + Marshall.marshallField + (!! idx) + ( Marshall.unboundedTextField + . Marshall.fieldNameToString + . Marshall.fieldName + $ fieldDef + ) + + marshallerConstructors :: [Int -> Marshall.SqlMarshaller [T.Text] T.Text] + marshallerConstructors = + Marshall.foldMarshallerFields marshaller [] $ + Marshall.collectFromField + Marshall.ExcludeReadOnlyColumns + mkFieldMarshaller + + stringyMarshaller :: Marshall.SqlMarshaller [T.Text] [T.Text] + stringyMarshaller = + sequenceA (zipWith ($) marshallerConstructors [(0 :: Int) ..]) + in + (length marshallerConstructors, stringyMarshaller) + +{- | 'SelectOperation' is a helper type for building 'Operation' primitives that run 'Ex.cSelect' queries. Specifying the fields of 'SelectOperation' and then using the 'selectOperation' function to build an 'Operation' is more convenient than building functions to execute the queries that are required @@ -509,8 +566,7 @@ -- type as the @result@ type and 'findOne' uses 'Maybe'. } -{- | - 'selectOperation' builds a primitive planning 'Operation' using the functions +{- | 'selectOperation' builds a primitive planning 'Operation' using the functions given by a 'SelectOperation'. If you are implementing a custom operation that runs a select statement, it is probably easier to use this function rather than building the 'Operation' functions directly. @@ -533,8 +589,7 @@ explainSelect = Exp.explainStep . BS8.unpack . RawSql.toExampleBytes . Exec.selectToQueryExpr -{- | - 'executeSelectOne' is an internal helper function that executes a +{- | 'executeSelectOne' is an internal helper function that executes a 'SelectOperation' on a single input parameter. @since 1.0.0.0 @@ -548,8 +603,7 @@ Right . produceResult selectOp <$> (Exec.executeSelect . selectOne selectOp $ param) -{- | - 'executeSelectMany' is an internal helper function that executes a +{- | 'executeSelectMany' is an internal helper function that executes a 'SelectOperation' on multiple input parameters. @since 1.0.0.0 @@ -573,7 +627,7 @@ emptyRowsMap :: Map.Map param (Seq.Seq a) emptyRowsMap = Map.fromList - . map (\param -> (param, Seq.empty)) + . fmap (\param -> (param, Seq.empty)) $ paramList insertRow results row = @@ -600,8 +654,7 @@ pure . Right $ manyRows -{- | - 'findSelect' builds a plan 'Operation' where the select that is run does not +{- | 'findSelect' builds a plan 'Operation' where the select that is run does not use the input parameters for the plan in any way. The 'executeOperationMany' function of the resulting 'Operation' will run the query once and use the entire result set as the result each of the input parameters in turn. diff --git a/src/Orville/PostgreSQL/Plan/Syntax.hs b/src/Orville/PostgreSQL/Plan/Syntax.hs --- a/src/Orville/PostgreSQL/Plan/Syntax.hs +++ b/src/Orville/PostgreSQL/Plan/Syntax.hs @@ -54,8 +54,7 @@ import qualified Orville.PostgreSQL.Plan as Plan -{- | - An operator alias of 'Plan.bind' so that it can be used with @QualifiedDo@. +{- | An operator alias of 'Plan.bind' so that it can be used with @QualifiedDo@. @since 1.0.0.0 -} diff --git a/src/Orville/PostgreSQL/Raw/Connection.hs b/src/Orville/PostgreSQL/Raw/Connection.hs --- a/src/Orville/PostgreSQL/Raw/Connection.hs +++ b/src/Orville/PostgreSQL/Raw/Connection.hs @@ -2,7 +2,7 @@ {-# LANGUAGE RankNTypes #-} {- | -Copyright : Flipstone Technology Partners 2023 +Copyright : Flipstone Technology Partners 2023-2025 License : MIT Stability : Stable @@ -30,16 +30,18 @@ , ConnectionUsedAfterCloseError , ConnectionError , SqlExecutionError (..) + , transactionStatus + , transactionStatusOrThrow ) where import Control.Concurrent (getNumCapabilities, threadWaitRead, threadWaitWrite) -import Control.Concurrent.MVar (MVar, newMVar, tryReadMVar, tryTakeMVar) +import Control.Concurrent.MVar (MVar, newMVar, tryTakeMVar, withMVar) import Control.Exception (Exception, mask, throwIO) -import Control.Monad (void) import qualified Data.ByteString as BS import qualified Data.ByteString.Builder as BSB import qualified Data.ByteString.Char8 as B8 +import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.Maybe (fromMaybe) #if MIN_VERSION_resource_pool(0,4,0) import Data.Pool (Pool, newPool, defaultPoolConfig, setNumStripes, withResource) @@ -53,8 +55,7 @@ import Orville.PostgreSQL.Raw.PgTextFormatValue (NULByteFoundError (NULByteFoundError), PgTextFormatValue, toBytesForLibPQ) -{- | - An option for 'createConnectionPool' that indicates whether LibPQ should +{- | An option for 'createConnectionPool' that indicates whether LibPQ should print notice reports for warnings to the console. @since 1.0.0.0 @@ -63,8 +64,7 @@ = EnableNoticeReporting | DisableNoticeReporting -{- | -Orville always uses a connection pool to manage the number of open connections +{- | Orville always uses a connection pool to manage the number of open connections to the database. See 'ConnectionConfig' and 'createConnectionPool' to find how to create a 'ConnectionPool'. @@ -73,8 +73,7 @@ newtype ConnectionPool = ConnectionPool (Pool Connection) -{- | - 'createConnectionPool' allocates a pool of connections to a PostgreSQL server. +{- | 'createConnectionPool' allocates a pool of connections to a PostgreSQL server. @since 1.0.0.0 -} @@ -121,8 +120,7 @@ connPerStripe #endif -{- | -Values for the 'connectionPoolStripes' field of 'ConnectionOptions'. +{- | Values for the 'connectionPoolStripes' field of 'ConnectionOptions'. @since 1.0.0.0 -} @@ -137,8 +135,7 @@ -- the runtime has. StripeCount Int -{- | -Values for the 'connectionMaxConnections' field of 'ConnectionOptions'. +{- | Values for the 'connectionMaxConnections' field of 'ConnectionOptions'. @since 1.0.0.0 -} @@ -155,8 +152,7 @@ -- be this value multiplied by the number of stripes. MaxConnectionsPerStripe Int -{- | -Configuration options to pass to 'createConnectionPool' to specify the +{- | Configuration options to pass to 'createConnectionPool' to specify the parameters for the pool and the connections that it creates. @since 1.0.0.0 @@ -174,17 +170,14 @@ -- ^ Controls the number of connections available in the 'ConnectionPool'. } -{- | - INTERNAL: Resolves the 'StripeOption' to the actual number of stripes to use. --} +-- | INTERNAL: Resolves the 'StripeOption' to the actual number of stripes to use. determineStripeCount :: StripeOption -> IO Int determineStripeCount stripeOption = case stripeOption of OneStripePerCapability -> getNumCapabilities StripeCount n -> pure n -{- | - INTERNAL: Resolves the 'MaxConnections' to the actual number of connections +{- | INTERNAL: Resolves the 'MaxConnections' to the actual number of connections to use per stripe. -} determineConnectionsPerStripe :: Int -> MaxConnections -> Either String Int @@ -204,19 +197,33 @@ <> show stripes <> " stripes." -{- | - Allocates a connection from the pool and performs an action with it. This +{- | Allocates a connection from the pool and performs an action with it. This function will block if the maximum number of connections is reached. @since 1.0.0.0 -} withPoolConnection :: ConnectionPool -> (Connection -> IO a) -> IO a -withPoolConnection (ConnectionPool pool) = - withResource pool +withPoolConnection (ConnectionPool pool) action = + let + assertConnectionIdle connection mkMsg = do + status <- transactionStatusOrThrow connection + case status of + LibPQ.TransIdle -> + pure () + _ -> + withLibPQConnectionOrFailIfClosed connection $ \libPQConn -> do + throwConnectionError (mkMsg status) libPQConn -{- | - 'executeRaw' runs a given SQL statement returning the raw underlying result. + actionWithTxnStatusChecks connection = do + assertConnectionIdle connection (\status -> "Connection found in pool that was not idle. It was: " <> show status) + result <- action connection + assertConnectionIdle connection (\status -> "Would have returned a connection to the pool that was not idle. It was: " <> show status) + pure result + in + withResource pool actionWithTxnStatusChecks +{- | 'executeRaw' runs a given SQL statement returning the raw underlying result. + All handling of stepping through the result set is left to the caller. This potentially leaves connections open much longer than one would expect if all of the results are not iterated through immediately *and* the data copied. @@ -236,15 +243,29 @@ Right paramBytes -> underlyingExecute bs paramBytes connection -{- | - An Orville handler for a LibPQ connection. +data ConnectionState + = OpenConnection LibPQ.Connection + | ClosedConnection +data ConnectionContext = ConnectionContext + { i_connUtilizationLock :: MVar () + -- ^ Used to serialize access to the connection for the purpose of issuing commands + , i_connCloseLock :: MVar () + -- ^ Used to guarantee that only one thread will close the connection. This + -- is separate from the utilization lock because a connection should still + -- be closeable if it is in use by another thread but should not be closed + -- by multiple threads simultaneously. + , i_connState :: ConnectionState + -- ^ The underlying connection, if open + } + +{- | An Orville handler for a LibPQ connection. + @since 1.0.0.0 -} -newtype Connection = Connection (MVar LibPQ.Connection) +newtype Connection = Connection (IORef ConnectionContext) -{- | - 'connect' is the internal, primitive connection function. +{- | 'connect' is the internal, primitive connection function. This should not be exposed to end users, but instead wrapped in something to create a pool. @@ -275,7 +296,15 @@ LibPQ.PollingWriting -> checkSocketAndThreadWait conn threadWaitWrite LibPQ.PollingOk -> do - connectionHandle <- newMVar conn + connUseLock <- newMVar () + connCloseLock <- newMVar () + connectionHandle <- + newIORef + ConnectionContext + { i_connUtilizationLock = connUseLock + , i_connCloseLock = connCloseLock + , i_connState = OpenConnection conn + } pure (Connection connectionHandle) in do @@ -285,8 +314,7 @@ EnableNoticeReporting -> LibPQ.enableNoticeReporting connection poll connection -{- | - 'close' has many subtleties to it. +{- | 'close' has many subtleties to it. First note that async exceptions are masked. 'mask' though, only works for things that are not interruptible @@ -295,33 +323,33 @@ From the previous link, 'tryTakeMVar' is not interruptible, where @takeMVar@ *is*. So by using 'tryTakeMVar' along with 'mask', we should be safe from async exceptions causing us to not finish an underlying connection. Notice - that the only place the MVar is ever taken is here so 'tryTakeMVar' gives us - both the non-blocking semantics to protect from async exceptions with 'mask' - _and_ should never truly return an empty unless two threads were racing to - close the connection, in which case.. one of them will close the connection. + that the only place the close lock MVar is ever taken is here so + 'tryTakeMVar' gives us both the non-blocking semantics to protect from async + exceptions with 'mask' _and_ should never truly return an empty unless two + threads were racing to close the connection, in which case.. one of them will + close the connection. @since 1.0.0.0 -} close :: Connection -> IO () close (Connection handle) = let - underlyingFinish :: (forall a. IO a -> IO a) -> IO (Maybe ()) + underlyingFinish :: (forall a. IO a -> IO a) -> IO () underlyingFinish restore = do - underlyingConnection <- tryTakeMVar handle - restore (traverse LibPQ.finish underlyingConnection) + connCtx <- readIORef handle + mCloseLock <- tryTakeMVar $ i_connCloseLock connCtx + case (mCloseLock, i_connState connCtx) of + (Just (), OpenConnection underlyingConnection) -> do + writeIORef handle connCtx {i_connState = ClosedConnection} + restore (LibPQ.finish underlyingConnection) + _ -> pure () in - void $ mask underlyingFinish + mask underlyingFinish -{- | - 'underlyingExecute' is the internal, primitive execute function. +{- | 'underlyingExecute' is the internal, primitive execute function. This is not intended to be directly exposed to end users, but instead wrapped - in something using a pool. Note there are potential dragons here in that - this calls @tryReadMvar@ and then returns an error if the MVar is not full. - The intent is to never expose the ability to empty the `MVar` outside of this - module, so unless a connection has been closed it *should* never be empty. - And a connection should be closed upon removal from a resource pool (in which - case it can't be used for this function in the first place). + in something using a pool. @since 1.0.0.0 -} @@ -330,23 +358,22 @@ [Maybe BS.ByteString] -> Connection -> IO LibPQ.Result -underlyingExecute bs params connection = do - libPQConn <- readLibPQConnectionOrFailIfClosed connection - mbResult <- - LibPQ.execParams libPQConn bs (map mkInferredTextParam params) LibPQ.Text +underlyingExecute bs params connection = + withLibPQConnectionOrFailIfClosed connection $ \libPQConn -> do + mbResult <- + LibPQ.execParams libPQConn bs (fmap mkInferredTextParam params) LibPQ.Text - case mbResult of - Nothing -> do - throwExecutionErrorWithoutResult libPQConn bs - Just result -> do - execStatus <- LibPQ.resultStatus result + case mbResult of + Nothing -> do + throwExecutionErrorWithoutResult libPQConn bs + Just result -> do + execStatus <- LibPQ.resultStatus result - if isRowReadableStatus execStatus - then pure result - else throwExecutionErrorWithResult result execStatus bs + if isRowReadableStatus execStatus + then pure result + else throwExecutionErrorWithResult result execStatus bs -{- | - Escapes and quotes a string for use as a literal within a SQL command that +{- | Escapes and quotes a string for use as a literal within a SQL command that will be executed on the given connection. This uses the @PQescapeStringConn@ function from LibPQ, which takes the character encoding of the connection into account. Note that while @PQescapeStringConn@ does not surround the @@ -361,22 +388,21 @@ @since 1.0.0.0 -} quoteStringLiteral :: Connection -> BS.ByteString -> IO BSB.Builder -quoteStringLiteral connection unquotedString = do - libPQConn <- readLibPQConnectionOrFailIfClosed connection - mbEscapedString <- LibPQ.escapeStringConn libPQConn unquotedString +quoteStringLiteral connection unquotedString = + withLibPQConnectionOrFailIfClosed connection $ \libPQConn -> do + mbEscapedString <- LibPQ.escapeStringConn libPQConn unquotedString - case mbEscapedString of - Nothing -> - throwConnectionError "Error while escaping string literal" libPQConn - Just escapedString -> - let - singleQuote = - BSB.char8 '\'' - in - pure (singleQuote <> BSB.byteString escapedString <> singleQuote) + case mbEscapedString of + Nothing -> + throwConnectionError "Error while escaping string literal" libPQConn + Just escapedString -> + let + singleQuote = + BSB.char8 '\'' + in + pure (singleQuote <> BSB.byteString escapedString <> singleQuote) -{- | - Escapes and quotes a string for use as an identifier within a SQL command +{- | Escapes and quotes a string for use as an identifier within a SQL command that will be executed on the given connection. This uses the @PQescapeIdentifier@ function from LibPQ, which takes the character encoding of the connection into account and also applies the quotes. @@ -388,26 +414,57 @@ @since 1.0.0.0 -} quoteIdentifier :: Connection -> BS.ByteString -> IO BSB.Builder -quoteIdentifier connection unquotedString = do - libPQConn <- readLibPQConnectionOrFailIfClosed connection - mbEscapedString <- LibPQ.escapeIdentifier libPQConn unquotedString +quoteIdentifier connection unquotedString = + withLibPQConnectionOrFailIfClosed connection $ \libPQConn -> do + mbEscapedString <- LibPQ.escapeIdentifier libPQConn unquotedString - case mbEscapedString of - Nothing -> - throwConnectionError "Error while escaping identifier" libPQConn - Just quotedString -> - pure (BSB.byteString quotedString) + case mbEscapedString of + Nothing -> + throwConnectionError "Error while escaping identifier" libPQConn + Just quotedString -> + pure (BSB.byteString quotedString) -readLibPQConnectionOrFailIfClosed :: Connection -> IO LibPQ.Connection -readLibPQConnectionOrFailIfClosed (Connection handle) = do - mbConn <- tryReadMVar handle +{- | Serializes access to the underlying LibPQ connection. This is necessary + because multiple concurrent commands issued using the same connection will + result in a dead-lock in LibPQ. - case mbConn of - Nothing -> - throwIO ConnectionUsedAfterCloseError - Just conn -> - pure conn + Do not nest calls to this function with the same connection or it will + dead-lock on the MVar. +-} +withLibPQConnectionOrFailIfClosed :: Connection -> (LibPQ.Connection -> IO a) -> IO a +withLibPQConnectionOrFailIfClosed (Connection handle) withConnection = do + connCtx <- readIORef handle + withMVar (i_connUtilizationLock connCtx) $ \() -> + case i_connState connCtx of + ClosedConnection -> + throwIO ConnectionUsedAfterCloseError + OpenConnection conn -> + withConnection conn +{- | Returns 'Just' the transaction status of the current connection, as reported by @libpq@, or + 'Nothing' if the connection is currently closed. See 'Database.PostgreSQL.LibPQ.transactionStatus', + 'Database.PostgreSQL.LibPQ.TransactionStatus' for more information. + +@since 1.1.0.0 +-} +transactionStatus :: Connection -> IO (Maybe LibPQ.TransactionStatus) +transactionStatus (Connection handle) = do + connCtx <- readIORef handle + withMVar (i_connUtilizationLock connCtx) $ \() -> + case i_connState connCtx of + ClosedConnection -> + pure Nothing + OpenConnection conn -> + fmap Just (LibPQ.transactionStatus conn) + +{- | Similar to 'transactionStatus', but throws a 'ConnectionUsedAfterCloseError' if the connection is closed. + +@since 1.1.0.0 +-} +transactionStatusOrThrow :: Connection -> IO LibPQ.TransactionStatus +transactionStatusOrThrow conn = + withLibPQConnectionOrFailIfClosed conn LibPQ.transactionStatus + throwConnectionError :: String -> LibPQ.Connection -> IO a throwConnectionError message conn = do mbLibPQError <- LibPQ.errorMessage conn @@ -463,9 +520,12 @@ LibPQ.BadResponse -> False LibPQ.NonfatalError -> False -- NonfatalError never returned from LibPQ query execution functions. It passes them to the notice processor instead. LibPQ.FatalError -> False +#if MIN_VERSION_postgresql_libpq(0,11,0) + LibPQ.PipelineSync -> False + LibPQ.PipelineAbort -> False +#endif -{- | - Packages a bytestring parameter value (which is assumed to be a value encoded +{- | Packages a bytestring parameter value (which is assumed to be a value encoded as text that the database can use) as a parameter for executing a query. This uses Oid 0 to cause the database to infer the type of the paremeter and explicitly marks the parameter as being in Text format. @@ -480,8 +540,7 @@ Just value -> Just (LibPQ.Oid 0, value, LibPQ.Text) -{- | - Orville throws a 'ConnectionError' on an error reported by the underlying +{- | Orville throws a 'ConnectionError' on an error reported by the underlying LibPQ connection that does not come directly from executing SQL. This could could represent an inability to open a new database connection, but could also represent other errors such as an error while quoting a database @@ -510,10 +569,10 @@ in connectionErrorMessage err <> ": " <> libPQErrorMsg +-- | @since 1.0.0.0 instance Exception ConnectionError -{- | - Orville throws a 'SqlExecutionError' when an error is reported by the +{- | Orville throws a 'SqlExecutionError' when an error is reported by the underlying LibPQ connection during an attempt to execute SQL. @since 1.0.0.0 @@ -531,12 +590,15 @@ , sqlExecutionErrorSqlQuery :: BS.ByteString -- ^ The SQL query that was being run when the error occurred. } - deriving (Show) + deriving + ( -- | @since 1.0.0.0 + Show + ) +-- | @since 1.0.0.0 instance Exception SqlExecutionError -{- | - Orville throws as 'ConnectionUsedAfterCloseError' if it attempts to use a +{- | Orville throws as 'ConnectionUsedAfterCloseError' if it attempts to use a 'Connection' value after it has already been closed. If this occurs, it is a bug in Orville. @@ -544,6 +606,10 @@ -} data ConnectionUsedAfterCloseError = ConnectionUsedAfterCloseError - deriving (Show) + deriving + ( -- | @since 1.0.0.0 + Show + ) +-- | @since 1.0.0.0 instance Exception ConnectionUsedAfterCloseError diff --git a/src/Orville/PostgreSQL/Raw/PgTextFormatValue.hs b/src/Orville/PostgreSQL/Raw/PgTextFormatValue.hs --- a/src/Orville/PostgreSQL/Raw/PgTextFormatValue.hs +++ b/src/Orville/PostgreSQL/Raw/PgTextFormatValue.hs @@ -18,8 +18,7 @@ import Control.Exception (Exception) import qualified Data.ByteString as BS -{- | - A 'PgTextFormatValue' represents raw bytes that will be passed to PostgreSQL +{- | A 'PgTextFormatValue' represents raw bytes that will be passed to PostgreSQL via LibPQ. These bytes must conform to the TEXT format of values that PostgreSQL expects. In all cases, PostgreSQL will be allowed to infer the type of the value based on its usage in the query. @@ -40,20 +39,33 @@ data PgTextFormatValue = NoAssumptionsMade BS.ByteString | AssumedToHaveNoNULValues BS.ByteString - deriving (Show) + deriving + ( -- | @since 1.0.0.0 + Show + ) +-- | @since 1.0.0.0 instance Eq PgTextFormatValue where left == right = toBytesForLibPQ left == toBytesForLibPQ right +{- | The exception raised when encountering a '\NUL' byte is unexpectedly found + +@since 1.0.0.0 +-} data NULByteFoundError = NULByteFoundError - deriving (Show, Eq) + deriving + ( -- | @since 1.0.0.0 + Show + , -- | @since 1.0.0.0 + Eq + ) +-- | @since 1.0.0.0 instance Exception NULByteFoundError -{- | - Constructs a 'PgTextFormatValue' from the given bytes directly, without checking +{- | Constructs a 'PgTextFormatValue' from the given bytes directly, without checking whether any of the bytes are '\NUL' or not. If a 'BS.ByteString' containing a '\NUL' byte is given, the value will be truncated at the '\NUL' when it is passed to LibPQ. @@ -68,8 +80,7 @@ unsafeFromByteString = AssumedToHaveNoNULValues -{- | - Constructs a 'PgTextFormatValue' from the given bytes, which will be checked +{- | Constructs a 'PgTextFormatValue' from the given bytes, which will be checked to ensure none of them are '\NUL' before being passed to LibPQ. If a '\NUL' byte is found an error will be raised. @@ -79,8 +90,7 @@ fromByteString = NoAssumptionsMade -{- | - Converts the 'PgTextFormatValue' to bytes intended to be passed to LibPQ. +{- | Converts the 'PgTextFormatValue' to bytes intended to be passed to LibPQ. If any '\NUL' bytes are found, 'NULByteFoundError' will be returned (unless 'unsafeFromByteString' was used to construct the value). @@ -96,8 +106,7 @@ then Left NULByteFoundError else Right anyBytes -{- | - Converts the 'PgTextFormatValue' back to the bytes that were used to +{- | Converts the 'PgTextFormatValue' back to the bytes that were used to construct it, losing the information about whether it would be checked for '\NUL' bytes or not. diff --git a/src/Orville/PostgreSQL/Raw/PgTime.hs b/src/Orville/PostgreSQL/Raw/PgTime.hs --- a/src/Orville/PostgreSQL/Raw/PgTime.hs +++ b/src/Orville/PostgreSQL/Raw/PgTime.hs @@ -1,5 +1,5 @@ {- | -Copyright : Flipstone Technology Partners 2023 +Copyright : Flipstone Technology Partners 2023-2025 License : MIT Stability : Stable @@ -15,6 +15,8 @@ ) where +import Control.Applicative ((<|>)) +import Control.Monad (when) import qualified Data.Attoparsec.ByteString as AttoBS import qualified Data.Attoparsec.ByteString.Char8 as AttoB8 import qualified Data.ByteString as BS @@ -23,114 +25,149 @@ import qualified Data.Fixed as Fixed import qualified Data.Time as Time import qualified Data.Word as Word +import qualified Text.Printf as Printf -{- | - Renders a 'Time.Day' value to a textual representation for PostgreSQL. +{- | Renders a 'Time.Day' value to a textual representation for PostgreSQL. @since 1.0.0.0 -} dayToPostgreSQL :: Time.Day -> B8.ByteString -dayToPostgreSQL = - B8.pack . Time.showGregorian +dayToPostgreSQL date = + case mkCommonEraDay date of + (ce, ced) -> + B8.pack (renderCommonEraDay ced <> renderCommonEraSuffix ce) -{- | - An Attoparsec parser for parsing 'Time.Day' from YYYY-MM-DD format. Parsing - fails if given an invalid 'Time.Day'. +{- | An Attoparsec parser for parsing 'Time.Day' from a string in PostgreSQL's ISO style + (YYYY-MM-DD[ BC]) format. Parsing fails if given an invalid 'Time.Day'. @since 1.0.0.0 -} day :: AttoB8.Parser Time.Day day = do - (y, yearCount) <- decimalWithCount <* AttoB8.char '-' - if yearCount < 4 - then fail "invalid date format" - else do - m <- twoDigits <* AttoB8.char '-' - d <- twoDigits - maybe (fail "invalid date format") pure $ Time.fromGregorianValid y m d - -{- | - An Attoparsec parser for parsing 2-digit integral numbers. - -@since 1.0.0.0 --} -twoDigits :: Integral a => AttoB8.Parser a -twoDigits = do - tens <- AttoB8.digit - ones <- AttoB8.digit - pure $ fromChar tens * 10 + fromChar ones + ced <- commonEraDay + ce <- parseCommonEraSuffix + commonEraDayToISO8601Day ce ced -fromChar :: Integral a => Char -> a -fromChar c = fromIntegral $ Char.ord c - Char.ord '0' +commonEraDay :: AttoB8.Parser CommonEraDay +commonEraDay = do + (y, yearCount) <- decimalWithCount <* AttoB8.char '-' + when (yearCount < 4) (fail "invalid date format") + m <- twoDigits <* AttoB8.char '-' + d <- twoDigits + pure $ CommonEraDay y m d -{- | - Renders a 'Time.UTCTime' value to a textual representation for PostgreSQL. +{- | Renders a 'Time.UTCTime' value to a textual representation for PostgreSQL. @since 1.0.0.0 -} utcTimeToPostgreSQL :: Time.UTCTime -> B8.ByteString -utcTimeToPostgreSQL = - B8.pack . Time.formatTime Time.defaultTimeLocale "%0Y-%m-%d %H:%M:%S%Q+00" +utcTimeToPostgreSQL time = + let + -- DiffTime lacks support for %Q (fractional seconds), so be sure to format + -- via a type that supports %Q. + formattedTime = + Time.formatTime Time.defaultTimeLocale "%0H:%0M:%0S%Q+00" + . Time.timeToTimeOfDay + $ Time.utctDayTime time + in + case mkCommonEraDay (Time.utctDay time) of + (ce, ced) -> + B8.pack $ + renderCommonEraDay ced <> " " <> formattedTime <> renderCommonEraSuffix ce -{- | - An Attoparsec parser for parsing 'Time.UTCTime' from an ISO-8601 style - datetime and timezone with a few PostgreSQL-specific exceptions. See - 'localTime' for more details. +{- | An Attoparsec parser for 'Time.UTCTime' from a PostgreSQL ISO style timestamptz format. @since 1.0.0.0 -} utcTime :: AttoB8.Parser Time.UTCTime utcTime = do - lt <- localTime - sign <- AttoB8.satisfy (\char -> char == '+' || char == '-' || char == 'Z') - if sign == 'Z' - then pure $ Time.localTimeToUTC Time.utc lt - else do - hour <- twoDigits - minute <- AttoB8.option 0 $ AttoB8.choice [AttoB8.char ':' *> twoDigits, twoDigits] - second <- AttoB8.option 0 $ AttoB8.char ':' *> twoDigits - let - offsetSeconds :: Int - offsetSeconds = (second + minute * 60 + hour * 3600) * if sign == '+' then (-1) else 1 - offsetNominalDiffTime = fromIntegral offsetSeconds - diffTime = Time.timeOfDayToTime (Time.localTimeOfDay lt) - utcTimeWithoutOffset = Time.UTCTime (Time.localDay lt) diffTime - pure $ Time.addUTCTime offsetNominalDiffTime utcTimeWithoutOffset + ced <- commonEraDay <* AttoB8.char ' ' + time <- timeOfDay + offset <- signedTimezoneOffset + ce <- parseCommonEraSuffix + validDay <- commonEraDayToISO8601Day ce ced + pure $ Time.addUTCTime offset (Time.UTCTime validDay (Time.timeOfDayToTime time)) -{- | - Renders a 'Time.LocalTime' value to a textual representation for PostgreSQL. +signedTimezoneOffset :: AttoB8.Parser Time.NominalDiffTime +signedTimezoneOffset = do + sign <- AttoB8.satisfy (\char -> char == '+' || char == '-') + case sign of + '+' -> fmap negate timezoneOffset + _ -> timezoneOffset +timezoneOffset :: AttoB8.Parser Time.NominalDiffTime +timezoneOffset = do + h <- twoDigits + m <- AttoB8.option 0 (AttoB8.char ':' *> twoDigits) + s <- AttoB8.option 0 (AttoB8.char ':' *> twoDigits) + pure . fromIntegral $ (s :: Int) + m * 60 + h * 3600 + +{- | Renders a 'Time.LocalTime' value to a textual representation for PostgreSQL. + @since 1.0.0.0 -} localTimeToPostgreSQL :: Time.LocalTime -> B8.ByteString -localTimeToPostgreSQL = - B8.pack . Time.formatTime Time.defaultTimeLocale "%0Y-%m-%d %H:%M:%S%Q" +localTimeToPostgreSQL time = + let + formattedTime = + Time.formatTime Time.defaultTimeLocale "%0H:%0M:%0S%Q" $ + Time.localTimeOfDay time + in + case mkCommonEraDay (Time.localDay time) of + (ce, ced) -> + B8.pack $ + renderCommonEraDay ced <> " " <> formattedTime <> renderCommonEraSuffix ce -{- | - An Attoparsec parser for parsing 'Time.LocalTime' from an ISO-8601 style - datetime with a few exceptions. The separator between the date and time - is always @\' \'@ and never @\'T\'@. +{- | An Attoparsec parser for 'Time.LocalTime' from PostgreSQL's ISO style timestamp format. @since 1.0.0.0 -} localTime :: AttoB8.Parser Time.LocalTime localTime = do - Time.LocalTime <$> day <* AttoB8.char ' ' <*> timeOfDay + ced <- commonEraDay <* AttoB8.char ' ' + time <- timeOfDay + ce <- parseCommonEraSuffix + validDay <- commonEraDayToISO8601Day ce ced + pure $ Time.LocalTime validDay time -{- | - An Attoparsec parser for parsing 'Time.TimeOfDay' from an ISO-8601 style time. +{- | An Attoparsec parser for 'Time.TimeOfDay' from PostgreSQL's ISO style time format. @since 1.0.0.0 -} timeOfDay :: AttoB8.Parser Time.TimeOfDay timeOfDay = do h <- twoDigits <* AttoB8.char ':' - m <- twoDigits - s <- AttoB8.option 0 (AttoB8.char ':' *> seconds) - maybe (fail "invalid time format") pure $ Time.makeTimeOfDayValid h m s + m <- twoDigits <* AttoB8.char ':' + s <- seconds + case Time.makeTimeOfDayValid h m s of + Nothing -> fail "invalid time format" + Just validTime -> pure validTime -{- | - An Attoparsec parser for parsing a base-10 number. Returns the number of +{- | An Attoparsec parser for parsing 'Fixed.Pico' from SS[.sss] format. This can + handle more resolution than PostgreSQL uses, and will truncate the seconds + fraction if more than 12 digits are present. + +@since 1.0.0.0 +-} +seconds :: AttoB8.Parser Fixed.Pico +seconds = do + s <- twoDigits + (dec, charCount) <- AttoB8.option (0, 0) (AttoB8.char '.' *> decimalWithCount) + if charCount >= 12 + then pure . Fixed.MkFixed $ (s * 10 ^ (12 :: Int)) + (dec `div` 10 ^ (charCount - 12)) + else pure . Fixed.MkFixed $ (s * 10 ^ (12 :: Int)) + (dec * 10 ^ (12 - charCount)) + +{- | An Attoparsec parser for parsing 2-digit integral numbers. + +@since 1.0.0.0 +-} +twoDigits :: Integral a => AttoB8.Parser a +twoDigits = do + tens <- fmap (fromIntegral . Char.digitToInt) AttoB8.digit + ones <- fmap (fromIntegral . Char.digitToInt) AttoB8.digit + pure $ tens * 10 + ones + +{- | An Attoparsec parser for parsing a base-10 number. Returns the number of digits consumed. Based off of 'AttoB8.decimal'. @since 1.0.0.0 @@ -143,17 +180,45 @@ appendDigit :: Integral a => a -> Word.Word8 -> a appendDigit a w = a * 10 + fromIntegral (w - 48) -{- | - An Attoparsec parser for parsing 'Fixed.Pico' from SS[.sss] format. This can - handle more resolution than PostgreSQL uses, and will truncate the seconds - fraction if more than 12 digits are present. +data CommonEra + = BCE + | CE -@since 1.0.0.0 --} -seconds :: AttoB8.Parser Fixed.Pico -seconds = do - s <- twoDigits - (dec, charCount) <- AttoB8.option (0, 0) (AttoB8.char '.' *> decimalWithCount) - if charCount >= 12 - then pure $ Fixed.MkFixed $ (s * 10 ^ (12 :: Int)) + (dec `div` 10 ^ (charCount - 12)) - else pure $ Fixed.MkFixed $ (s * 10 ^ (12 :: Int)) + (dec * 10 ^ (12 - charCount)) +renderCommonEraSuffix :: CommonEra -> String +renderCommonEraSuffix ce = + case ce of + BCE -> " BC" + CE -> mempty + +parseCommonEraSuffix :: AttoB8.Parser CommonEra +parseCommonEraSuffix = + (BCE <$ AttoB8.string (B8.pack " BC") <|> pure CE) <* AttoB8.endOfInput + +data CommonEraDay = CommonEraDay + { _commonEraDayYear :: Integer + , _commonEraDayMonth :: Int + , _commonEraDayDay :: Int + } + +mkCommonEraDay :: Time.Day -> (CommonEra, CommonEraDay) +mkCommonEraDay date = + case Time.toGregorian date of + (y, m, d) -> + fmap + (\cey -> CommonEraDay cey m d) + (if y <= 0 then (BCE, 1 - y) else (CE, y)) + +renderCommonEraDay :: CommonEraDay -> String +renderCommonEraDay (CommonEraDay y m d) = + Printf.printf "%04d-%02d-%02d" y m d + +commonEraDayToISO8601Day :: MonadFail m => CommonEra -> CommonEraDay -> m Time.Day +commonEraDayToISO8601Day ce (CommonEraDay y m d) = + let + iso8601Year = case ce of + BCE -> 1 - y + CE -> y + in + case Time.fromGregorianValid iso8601Year m d of + Nothing -> fail "invalid date" + Just valid -> pure valid diff --git a/src/Orville/PostgreSQL/Raw/RawSql.hs b/src/Orville/PostgreSQL/Raw/RawSql.hs --- a/src/Orville/PostgreSQL/Raw/RawSql.hs +++ b/src/Orville/PostgreSQL/Raw/RawSql.hs @@ -1,6 +1,6 @@ {- | -Copyright : Flipstone Technology Partners 2023 +Copyright : Flipstone Technology Partners 2023-2025 License : MIT Stability : Stable @@ -19,6 +19,7 @@ , execute , executeVoid , connectionQuoting + , appendWithCommaSpace -- * Fragments provided for convenience , space @@ -32,6 +33,7 @@ , stringLiteral , identifier , parenthesized + , nullLiteral -- * Integer values as literals , intDecLiteral @@ -61,6 +63,7 @@ import Data.Functor.Identity (Identity (Identity, runIdentity)) import qualified Data.Int as Int import qualified Data.List as List +import qualified Data.List.NonEmpty as NE import qualified Data.Text as T import qualified Data.Text.Encoding as TextEnc import qualified Database.PostgreSQL.LibPQ as LibPQ @@ -70,8 +73,7 @@ import Orville.PostgreSQL.Raw.SqlValue (SqlValue) import qualified Orville.PostgreSQL.Raw.SqlValue as SqlValue -{- | - 'RawSql' provides a type for efficiently constructing raw SQL statements from +{- | 'RawSql' provides a type for efficiently constructing raw SQL statements from smaller parts and then executing them. It also supports using placeholder values to pass parameters with a query without having to interpolate them as part of the actual SQL state and being exposed to SQL injection. @@ -84,18 +86,33 @@ | StringLiteral BS.ByteString | Identifier BS.ByteString | Append RawSql RawSql + | Empty +-- | @since 1.0.0.0 instance Semigroup RawSql where (SqlSection builderA) <> (SqlSection builderB) = SqlSection (builderA <> builderB) + Empty <> otherB = otherB + otherA <> Empty = otherA otherA <> otherB = Append otherA otherB +-- | @since 1.0.0.0 instance Monoid RawSql where - mempty = SqlSection mempty + mempty = Empty -{- | - 'SqlExpression' provides a common interface for converting types to and from +{- | Append two 'RawSql' values together with 'commaSpace' in between, unless + either of the values are empty. + +@since 1.1.0.0 +-} +appendWithCommaSpace :: RawSql -> RawSql -> RawSql +appendWithCommaSpace a b = case (a, b) of + (Empty, x) -> x + (x, Empty) -> x + (x, y) -> x <> commaSpace <> y + +{- | 'SqlExpression' provides a common interface for converting types to and from 'RawSql', either via 'toRawSql' and 'unsafeFromRawSql', or the convenience function 'unsafeSqlExpression'. Orville defines a large number of types that represent various fragments of SQL statements as well as functions to help @@ -112,12 +129,12 @@ toRawSql :: a -> RawSql unsafeFromRawSql :: RawSql -> a +-- | @since 1.0.0.0 instance SqlExpression RawSql where toRawSql = id unsafeFromRawSql = id -{- | -A convenience function for creating an arbitrary 'SqlExpression' from a +{- | A convenience function for creating an arbitrary 'SqlExpression' from a 'String'. Great care should be exercised when using this function as it cannot provide any sort of guarantee that the string passed is usable to generate valid SQL via the rest of Orville's 'Orville.PostgreSQL.Expr' API. @@ -135,8 +152,7 @@ unsafeSqlExpression = unsafeFromRawSql . fromString -{- | - Provides procedures for quoting parts of a raw SQL query so that they can be +{- | Provides procedures for quoting parts of a raw SQL query so that they can be safely executed. Quoting may be done in some 'Monad' m, allowing for the use of quoting operations provided by 'Conn.Connection', which operates in the 'IO' monad. @@ -150,8 +166,7 @@ , quoteIdentifier :: BS.ByteString -> m BSB.Builder } -{- | - Quoting done in pure Haskell that is suitable for showing SQL examples, +{- | Quoting done in pure Haskell that is suitable for showing SQL examples, but is not guaranteed to be sufficient for all database connections. For quoting that is based on the actual connection to the database, see 'connectionQuoting'. @@ -188,8 +203,7 @@ <> BSB.byteString (B8.unfoldr quote (Right unquoted)) <> quoteBytes -{- | - Quoting done in IO using the quoting functions provided by the connection, +{- | Quoting done in IO using the quoting functions provided by the connection, which can apply quoting based on the specific connection properties. If you don't have a connection available and are only planning on using the @@ -204,8 +218,7 @@ , quoteIdentifier = Conn.quoteIdentifier connection } -{- | - Constructs the actual SQL bytestring and parameter values that will be passed +{- | Constructs the actual SQL bytestring and parameter values that will be passed to the database to execute a 'RawSql' query. Any string literals that are included in the SQL expression will be quoted using the given quoting directive. @@ -225,8 +238,7 @@ , DList.toList (paramValues finalProgress) ) -{- | - Builds the bytes that represent the raw SQL. These bytes may not be executable +{- | Builds the bytes that represent the raw SQL. These bytes may not be executable on their own, because they may contain placeholders that must be filled in, but can be useful for inspecting SQL queries. @@ -236,8 +248,7 @@ toExampleBytes = fst . runIdentity . toBytesAndParams exampleQuoting -{- | - This is an internal datatype used during the SQL building process to track +{- | This is an internal datatype used during the SQL building process to track how many params have been seen so that placeholder indices (e.g. '$1', etc) can be generated to include in the SQL. @@ -248,8 +259,7 @@ , paramValues :: DList (Maybe PgTextFormatValue) } -{- | - An initial value for 'ParamsProgress' that indicates no params have been been +{- | An initial value for 'ParamsProgress' that indicates no params have been been encountered yet. @since 1.0.0.0 @@ -261,8 +271,7 @@ , paramValues = DList.empty } -{- | - Adds a parameter value to the end of the params list, tracking the count +{- | Adds a parameter value to the end of the params list, tracking the count of parameters as it does so. @since 1.0.0.0 @@ -274,8 +283,7 @@ , paramValues = DList.snoc values newValue } -{- | - Constructs a bytestring builder that can be executed to get the bytes for a +{- | Constructs a bytestring builder that can be executed to get the bytes for a section of 'RawSql'. This function takes and returns a 'ParamsProgress' so that placeholder indices (e.g. '$1') and their corresponding parameter values can be tracked across multiple sections of raw SQL. @@ -298,20 +306,57 @@ Identifier unquotedIdentifier -> do quotedIdentifier <- quoteIdentifier quoting unquotedIdentifier pure (quotedIdentifier, progress) - Parameter value -> - let - newProgress = snocParam progress (SqlValue.toPgValue value) - placeholder = BSB.stringUtf8 "$" <> BSB.intDec (paramCount newProgress) - in - pure (placeholder, newProgress) + Parameter value -> pure $ buildParameterSql value progress Append first second -> do (firstBuilder, nextProgress) <- buildSqlWithProgress quoting progress first (secondBuilder, finalProgress) <- buildSqlWithProgress quoting nextProgress second pure (firstBuilder <> secondBuilder, finalProgress) + Empty -> + pure (mempty, progress) -{- | - Constructs a 'RawSql' from a 'String' value using UTF-8 encoding. +buildParameterSql :: + SqlValue.SqlValue -> + ParamsProgress -> + (BSB.Builder, ParamsProgress) +buildParameterSql = + let + mkSingleValue mbPgVal currentProgress = + let + newProgress = snocParam currentProgress mbPgVal + placeholder = BSB.stringUtf8 "$" <> BSB.intDec (paramCount newProgress) + in + (placeholder, newProgress) + mkRowValue :: + NE.NonEmpty (ParamsProgress -> (BSB.Builder, ParamsProgress)) -> + ParamsProgress -> + (BSB.Builder, ParamsProgress) + mkRowValue (mkFirstRowVal NE.:| mkRowVals) currentProgress = + let + (firstRowVal, firstRowProgress) = mkFirstRowVal currentProgress + (remainingRowVals, newProgress) = + foldr + ( \mkNextRow mkRemainingRows rowProgress -> + let + (valBuilder, newRowProgress) = mkNextRow rowProgress + (remainingBuilder, remainingProgress) = mkRemainingRows newRowProgress + in + (BSB.stringUtf8 "," <> valBuilder <> remainingBuilder, remainingProgress) + ) + (\p -> (mempty, p)) + mkRowVals + firstRowProgress + placeholder = BSB.stringUtf8 "(" <> firstRowVal <> remainingRowVals <> BSB.stringUtf8 ")" + in + (placeholder, newProgress) + in + SqlValue.foldSqlValue + (mkSingleValue . Just) + mkRowValue + (mkSingleValue Nothing) + +{- | Constructs a 'RawSql' from a 'String' value using UTF-8 encoding. + Note that because the string is treated as raw SQL, it is completely up to the caller to protected againt SQL-injection attacks when using this function. Never use this function with input read from an untrusted source. @@ -322,8 +367,7 @@ fromString = SqlSection . BSB.stringUtf8 -{- | - Constructs a 'RawSql' from a 'T.Text' value using UTF-8 encoding. +{- | Constructs a 'RawSql' from a 'T.Text' value using UTF-8 encoding. Note that because the text is treated as raw SQL, it is completely up to the caller to protected againt SQL-injection attacks when using this function. @@ -335,8 +379,7 @@ fromText = SqlSection . TextEnc.encodeUtf8Builder -{- | - Constructs a 'RawSql' from a 'BS.ByteString' value, which is assumed to be +{- | Constructs a 'RawSql' from a 'BS.ByteString' value, which is assumed to be encoded sensibly for the database to handle. Note that because the string is treated as raw SQL, it is completely up to @@ -349,8 +392,7 @@ fromBytes = SqlSection . BSB.byteString -{- | - Includes an input parameter in the 'RawSql' statement that will be passed +{- | Includes an input parameter in the 'RawSql' statement that will be passed using placeholders (e.g. '$1') rather than being included directly in the SQL statement. This is the correct way to include input from untrusted sources as part of a 'RawSql' query. The parameter must be formatted in a textual @@ -363,8 +405,7 @@ parameter = Parameter -{- | - Includes a bytestring value as a string literal in the SQL statement. The +{- | Includes a bytestring value as a string literal in the SQL statement. The string literal will be quoted and escaped for you; the value provided should not include surrounding quotes or quote special characters. @@ -379,8 +420,7 @@ stringLiteral = StringLiteral -{- | - Includes a bytestring value as an identifier in the SQL statement. The +{- | Includes a bytestring value as an identifier in the SQL statement. The identifier will be quoted and escaped for you; the value provided should not include surrounding quotes or quote special characters. @@ -390,8 +430,7 @@ identifier = Identifier -{- | - Concatenates a list of 'RawSql' values using another 'RawSql' value as the +{- | Concatenates a list of 'RawSql' values using another 'RawSql' value as the separator between the items. @since 1.0.0.0 @@ -400,11 +439,10 @@ intercalate separator = mconcat . List.intersperse separator - . map toRawSql + . fmap toRawSql . Fold.toList -{- | - Executes a 'RawSql' value using the 'Conn.executeRaw' function. Make sure +{- | Executes a 'RawSql' value using the 'Conn.executeRaw' function. Make sure to read the documentation of 'Conn.executeRaw' for caveats and warnings. Use with caution. @@ -418,8 +456,7 @@ (sqlBytes, params) <- toBytesAndParams (connectionQuoting connection) sql Conn.executeRaw connection sqlBytes params -{- | - Executes a 'RawSql' value using the 'Conn.executeRawVoid' function. Make sure +{- | Executes a 'RawSql' value using the 'Conn.executeRawVoid' function. Make sure to read the documentation of 'Conn.executeRawVoid' for caveats and warnings. Use with caution. @@ -429,43 +466,66 @@ @since 1.0.0.0 -} executeVoid :: SqlExpression sql => Conn.Connection -> sql -> IO () -executeVoid connection sql = do - void $ execute connection sql +executeVoid connection = + void . execute connection --- | Just a plain old space, provided for convenience. +{- | Just a plain old space, provided for convenience. + +@since 1.0.0.0 +-} space :: RawSql space = fromString " " --- | Just a plain old comma, provided for convenience. +{- | Just a plain old comma, provided for convenience. + +@since 1.0.0.0 +-} comma :: RawSql comma = fromString "," --- | Comma space separator, provided for convenience. +{- | Comma space separator, provided for convenience. + +@since 1.0.0.0 +-} commaSpace :: RawSql commaSpace = fromString ", " --- | Just a plain old left paren, provided for convenience. +{- | Just a plain old left paren, provided for convenience. + +@since 1.0.0.0 +-} leftParen :: RawSql leftParen = fromString "(" --- | Just a plain old right paren, provided for convenience. +{- | Just a plain old right paren, provided for convenience. + +@since 1.0.0.0 +-} rightParen :: RawSql rightParen = fromString ")" --- | Just a plain period, provided for convenience. +{- | Just a plain period, provided for convenience. + +@since 1.0.0.0 +-} dot :: RawSql dot = fromString "." --- | Just a plain double quote, provided for convenience. +{- | Just a plain double quote, provided for convenience. + +@since 1.0.0.0 +-} doubleQuote :: RawSql doubleQuote = fromString "\"" --- | Just two colons, provided for convenience. +{- | Just two colons, provided for convenience. + +@since 1.0.0.0 +-} doubleColon :: RawSql doubleColon = fromString "::" -{- | - Constructs a 'RawSql' from an 'Int.Int8' value. The integral value is +{- | Constructs a 'RawSql' from an 'Int.Int8' value. The integral value is included directly in the SQL string, not passed as a parameter. When dealing with user input, it is better to use 'parameter' whenever possible. @@ -475,8 +535,7 @@ int8DecLiteral = SqlSection . BSB.int8Dec -{- | - Constructs a 'RawSql' from an 'Int.Int16' value. The integral value is +{- | Constructs a 'RawSql' from an 'Int.Int16' value. The integral value is included directly in the SQL string, not passed as a parameter. When dealing with user input, it is better to use 'parameter' whenever possible. @@ -486,8 +545,7 @@ int16DecLiteral = SqlSection . BSB.int16Dec -{- | - Constructs a 'RawSql' from an 'Int.Int32' value. The integral value is +{- | Constructs a 'RawSql' from an 'Int.Int32' value. The integral value is included directly in the SQL string, not passed as a parameter. When dealing with user input, it is better to use 'parameter' whenever possible. @@ -497,8 +555,7 @@ int32DecLiteral = SqlSection . BSB.int32Dec -{- | - Constructs a 'RawSql' from an 'Int.Int64' value. The integral value is +{- | Constructs a 'RawSql' from an 'Int.Int64' value. The integral value is included directly in the SQL string, not passed as a parameter. When dealing with user input, it is better to use 'parameter' whenever possible. @@ -508,8 +565,7 @@ int64DecLiteral = SqlSection . BSB.int64Dec -{- | - Constructs a 'RawSql' from an 'Int' value. The integral value is included +{- | Constructs a 'RawSql' from an 'Int' value. The integral value is included directly in the SQL string, not passed as a parameter. When dealing with user input, it is better to use 'parameter' whenever possible. @@ -519,8 +575,14 @@ intDecLiteral = SqlSection . BSB.intDec -{- | - Constructs a 'RawSql' by putting parentheses around an arbitrary expression. +{- | Constructs a 'RawSql' representing the SQL @NULL@ literal. + +@since 1.1.0.0 +-} +nullLiteral :: RawSql +nullLiteral = fromString "NULL" + +{- | Constructs a 'RawSql' by putting parentheses around an arbitrary expression. The result is returned as a 'RawSql'. It is up to the caller to decide whether it should be wrapped in a more-specific expression type. diff --git a/src/Orville/PostgreSQL/Raw/SqlValue.hs b/src/Orville/PostgreSQL/Raw/SqlValue.hs --- a/src/Orville/PostgreSQL/Raw/SqlValue.hs +++ b/src/Orville/PostgreSQL/Raw/SqlValue.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + {- | Copyright : Flipstone Technology Partners 2023 @@ -11,6 +13,7 @@ -} module Orville.PostgreSQL.Raw.SqlValue ( SqlValue + , foldSqlValue , isSqlNull , sqlNull , fromInt8 @@ -45,9 +48,9 @@ , toUTCTime , fromLocalTime , toLocalTime + , fromRow , fromRawBytes , fromRawBytesNullable - , toPgValue ) where @@ -58,6 +61,7 @@ import qualified Data.ByteString.Builder as BSB import qualified Data.ByteString.Lazy as LBS import Data.Int (Int16, Int32, Int64, Int8) +import qualified Data.List.NonEmpty as NE import qualified Data.Text as T import qualified Data.Text.Encoding as TextEnc import qualified Data.Time as Time @@ -68,8 +72,7 @@ import qualified Orville.PostgreSQL.Raw.PgTextFormatValue as PgTextFormatValue import qualified Orville.PostgreSQL.Raw.PgTime as PgTime -{- | - 'SqlValue' represents a value that is in encoded format for use with LibPQ. +{- | 'SqlValue' represents a value that is in encoded format for use with LibPQ. It is used both for values passed to LibPQ and values parsed from LibPQ. The conversion functions in "Orville.PostgreSQL.Raw.SqlValue" can be used to convert to and from the value. @@ -78,22 +81,46 @@ -} data SqlValue = SqlValue PgTextFormatValue + | SqlRowValue (NE.NonEmpty SqlValue) | SqlNull - deriving (Eq) + deriving + ( -- | @since 1.0.0.0 + Eq + ) -{- | - Checks whether the 'SqlValue' represents a SQL NULL value in the database. +{- | Covert a 'SqlValue' to an 'r', handling a plain value, a row, and a null independently. @since 1.0.0.0 -} +foldSqlValue :: + (PgTextFormatValue -> r) -> + (NE.NonEmpty r -> r) -> + r -> + SqlValue -> + r +foldSqlValue onValue onRow onNull = go + where + go sqlValue = + case sqlValue of + SqlValue value -> + onValue value + SqlRowValue values -> + onRow $ fmap go values + SqlNull -> + onNull + +{- | Checks whether the 'SqlValue' represents a SQL NULL value in the database. + +@since 1.0.0.0 +-} isSqlNull :: SqlValue -> Bool isSqlNull sqlValue = case sqlValue of SqlValue _ -> False + SqlRowValue _ -> False SqlNull -> True -{- | - A value of 'SqlValue' that will be interpreted as a SQL NULL value when +{- | A value of 'SqlValue' that will be interpreted as a SQL NULL value when passed to the database. @since 1.0.0.0 @@ -102,24 +129,7 @@ sqlNull = SqlNull -{- | - Converts a 'SqlValue' to its underlying raw bytes as it will be represented - when sent to the database. The output should be recognizable as similar to - values you would write in a query. If the value represents a SQL NULL value, - 'Nothing' is returned. - -@since 1.0.0.0 --} -toPgValue :: SqlValue -> Maybe PgTextFormatValue -toPgValue sqlValue = - case sqlValue of - SqlValue value -> - Just value - SqlNull -> - Nothing - -{- | - Creates a 'SqlValue' from a raw bytestring as if the bytes had been returned +{- | Creates a 'SqlValue' from a raw bytestring as if the bytes had been returned by the database. This function does not interpret the bytes in any way, but using decode functions on them might fail depending on whether the bytes can be parsed as the requested type. @@ -128,14 +138,17 @@ function. See 'fromRawBytesNullable' for how to represent a nullable raw value. + Warning: Will throw NULByteFoundError if there is a NULL byte. For arbitrary + binary data see: + https://www.postgresql.org/docs/current/datatype-binary.html#DATATYPE-BINARY-BYTEA-HEX-FORMAT + @since 1.0.0.0 -} fromRawBytes :: BS.ByteString -> SqlValue fromRawBytes = SqlValue . PgTextFormatValue.fromByteString -{- | - Creates a 'SqlValue' from a raw bytestring. If 'Nothing' is specified as the +{- | Creates a 'SqlValue' from a raw bytestring. If 'Nothing' is specified as the input parameter then the resulting 'SqlValue' will represent a NULL value in SQL. Otherwise, the bytes given are used in the same way as 'fromRawBytes'. @@ -145,8 +158,7 @@ fromRawBytesNullable = maybe sqlNull fromRawBytes -{- | - Encodes an 'Int8' value for use with the database. +{- | Encodes an 'Int8' value for use with the database. @since 1.0.0.0 -} @@ -154,8 +166,7 @@ fromInt8 = fromBSBuilderWithNoNULs BSB.int8Dec -{- | - Attempts to decode a 'SqlValue' as a Haskell 'Int8' value. If decoding fails, +{- | Attempts to decode a 'SqlValue' as a Haskell 'Int8' value. If decoding fails, 'Nothing' is returned. @since 1.0.0.0 @@ -164,8 +175,7 @@ toInt8 = toParsedValue (AttoB8.signed AttoB8.decimal) -{- | - Encodes an 'Int16' value for use with the database. +{- | Encodes an 'Int16' value for use with the database. @since 1.0.0.0 -} @@ -173,8 +183,7 @@ fromInt16 = fromBSBuilderWithNoNULs BSB.int16Dec -{- | - Attempts to decode a 'SqlValue' as a Haskell 'Int16' value. If decoding +{- | Attempts to decode a 'SqlValue' as a Haskell 'Int16' value. If decoding fails, 'Nothing' is returned. @since 1.0.0.0 @@ -183,8 +192,7 @@ toInt16 = toParsedValue (AttoB8.signed AttoB8.decimal) -{- | - Encodes an 'Int32' value for use with the database. +{- | Encodes an 'Int32' value for use with the database. @since 1.0.0.0 -} @@ -192,8 +200,7 @@ fromInt32 = fromBSBuilderWithNoNULs BSB.int32Dec -{- | - Attempts to decode a 'SqlValue' as a Haskell 'Int32' value. If decoding +{- | Attempts to decode a 'SqlValue' as a Haskell 'Int32' value. If decoding fails, 'Nothing' is returned. @since 1.0.0.0 @@ -202,8 +209,7 @@ toInt32 = toParsedValue (AttoB8.signed AttoB8.decimal) -{- | - Encodes an 'Int64' value for use with the database. +{- | Encodes an 'Int64' value for use with the database. @since 1.0.0.0 -} @@ -211,8 +217,7 @@ fromInt64 = fromBSBuilderWithNoNULs BSB.int64Dec -{- | - Attempts to decode a 'SqlValue' as a Haskell 'Int' value. If decoding fails, +{- | Attempts to decode a 'SqlValue' as a Haskell 'Int' value. If decoding fails, 'Nothing' is returned. @since 1.0.0.0 @@ -221,8 +226,7 @@ toInt64 = toParsedValue (AttoB8.signed AttoB8.decimal) -{- | - Encodes an 'Int' value for use with the database. +{- | Encodes an 'Int' value for use with the database. @since 1.0.0.0 -} @@ -230,8 +234,7 @@ fromInt = fromBSBuilderWithNoNULs BSB.intDec -{- | - Attempts to decode a 'SqlValue' as a Haskell 'Int' value. If decoding fails, +{- | Attempts to decode a 'SqlValue' as a Haskell 'Int' value. If decoding fails, 'Nothing' is returned. @since 1.0.0.0 @@ -240,8 +243,7 @@ toInt = toParsedValue (AttoB8.signed AttoB8.decimal) -{- | - Encodes a 'Word8' value for use with the database. +{- | Encodes a 'Word8' value for use with the database. @since 1.0.0.0 -} @@ -249,8 +251,7 @@ fromWord8 = fromBSBuilderWithNoNULs BSB.word8Dec -{- | - Attempts to decode a 'SqlValue' as a Haskell 'Word8' value. If decoding +{- | Attempts to decode a 'SqlValue' as a Haskell 'Word8' value. If decoding fails, 'Nothing' is returned. @since 1.0.0.0 @@ -259,8 +260,7 @@ toWord8 = toParsedValue (AttoB8.signed AttoB8.decimal) -{- | - Encodes a 'Word16' value for use with the database. +{- | Encodes a 'Word16' value for use with the database. @since 1.0.0.0 -} @@ -268,8 +268,7 @@ fromWord16 = fromBSBuilderWithNoNULs BSB.word16Dec -{- | - Attempts to decode a 'SqlValue' as a Haskell 'Word16' value. If decoding +{- | Attempts to decode a 'SqlValue' as a Haskell 'Word16' value. If decoding fails, 'Nothing' is returned. @since 1.0.0.0 @@ -278,8 +277,7 @@ toWord16 = toParsedValue (AttoB8.signed AttoB8.decimal) -{- | - Encodes a 'Word32' value for use with the database. +{- | Encodes a 'Word32' value for use with the database. @since 1.0.0.0 -} @@ -287,8 +285,7 @@ fromWord32 = fromBSBuilderWithNoNULs BSB.word32Dec -{- | - Attempts to decode a 'SqlValue' as a Haskell 'Word32' value. If decoding +{- | Attempts to decode a 'SqlValue' as a Haskell 'Word32' value. If decoding fails, 'Nothing' is returned. @since 1.0.0.0 @@ -297,8 +294,7 @@ toWord32 = toParsedValue (AttoB8.signed AttoB8.decimal) -{- | - Encodes a 'Word64' value for use with the database. +{- | Encodes a 'Word64' value for use with the database. @since 1.0.0.0 -} @@ -306,8 +302,7 @@ fromWord64 = fromBSBuilderWithNoNULs BSB.word64Dec -{- | - Attempts to decode a 'SqlValue' as a Haskell 'Word64' value. If decoding +{- | Attempts to decode a 'SqlValue' as a Haskell 'Word64' value. If decoding fails, 'Nothing' is returned. @since 1.0.0.0 @@ -316,8 +311,7 @@ toWord64 = toParsedValue (AttoB8.signed AttoB8.decimal) -{- | - Encodes a 'Word' value for use with the database. +{- | Encodes a 'Word' value for use with the database. @since 1.0.0.0 -} @@ -325,8 +319,7 @@ fromWord = fromBSBuilderWithNoNULs BSB.wordDec -{- | - Attempts to decode a 'SqlValue' as a Haskell 'Word' value. If decoding fails, +{- | Attempts to decode a 'SqlValue' as a Haskell 'Word' value. If decoding fails, 'Nothing' is returned. @since 1.0.0.0 @@ -335,8 +328,7 @@ toWord = toParsedValue (AttoB8.signed AttoB8.decimal) -{- | - Encodes a 'Double' value for use with the database. +{- | Encodes a 'Double' value for use with the database. @since 1.0.0.0 -} @@ -344,8 +336,7 @@ fromDouble = fromBSBuilderWithNoNULs BSB.doubleDec -{- | - Attempts to decode a 'SqlValue' as a Haskell 'Double' value. If decoding +{- | Attempts to decode a 'SqlValue' as a Haskell 'Double' value. If decoding fails, 'Nothing' is returned. @since 1.0.0.0 @@ -354,8 +345,7 @@ toDouble = toParsedValue (AttoB8.signed AttoB8.double) -{- | - Encodes a 'Bool' value for use with the database. +{- | Encodes a 'Bool' value for use with the database. @since 1.0.0.0 -} @@ -366,8 +356,7 @@ True -> BSB.char8 't' False -> BSB.char8 'f' -{- | - Attempts to decode a 'SqlValue' as a Haskell 'Bool' value. If decoding fails, +{- | Attempts to decode a 'SqlValue' as a Haskell 'Bool' value. If decoding fails, 'Nothing' is returned. @since 1.0.0.0 @@ -381,8 +370,7 @@ 'f' -> pure False _ -> fail "Invalid boolean character value" -{- | - Encodes a 'T.Text' value as UTF-8 so that it can be used with the database. +{- | Encodes a 'T.Text' value as UTF-8 so that it can be used with the database. @since 1.0.0.0 -} @@ -390,8 +378,7 @@ fromText = SqlValue . PgTextFormatValue.fromByteString . TextEnc.encodeUtf8 -{- | - Attempts to decode a 'SqlValue' as UTF-8 text. If the decoding fails, +{- | Attempts to decode a 'SqlValue' as UTF-8 text. If the decoding fails, 'Nothing' is returned. Note: This decoding _only_ fails if the bytes returned from the database @@ -406,8 +393,7 @@ Right t -> Right t Left err -> Left $ Exc.displayException err -{- | - Encodes a 'Time.Day' value as text in YYYY-MM-DD format so that it can be +{- | Encodes a 'Time.Day' value as text in YYYY-MM-DD format so that it can be used with the database. @since 1.0.0.0 @@ -416,8 +402,7 @@ fromDay = SqlValue . PgTextFormatValue.unsafeFromByteString . PgTime.dayToPostgreSQL -{- | - Attempts to decode a 'SqlValue' as into a 'Time.Day' value by parsing it +{- | Attempts to decode a 'SqlValue' as into a 'Time.Day' value by parsing it from YYYY-MM-DD format. If the decoding fails, 'Nothing' is returned. @since 1.0.0.0 @@ -426,8 +411,7 @@ toDay = toParsedValue PgTime.day -{- | - Encodes a 'Time.UTCTime' in ISO-8601 format for use with the database. +{- | Encodes a 'Time.UTCTime' in ISO-8601 format for use with the database. @since 1.0.0.0 -} @@ -437,8 +421,7 @@ . PgTextFormatValue.unsafeFromByteString . PgTime.utcTimeToPostgreSQL -{- | - Encodes a 'Time.LocalTime' in ISO-8601 format for use with the database. +{- | Encodes a 'Time.LocalTime' in ISO-8601 format for use with the database. @since 1.0.0.0 -} @@ -448,8 +431,7 @@ . PgTextFormatValue.unsafeFromByteString . PgTime.localTimeToPostgreSQL -{- | - Attempts to decode a 'SqlValue' as a 'Time.LocalTime' formatted in ISO-8601 +{- | Attempts to decode a 'SqlValue' as a 'Time.LocalTime' formatted in ISO-8601 format in the default locale. If the decoding fails, 'Nothing' is returned. @since 1.0.0.0 @@ -458,8 +440,7 @@ toLocalTime = toParsedValue PgTime.localTime -{- | - Attempts to decode a 'SqlValue' as a 'Time.UTCTime' formatted in ISO-8601 +{- | Attempts to decode a 'SqlValue' as a 'Time.UTCTime' formatted in ISO-8601 format with time zone. If the decoding fails, 'Nothing' is returned. @since 1.0.0.0 @@ -468,8 +449,15 @@ toUTCTime = toParsedValue PgTime.utcTime -{- | - An internal helper function that constructs a 'SqlValue' via a bytestring +{- | Construct a 'SqlValue' representing a Postgres row value comprising the values in the list. + +@since 1.1.0.0 +-} +fromRow :: NE.NonEmpty SqlValue -> SqlValue +fromRow = + SqlRowValue + +{- | An internal helper function that constructs a 'SqlValue' via a bytestring 'BS8.Builder'. @since 1.0.0.0 @@ -482,8 +470,7 @@ . BSB.toLazyByteString . builder -{- | - An internal helper function that parses 'SqlValue' via an Attoparsec parser. +{- | An internal helper function that parses 'SqlValue' via an Attoparsec parser. @since 1.0.0.0 -} @@ -495,8 +482,7 @@ toParsedValue parser = toBytesValue (AttoBS.parseOnly parser) -{- | - An internal helper function that parses the bytes from a 'SqlValue' with the +{- | An internal helper function that parses the bytes from a 'SqlValue' with the given parsing function. If the 'SqlValue' is NULL, this function returns an error an a 'Left' value. If the parsing function fails (by returning 'Left'), the error it returns in returned by this function. @@ -514,6 +500,8 @@ case sqlValue of SqlNull -> Left "Unexpected SQL NULL value" + SqlRowValue _ -> + Left "Unexpected SQL row value" SqlValue bytes -> byteParser (PgTextFormatValue.toByteString bytes) diff --git a/src/Orville/PostgreSQL/Schema.hs b/src/Orville/PostgreSQL/Schema.hs --- a/src/Orville/PostgreSQL/Schema.hs +++ b/src/Orville/PostgreSQL/Schema.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -Wno-missing-import-lists #-} {- | -Copyright : Flipstone Technology Partners 2023 +Copyright : Flipstone Technology Partners 2023-2024 License : MIT Stability : Stable @@ -19,10 +19,18 @@ , module Orville.PostgreSQL.Schema.PrimaryKey , module Orville.PostgreSQL.Schema.IndexDefinition , module Orville.PostgreSQL.Schema.ConstraintDefinition + , module Orville.PostgreSQL.Schema.TriggerDefinition -- * Defining Sequences , module Orville.PostgreSQL.Schema.SequenceDefinition , module Orville.PostgreSQL.Schema.SequenceIdentifier + + -- * Definining Functions + , module Orville.PostgreSQL.Schema.FunctionDefinition + , module Orville.PostgreSQL.Schema.FunctionIdentifier + + -- * Using PostgreSQL Extensions + , module Orville.PostgreSQL.Schema.ExtensionIdentifier ) where @@ -30,9 +38,13 @@ -- appear in the generated haddock documentation. import Orville.PostgreSQL.Schema.ConstraintDefinition +import Orville.PostgreSQL.Schema.ExtensionIdentifier +import Orville.PostgreSQL.Schema.FunctionDefinition +import Orville.PostgreSQL.Schema.FunctionIdentifier import Orville.PostgreSQL.Schema.IndexDefinition import Orville.PostgreSQL.Schema.PrimaryKey import Orville.PostgreSQL.Schema.SequenceDefinition import Orville.PostgreSQL.Schema.SequenceIdentifier import Orville.PostgreSQL.Schema.TableDefinition import Orville.PostgreSQL.Schema.TableIdentifier +import Orville.PostgreSQL.Schema.TriggerDefinition diff --git a/src/Orville/PostgreSQL/Schema/ConstraintDefinition.hs b/src/Orville/PostgreSQL/Schema/ConstraintDefinition.hs --- a/src/Orville/PostgreSQL/Schema/ConstraintDefinition.hs +++ b/src/Orville/PostgreSQL/Schema/ConstraintDefinition.hs @@ -38,8 +38,7 @@ import qualified Orville.PostgreSQL.Internal.FieldName as FieldName import qualified Orville.PostgreSQL.Schema.TableIdentifier as TableIdentifier -{- | - A collection of constraints to be added to a table. This collection is +{- | A collection of constraints to be added to a table. This collection is indexed by 'ConstraintMigrationKey'. If multiple constraints with the same 'ConstraintMigrationKey' are added, the most recently-added one will be kept and the previous one dropped. @@ -48,18 +47,21 @@ -} newtype TableConstraints = TableConstraints (Map.Map ConstraintMigrationKey ConstraintDefinition) - deriving (Semigroup, Monoid) + deriving + ( -- | @since 1.0.0.0 + Semigroup + , -- | @since 1.0.0.0 + Monoid + ) -{- | - Constructs an empty 'TableConstraints'. +{- | Constructs an empty 'TableConstraints'. @since 1.0.0.0 -} emptyTableConstraints :: TableConstraints emptyTableConstraints = TableConstraints Map.empty -{- | - Adds a 'ConstraintDefinition' to an existing 'TableConstraints'. If a +{- | Adds a 'ConstraintDefinition' to an existing 'TableConstraints'. If a constraint already exists with the same 'ConstraintMigrationKey', it is replaced with the new constraint. @@ -73,8 +75,7 @@ constraint constraintMap -{- | - Gets the list of 'ConstraintDefinition's that have been added to the +{- | Gets the list of 'ConstraintDefinition's that have been added to the 'TableConstraints'. @since 1.0.0.0 @@ -83,8 +84,7 @@ tableConstraintKeys (TableConstraints constraints) = Map.keysSet constraints -{- | - Gets the list of 'ConstraintDefinition's that have been added to the +{- | Gets the list of 'ConstraintDefinition's that have been added to the 'TableConstraints'. @since 1.0.0.0 @@ -93,8 +93,7 @@ tableConstraintDefinitions (TableConstraints constraints) = Map.elems constraints -{- | - Defines a constraint that can be added to a +{- | Defines a constraint that can be added to a 'Orville.PostgreSQL.TableDefinition'. Use one of the constructor functions below (such as 'uniqueConstraint') to construct the constraint definition you wish to have and then use 'Orville.PostgreSQL.addTableConstraints' to add @@ -104,12 +103,11 @@ @since 1.0.0.0 -} data ConstraintDefinition = ConstraintDefinition - { _constraintSqlExpr :: Expr.TableConstraint - , _constraintMigrationKey :: ConstraintMigrationKey + { i_constraintSqlExpr :: Expr.TableConstraint + , i_constraintMigrationKey :: ConstraintMigrationKey } -{- | - The key used by Orville to determine whether a constraint should be added to +{- | The key used by Orville to determine whether a constraint should be added to a table when performing auto-migrations. For most use cases, the constructor functions that build a 'ConstraintDefinition' will create this automatically for you. @@ -124,10 +122,16 @@ , constraintKeyForeignKeyOnUpdateAction :: Maybe ForeignKeyAction , constraintKeyForeignKeyOnDeleteAction :: Maybe ForeignKeyAction } - deriving (Eq, Ord, Show) + deriving + ( -- | @since 1.0.0.0 + Eq + , -- | @since 1.0.0.0 + Ord + , -- | @since 1.0.0.0 + Show + ) -{- | - The kind of constraint that is described by a 'ConstraintMigrationKey' (e.g. +{- | The kind of constraint that is described by a 'ConstraintMigrationKey' (e.g. unique, foreign key). @since 1.0.0.0 @@ -135,26 +139,30 @@ data ConstraintKeyType = UniqueConstraint | ForeignKeyConstraint - deriving (Eq, Ord, Show) + deriving + ( -- | @since 1.0.0.0 + Eq + , -- | @since 1.0.0.0 + Ord + , -- | @since 1.0.0.0 + Show + ) -{- | - Gets the 'ConstraintMigrationKey' for the 'ConstraintDefinition'. +{- | Gets the 'ConstraintMigrationKey' for the 'ConstraintDefinition'. @since 1.0.0.0 -} constraintMigrationKey :: ConstraintDefinition -> ConstraintMigrationKey -constraintMigrationKey = _constraintMigrationKey +constraintMigrationKey = i_constraintMigrationKey -{- | - Gets the SQL expression that will be used to add the constraint to the table. +{- | Gets the SQL expression that will be used to add the constraint to the table. @since 1.0.0.0 -} constraintSqlExpr :: ConstraintDefinition -> Expr.TableConstraint -constraintSqlExpr = _constraintSqlExpr +constraintSqlExpr = i_constraintSqlExpr -{- | - Constructs a 'ConstraintDefinition' for a @UNIQUE@ constraint on the given +{- | Constructs a 'ConstraintDefinition' for a @UNIQUE@ constraint on the given columns. @since 1.0.0.0 @@ -176,12 +184,11 @@ } in ConstraintDefinition - { _constraintSqlExpr = expr - , _constraintMigrationKey = migrationKey + { i_constraintSqlExpr = expr + , i_constraintMigrationKey = migrationKey } -{- | - A 'ForeignReference' represents one part of a foreign key. The entire foreign +{- | A 'ForeignReference' represents one part of a foreign key. The entire foreign key may comprise multiple columns. The 'ForeignReference' defines a single column in the key and which column it references in the foreign table. @@ -192,8 +199,7 @@ , foreignFieldName :: FieldName.FieldName } -{- | - Constructs a 'ForeignReference'. +{- | Constructs a 'ForeignReference'. @since 1.0.0.0 -} @@ -209,8 +215,7 @@ , foreignFieldName = foreignName } -{- | - Defines the options for a foreign key constraint. To construct +{- | Defines the options for a foreign key constraint. To construct 'ForeignKeyOptions', perform a record update on 'defaultForeignKeyOptions'. @since 1.0.0.0 @@ -222,8 +227,7 @@ -- ^ The @ON DELETE@ action for the foreign key. } -{- | - The default 'ForeignKeyOptions', containing 'NoAction' for both +{- | The default 'ForeignKeyOptions', containing 'NoAction' for both 'foreignKeyOptionsOnUpdate' and 'foreignKeyOptionsOnDelete'. @since 1.0.0.0 @@ -235,8 +239,7 @@ , foreignKeyOptionsOnDelete = NoAction } -{- | - The actions that can be set on 'ForeignKeyOptions'. +{- | The actions that can be set on 'ForeignKeyOptions'. @since 1.0.0.0 -} @@ -246,7 +249,14 @@ | Cascade | SetNull | SetDefault - deriving (Show, Eq, Ord) + deriving + ( -- | @since 1.0.0.0 + Show + , -- | @since 1.0.0.0 + Eq + , -- | @since 1.0.0.0 + Ord + ) foreignKeyActionToExpr :: ForeignKeyAction -> Maybe Expr.ForeignKeyActionExpr foreignKeyActionToExpr action = case action of @@ -256,8 +266,7 @@ SetNull -> Just Expr.setNullExpr SetDefault -> Just Expr.setDefaultExpr -{- | - Builds a 'ConstraintDefinition' for a @FOREIGN KEY@ constraint. +{- | Builds a 'ConstraintDefinition' for a @FOREIGN KEY@ constraint. @since 1.0.0.0 -} @@ -270,8 +279,7 @@ foreignKeyConstraint foreignTableId foreignReferences = foreignKeyConstraintWithOptions foreignTableId foreignReferences defaultForeignKeyOptions -{- | - Builds a 'ConstraintDefinition' for a @FOREIGN KEY@ constraint, with +{- | Builds a 'ConstraintDefinition' for a @FOREIGN KEY@ constraint, with ON UPDATE and ON DELETE actions. @since 1.0.0.0 @@ -318,6 +326,6 @@ } in ConstraintDefinition - { _constraintSqlExpr = expr - , _constraintMigrationKey = migrationKey + { i_constraintSqlExpr = expr + , i_constraintMigrationKey = migrationKey } diff --git a/src/Orville/PostgreSQL/Schema/ExtensionIdentifier.hs b/src/Orville/PostgreSQL/Schema/ExtensionIdentifier.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Schema/ExtensionIdentifier.hs @@ -0,0 +1,61 @@ +{- | +Copyright : Flipstone Technology Partners 2024 +License : MIT +Stability : Stable + +@since 1.1.0.0 +-} +module Orville.PostgreSQL.Schema.ExtensionIdentifier + ( ExtensionIdentifier + , nameToExtensionId + , extensionIdName + , extensionIdToString + ) +where + +import qualified Orville.PostgreSQL.Expr as Expr + +{- | An identifier used by Orville to identify a particular extension + +@since 1.1.0.0 +-} +newtype ExtensionIdentifier = ExtensionIdentifier + { i_extensionName :: String + } + deriving + ( -- | @since 1.1.0.0 + Eq + , -- | @since 1.1.0.0 + Ord + , -- | @since 1.1.0.0 + Show + ) + +{- | Constructs a 'ExtensionIdentifier' with the given extension name string. + +@since 1.1.0.0 +-} +nameToExtensionId :: String -> ExtensionIdentifier +nameToExtensionId name = + ExtensionIdentifier + { i_extensionName = name + } + +{- | Returns the 'Expr.ExtensionName' that should be used to refer to the extension in SQL queries. + +@since 1.1.0.0 +-} +extensionIdName :: ExtensionIdentifier -> Expr.ExtensionName +extensionIdName = + Expr.extensionName . extensionIdToString + +{- | Converts a 'ExtensionIdentifier' to a 'String' for descriptive purposes. The + name will be qualified if a schema name has been set for the identifier. + + Note: You should not use this function for building SQL expressions. Use + 'extensionIdName' instead for that. + +@since 1.1.0.0 +-} +extensionIdToString :: ExtensionIdentifier -> String +extensionIdToString = i_extensionName diff --git a/src/Orville/PostgreSQL/Schema/FunctionDefinition.hs b/src/Orville/PostgreSQL/Schema/FunctionDefinition.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Schema/FunctionDefinition.hs @@ -0,0 +1,115 @@ +{- | +Copyright : Flipstone Technology Partners 2024 +License : MIT +Stability : Stable + +@since 1.1.0.0 +-} +module Orville.PostgreSQL.Schema.FunctionDefinition + ( FunctionDefinition + , setFunctionSchema + , functionIdentifier + , functionName + , functionSource + , mkTriggerFunction + , mkCreateFunctionExpr + ) where + +import qualified Orville.PostgreSQL.Expr as Expr +import Orville.PostgreSQL.Schema.FunctionIdentifier (FunctionIdentifier, functionIdQualifiedName, setFunctionIdSchema, unqualifiedNameToFunctionId) + +{- | Contains the definition of a PostgreSQL function for Orville to use when creating + the function. Currently only functionality for creating trigger functions for use + with 'Orville.PostgreSQL.Schema.TriggerDefinition' is supported. You can create a + 'FunctionDefintion' for a trigger via 'mkTriggerFunction'. + + When a 'FunctionDefinition' is included in a schema item list for auto-migration + the function will be created if it does not exist, or recreated if the source + code for the function does not match what is found in the database catalog. + +@since 1.1.0.0 +-} +data FunctionDefinition = FunctionDefinition + { i_functionIdentifier :: FunctionIdentifier + , i_functionReturnType :: Expr.ReturnType + , i_functionLanguage :: Expr.LanguageName + , i_functionSource :: String + } + +{- | Sets the function's schema to the name in the given 'String', which will be + treated as a SQL identifier. If a function has a schema name set, it will be + included as a qualifier on the function name for all queries involving the + function. + +@since 1.1.0.0 +-} +setFunctionSchema :: + String -> + FunctionDefinition -> + FunctionDefinition +setFunctionSchema schemaName functionDef = + functionDef + { i_functionIdentifier = setFunctionIdSchema schemaName (i_functionIdentifier functionDef) + } + +{- | Retrieves the 'FunctionIdentifier' for this function, which is set by the + name provided to 'mkTriggerFunction' and any calls made to + 'setFunctionSchema' thereafter. +@since 1.1.0.0 +-} +functionIdentifier :: FunctionDefinition -> FunctionIdentifier +functionIdentifier = + i_functionIdentifier + +{- | Retrieves the 'Expr.Qualified' 'Expr.FunctionName' for the function that + should be used to build SQL expressions involving it. + +@since 1.1.0.0 +-} +functionName :: FunctionDefinition -> Expr.QualifiedOrUnqualified Expr.FunctionName +functionName = + functionIdQualifiedName . i_functionIdentifier + +{- | Retrieves the source that was passed to 'mkTriggerFunction' when the + 'FunctionDefinition' was created. + +@since 1.1.0.0 +-} +functionSource :: FunctionDefinition -> String +functionSource = + i_functionSource + +{- | Constructs a 'FunctionDefinition' that will create a PostgreSQL function + with a return type of @trigger@ using the specified lanugage and function + body. +@since 1.1.0.0 +-} +mkTriggerFunction :: + String -> + Expr.LanguageName -> + String -> + FunctionDefinition +mkTriggerFunction name language source = + FunctionDefinition + { i_functionIdentifier = unqualifiedNameToFunctionId name + , i_functionReturnType = Expr.returnTypeTrigger + , i_functionLanguage = language + , i_functionSource = source + } + +{- | Builds a 'Expr.CreateFunctionExpr' that will create a SQL function matching + the given 'FunctionDefinition' when it is executed. + +@since 1.1.0.0 +-} +mkCreateFunctionExpr :: + FunctionDefinition -> + Maybe Expr.OrReplace -> + Expr.CreateFunctionExpr +mkCreateFunctionExpr functionDef maybeOrReplace = + Expr.createFunction + maybeOrReplace + (functionName functionDef) + (Expr.returns (i_functionReturnType functionDef)) + (Expr.language (i_functionLanguage functionDef)) + (Expr.asDefinition (i_functionSource functionDef)) diff --git a/src/Orville/PostgreSQL/Schema/FunctionIdentifier.hs b/src/Orville/PostgreSQL/Schema/FunctionIdentifier.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Schema/FunctionIdentifier.hs @@ -0,0 +1,128 @@ +{- | +Copyright : Flipstone Technology Partners 2024 +License : MIT +Stability : Stable + +@since 1.1.0.0 +-} +module Orville.PostgreSQL.Schema.FunctionIdentifier + ( FunctionIdentifier + , unqualifiedNameToFunctionId + , setFunctionIdSchema + , functionIdQualifiedName + , functionIdUnqualifiedName + , functionIdSchemaName + , functionIdToString + , functionIdUnqualifiedNameString + , functionIdSchemaNameString + ) +where + +import qualified Orville.PostgreSQL.Expr as Expr + +{- | An identifier used by Orville to identify a particular function in a particular + schema. + +@since 1.1.0.0 +-} +data FunctionIdentifier = FunctionIdentifier + { i_functionIdName :: String + , i_functionIdSchema :: Maybe String + } + deriving + ( -- | @since 1.1.0.0 + Eq + , -- | @since 1.1.0.0 + Ord + , -- | @since 1.1.0.0 + Show + ) + +{- | Constructs a 'FunctionIdentifier' where the function's name will not be qualified + by a particular schema. + +@since 1.1.0.0 +-} +unqualifiedNameToFunctionId :: String -> FunctionIdentifier +unqualifiedNameToFunctionId name = + FunctionIdentifier + { i_functionIdName = name + , i_functionIdSchema = Nothing + } + +{- | Sets the schema of the 'FunctionIdentifier'. Wherever applicable, references to + the function will be qualified by the given schema name. + +@since 1.1.0.0 +-} +setFunctionIdSchema :: String -> FunctionIdentifier -> FunctionIdentifier +setFunctionIdSchema schema functionId = + functionId + { i_functionIdSchema = Just schema + } + +{- | Returns the 'Expr.QualifiedOrUnqualified Expr.FunctionName' that should be used to refer to the + function in SQL queries where a potentially qualified reference is appropriate. + +@since 1.1.0.0 +-} +functionIdQualifiedName :: FunctionIdentifier -> Expr.QualifiedOrUnqualified Expr.FunctionName +functionIdQualifiedName functionId = + case functionIdSchemaName functionId of + Nothing -> + Expr.unqualified (functionIdUnqualifiedName functionId) + Just schemaName -> + Expr.untrackQualified $ + Expr.qualifyFunction + schemaName + (functionIdUnqualifiedName functionId) + +{- | Returns the unqualified 'Expr.FunctionName' that should be used to refer to the + function in SQL queries where an unqualified reference is appropriate. + +@since 1.1.0.0 +-} +functionIdUnqualifiedName :: FunctionIdentifier -> Expr.FunctionName +functionIdUnqualifiedName = + Expr.functionName . i_functionIdName + +{- | Returns the 'Expr.SchemaName' (if any) that should be used to qualify + references to the function in SQL queries. + +@since 1.1.0.0 +-} +functionIdSchemaName :: FunctionIdentifier -> Maybe Expr.SchemaName +functionIdSchemaName = + fmap Expr.schemaName . i_functionIdSchema + +{- | Retrieves the unqualified name of the function as a 'String'. + +@since 1.1.0.0 +-} +functionIdUnqualifiedNameString :: FunctionIdentifier -> String +functionIdUnqualifiedNameString = + i_functionIdName + +{- | Retrieves the schema name of the function as a 'String'. + +@since 1.1.0.0 +-} +functionIdSchemaNameString :: FunctionIdentifier -> Maybe String +functionIdSchemaNameString = + i_functionIdSchema + +{- | Converts a 'FunctionIdentifier' to a 'String' for descriptive purposes. The + name will be qualified if a schema name has been set for the identifier. + + Note: You should not use this function for building SQL expressions. Use + 'functionIdQualifiedName' instead for that. + +@since 1.1.0.0 +-} +functionIdToString :: FunctionIdentifier -> String +functionIdToString functionId = + case i_functionIdSchema functionId of + Nothing -> + i_functionIdName functionId + Just schema -> + schema <> "." <> i_functionIdName functionId diff --git a/src/Orville/PostgreSQL/Schema/IndexDefinition.hs b/src/Orville/PostgreSQL/Schema/IndexDefinition.hs --- a/src/Orville/PostgreSQL/Schema/IndexDefinition.hs +++ b/src/Orville/PostgreSQL/Schema/IndexDefinition.hs @@ -18,6 +18,10 @@ , Expr.IndexUniqueness (UniqueIndex, NonUniqueIndex) , IndexDefinition.indexCreateExpr , IndexDefinition.IndexCreationStrategy (Transactional, Concurrent) + , IndexDefinition.IndexMigrationKey (AttributeBasedIndexKey, NamedIndexKey) + , IndexDefinition.AttributeBasedIndexMigrationKey (AttributeBasedIndexMigrationKey, indexKeyUniqueness, indexKeyColumns) + , IndexDefinition.NamedIndexMigrationKey + , IndexDefinition.indexMigrationKey ) where diff --git a/src/Orville/PostgreSQL/Schema/PrimaryKey.hs b/src/Orville/PostgreSQL/Schema/PrimaryKey.hs --- a/src/Orville/PostgreSQL/Schema/PrimaryKey.hs +++ b/src/Orville/PostgreSQL/Schema/PrimaryKey.hs @@ -2,7 +2,7 @@ {-# LANGUAGE RankNTypes #-} {- | -Copyright : Flipstone Technology Partners 2023 +Copyright : Flipstone Technology Partners 2023-2024 License : MIT Stability : Stable @@ -29,11 +29,10 @@ import qualified Orville.PostgreSQL.Expr as Expr import qualified Orville.PostgreSQL.Internal.Extra.NonEmpty as ExtraNonEmpty -import Orville.PostgreSQL.Marshall.FieldDefinition (FieldDefinition, FieldName, NotNull, fieldColumnName, fieldEquals, fieldIn, fieldName, fieldNameToString, fieldValueToSqlValue) +import Orville.PostgreSQL.Marshall.FieldDefinition (FieldDefinition, FieldName, NotNull, fieldEquals, fieldIn, fieldName, fieldNameToColumnName, fieldNameToString, fieldValueToSqlValue) import qualified Orville.PostgreSQL.Raw.SqlValue as SqlValue -{- | - A Haskell description of the 'FieldDefinition's that make up the primary +{- | A Haskell description of the 'FieldDefinition's that make up the primary key of a SQL table. This type supports composite primary keys as well as singular ones. @@ -42,8 +41,7 @@ data PrimaryKey key = PrimaryKey (PrimaryKeyPart key) [PrimaryKeyPart key] -{- | - A 'PrimaryKeyPart' describes one field of a composite primary key. Values +{- | A 'PrimaryKeyPart' describes one field of a composite primary key. Values are built using 'primaryKeyPart' and then used with 'compositePrimaryKey' to build a 'PrimaryKey'. @@ -52,8 +50,7 @@ data PrimaryKeyPart key = forall part. PrimaryKeyPart (key -> part) (FieldDefinition NotNull part) -{- | - 'primaryKeyDescription' builds a user-readable representation of the +{- | 'primaryKeyDescription' builds a user-readable representation of the primary key for use in error messages and such. It is a comma-delimited list of the names of the fields that make up the primary key. @@ -66,8 +63,7 @@ . toList . primaryKeyFieldNames -{- | - Retrieves the names of the fields that are part of the primary key. +{- | Retrieves the names of the fields that are part of the primary key. @since 1.0.0.0 -} @@ -75,13 +71,12 @@ primaryKeyFieldNames = let partName :: (part -> key) -> FieldDefinition NotNull a -> FieldName - partName _ field = - fieldName field + partName _ = + fieldName in mapPrimaryKeyParts partName -{- | - 'primaryKeyToSql' converts a Haskell value for a primary key into the +{- | 'primaryKeyToSql' converts a Haskell value for a primary key into the (possibly multiple) SQL values that represent the primary key in the database. @@ -91,8 +86,7 @@ primaryKeyToSql keyDef key = mapPrimaryKeyParts (partSqlValue key) keyDef -{- | - 'partSqlValue' is an internal helper function that builds the +{- | 'partSqlValue' is an internal helper function that builds the 'SqlValue.SqlValue' for one part of a (possible composite) primary key. @since 1.0.0.0 @@ -101,8 +95,7 @@ partSqlValue key getPart partField = fieldValueToSqlValue partField (getPart key) -{- | - 'primaryKey' constructs a single-field primary key from the 'FieldDefinition' +{- | 'primaryKey' constructs a single-field primary key from the 'FieldDefinition' that corresponds to the primary key's column. This is generally used while building a 'Orville.PostgreSQL.TableDefinition'. @@ -112,8 +105,7 @@ primaryKey fieldDef = PrimaryKey (PrimaryKeyPart id fieldDef) [] -{- | - 'compositePrimaryKey' constructs a multi-field primary key from the given +{- | 'compositePrimaryKey' constructs a multi-field primary key from the given parts, each of which corresponds to one field in the primary key. You should use this while building a 'Orville.PostgreSQL.TableDefinition' for a table that you want to have a multi-column primary key. See 'primaryKeyPart' for @@ -130,8 +122,7 @@ compositePrimaryKey = PrimaryKey -{- | - 'primaryKeyPart' constructs a building block for a composite primary key +{- | 'primaryKeyPart' constructs a building block for a composite primary key based on a 'FieldDefinition' and an accessor function to extract the value for that field from the Haskell @key@ type that represents the overall composite key. 'PrimaryKeyPart' values built using this function are usually then @@ -146,8 +137,7 @@ primaryKeyPart = PrimaryKeyPart -{- | - 'mapPrimaryKeyParts' provides a way to access the innards of a 'PrimaryKey' +{- | 'mapPrimaryKeyParts' provides a way to access the innards of a 'PrimaryKey' definition to extract information. The given function will be called on each part of the primary key in order and the list of results is returned. Note that single-field and multi-field primary keys are treated the same by @@ -171,8 +161,7 @@ in fmap doPart (first :| rest) -{- | - Builds a 'Expr.PrimaryKeyExpr' that is suitable to be used when creating +{- | Builds a 'Expr.PrimaryKeyExpr' that is suitable to be used when creating a table to define the primary key on the table. @since 1.0.0.0 @@ -181,12 +170,11 @@ mkPrimaryKeyExpr keyDef = let names = - mapPrimaryKeyParts (\_ field -> fieldColumnName field) keyDef + mapPrimaryKeyParts (\_ field -> fieldNameToColumnName $ fieldName field) keyDef in Expr.primaryKeyExpr names -{- | - 'primaryKeyEquals' builds a 'Expr.BooleanExpr' that will match the row where +{- | 'primaryKeyEquals' builds a 'Expr.BooleanExpr' that will match the row where the primary key is equal to the given value. For single-field primary keys, this is equivalent to 'fieldEquals', but 'primaryKeyEquals' also handles composite primary keys. @@ -199,8 +187,7 @@ Expr.andExpr (mapPrimaryKeyParts (partEquals key) keyDef) -{- | - 'primaryKeyIn' builds a 'Expr.BooleanExpr' that will match rows where the +{- | 'primaryKeyIn' builds a 'Expr.BooleanExpr' that will match rows where the primary key is contained in the given list. For single-field primary keys, this is equivalent to 'fieldIn', but 'primaryKeyIn' also handles composite primary keys. @@ -217,8 +204,7 @@ Expr.orExpr (fmap (primaryKeyEquals keyDef) keys) -{- | - INTERNAL: builds the where condition for a single part of the key +{- | INTERNAL: builds the where condition for a single part of the key @since 1.0.0.0 -} diff --git a/src/Orville/PostgreSQL/Schema/SequenceDefinition.hs b/src/Orville/PostgreSQL/Schema/SequenceDefinition.hs --- a/src/Orville/PostgreSQL/Schema/SequenceDefinition.hs +++ b/src/Orville/PostgreSQL/Schema/SequenceDefinition.hs @@ -32,8 +32,7 @@ import qualified Orville.PostgreSQL.Expr as Expr import Orville.PostgreSQL.Schema.SequenceIdentifier (SequenceIdentifier, sequenceIdQualifiedName, setSequenceIdSchema, unqualifiedNameToSequenceId) -{- | - Contains the definition of a SQL sequence for Orville to use when creating +{- | Contains the definition of a SQL sequence for Orville to use when creating the sequence and fetching values from it. You can create a 'SequenceDefinition' with default values via 'mkSequenceDefinition' and then use the various set functions that are provided if you need to set specific @@ -50,10 +49,14 @@ , i_sequenceCache :: Int64 , i_sequenceCycle :: Bool } - deriving (Eq, Show) + deriving + ( -- | @since 1.0.0.0 + Eq + , -- | @since 1.0.0.0 + Show + ) -{- | - Constructs an ascending 'SequenceDefinition' with increment 1 and cache +{- | Constructs an ascending 'SequenceDefinition' with increment 1 and cache 1 that does not cycle. The sequence will start at 1 and count to the largest 'Int64' value. @@ -71,8 +74,7 @@ , i_sequenceCycle = False } -{- | - Sets the sequence's schema to the name in the given 'String', which will be +{- | Sets the sequence's schema to the name in the given 'String', which will be treated as a SQL identifier. If a sequence has a schema name set, it will be included as a qualifier on the sequence name for all queries involving the sequence. @@ -88,8 +90,7 @@ { i_sequenceIdentifier = setSequenceIdSchema schemaName (i_sequenceIdentifier sequenceDef) } -{- | - Retrieves the 'SequenceIdentifier' for this sequence, which is set by the +{- | Retrieves the 'SequenceIdentifier' for this sequence, which is set by the name provided to 'mkSequenceDefinition' and any calls made to 'setSequenceSchema' thereafter. @@ -98,26 +99,23 @@ sequenceIdentifier :: SequenceDefinition -> SequenceIdentifier sequenceIdentifier = i_sequenceIdentifier -{- | - Retrieves the 'Expr.Qualified' 'Expr.SequenceName' for the sequence that +{- | Retrieves the 'Expr.Qualified' 'Expr.SequenceName' for the sequence that should be used to build SQL expressions involving it. @since 1.0.0.0 -} -sequenceName :: SequenceDefinition -> Expr.Qualified Expr.SequenceName +sequenceName :: SequenceDefinition -> Expr.QualifiedOrUnqualified Expr.SequenceName sequenceName = sequenceIdQualifiedName . i_sequenceIdentifier -{- | - Retrieves the increment value for the sequence. +{- | Retrieves the increment value for the sequence. @since 1.0.0.0 -} sequenceIncrement :: SequenceDefinition -> Int64 sequenceIncrement = i_sequenceIncrement -{- | - Sets the increment value for the sequence. The increment cannot be set to +{- | Sets the increment value for the sequence. The increment cannot be set to @0@ (PostgreSQL will raise an error when trying to create or modify the sequence in this case). @@ -130,8 +128,7 @@ setSequenceIncrement n sequenceDef = sequenceDef {i_sequenceIncrement = n} -{- | - Retrieves the min value of the sequence. If no explicit minimum has been set, +{- | Retrieves the min value of the sequence. If no explicit minimum has been set, this returns @1@ for ascending sequences and 'minBound' for 'Int64' for descending sequences. @@ -146,8 +143,7 @@ then 1 else minBound -{- | - Sets the min value for the sequence. +{- | Sets the min value for the sequence. @since 1.0.0.0 -} @@ -155,8 +151,7 @@ setSequenceMinValue n sequenceDef = sequenceDef {i_sequenceMinValue = Just n} -{- | - Retrieves the max value of the sequence. If no explicit maximum has been set, +{- | Retrieves the max value of the sequence. If no explicit maximum has been set, this returns 'maxBound' for 'Int64' for ascending sequences and @-1@ for descending sequences. @@ -171,8 +166,7 @@ then maxBound else -1 -{- | - Sets the max value for the sequence. +{- | Sets the max value for the sequence. @since 1.0.0.0 -} @@ -180,8 +174,7 @@ setSequenceMaxValue n sequenceDef = sequenceDef {i_sequenceMaxValue = Just n} -{- | - Retrieves the start value for the sequence. If no explicit start value has +{- | Retrieves the start value for the sequence. If no explicit start value has been set, this returns 'sequenceMinValue' for ascending sequences and 'sequenceMaxValue' for descending sequences. @@ -196,8 +189,7 @@ then sequenceMinValue sequenceDef else sequenceMaxValue sequenceDef -{- | - Sets the sequence start value. The start value must be at least the +{- | Sets the sequence start value. The start value must be at least the minimum value and no greater than the maximum value. @since 1.0.0.0 @@ -206,8 +198,7 @@ setSequenceStart n sequenceDef = sequenceDef {i_sequenceStart = Just n} -{- | - Retrieves the number of sequence values that will be pre-allocated by +{- | Retrieves the number of sequence values that will be pre-allocated by PostgreSQL. @since 1.0.0.0 @@ -215,8 +206,7 @@ sequenceCache :: SequenceDefinition -> Int64 sequenceCache = i_sequenceCache -{- | - Sets the number of sequence values that will be pre-allocated by PostgreSQL. +{- | Sets the number of sequence values that will be pre-allocated by PostgreSQL. @since 1.0.0.0 -} @@ -224,8 +214,7 @@ setSequenceCache n sequenceDef = sequenceDef {i_sequenceCache = n} -{- | - Indicates whether the sequence will wrap around when it reaches the maximum +{- | Indicates whether the sequence will wrap around when it reaches the maximum value (for ascending sequences) or minimum value (for descending sequences). When 'False', any attempts to get the next value of the sequence while at the limit will result in an error. @@ -235,8 +224,7 @@ sequenceCycle :: SequenceDefinition -> Bool sequenceCycle = i_sequenceCycle -{- | - Sets the 'sequenceCycle' value for the sequence. 'True' indicates that the +{- | Sets the 'sequenceCycle' value for the sequence. 'True' indicates that the sequence will cycle. 'False' will cause an error to be raised if the next sequence value is requested while already at the limit. @@ -246,8 +234,7 @@ setSequenceCycle b sequenceDef = sequenceDef {i_sequenceCycle = b} -{- | - Builds a 'Expr.CreateSequenceExpr' that will create a SQL sequence matching +{- | Builds a 'Expr.CreateSequenceExpr' that will create a SQL sequence matching the given 'SequenceDefinition' when it is executed. @since 1.0.0.0 diff --git a/src/Orville/PostgreSQL/Schema/SequenceIdentifier.hs b/src/Orville/PostgreSQL/Schema/SequenceIdentifier.hs --- a/src/Orville/PostgreSQL/Schema/SequenceIdentifier.hs +++ b/src/Orville/PostgreSQL/Schema/SequenceIdentifier.hs @@ -20,8 +20,7 @@ import qualified Orville.PostgreSQL.Expr as Expr -{- | - An identifier used by Orville to identify a particular sequence in a particular +{- | An identifier used by Orville to identify a particular sequence in a particular schema. @since 1.0.0.0 @@ -30,10 +29,16 @@ { i_sequenceIdName :: String , i_sequenceIdSchema :: Maybe String } - deriving (Eq, Ord, Show) + deriving + ( -- | @since 1.0.0.0 + Eq + , -- | @since 1.0.0.0 + Ord + , -- | @since 1.0.0.0 + Show + ) -{- | - Constructs a 'SequenceIdentifier' where the sequence's name will not be qualified +{- | Constructs a 'SequenceIdentifier' where the sequence's name will not be qualified by a particular schema. @since 1.0.0.0 @@ -45,8 +50,7 @@ , i_sequenceIdSchema = Nothing } -{- | - Sets the schema of the 'SequenceIdentifier'. Wherever applicable, references +{- | Sets the schema of the 'SequenceIdentifier'. Wherever applicable, references to the sequence will be qualified by the given schema name. @since 1.0.0.0 @@ -57,20 +61,23 @@ { i_sequenceIdSchema = Just schema } -{- | - Returns the 'Expr.Qualified Expr.SequenceName' that should be used to refer to the +{- | Returns the 'Expr.Qualified Expr.SequenceName' that should be used to refer to the sequence in SQL queries. @since 1.0.0.0 -} -sequenceIdQualifiedName :: SequenceIdentifier -> Expr.Qualified Expr.SequenceName +sequenceIdQualifiedName :: SequenceIdentifier -> Expr.QualifiedOrUnqualified Expr.SequenceName sequenceIdQualifiedName sequenceId = - Expr.qualifySequence - (sequenceIdSchemaName sequenceId) - (sequenceIdUnqualifiedName sequenceId) + case sequenceIdSchemaName sequenceId of + Nothing -> + Expr.unqualified (sequenceIdUnqualifiedName sequenceId) + Just schemaName -> + Expr.untrackQualified $ + Expr.qualifySequence + schemaName + (sequenceIdUnqualifiedName sequenceId) -{- | - Returns the unqualified 'Expr.SequenceName' that should be used to refer to the +{- | Returns the unqualified 'Expr.SequenceName' that should be used to refer to the sequence in SQL queries where an unqualified reference is appropriate. @since 1.0.0.0 @@ -79,8 +86,7 @@ sequenceIdUnqualifiedName = Expr.sequenceName . i_sequenceIdName -{- | - Returns the 'Expr.SchemaName' (if any) that should be used to qualify +{- | Returns the 'Expr.SchemaName' (if any) that should be used to qualify references to the sequence in SQL queries. @since 1.0.0.0 @@ -89,8 +95,7 @@ sequenceIdSchemaName = fmap Expr.schemaName . i_sequenceIdSchema -{- | - Retrieves the unqualified name of the sequence as a 'String'. +{- | Retrieves the unqualified name of the sequence as a 'String'. @since 1.0.0.0 -} @@ -98,8 +103,7 @@ sequenceIdUnqualifiedNameString = i_sequenceIdName -{- | - Retrieves the schema name of the sequence as a 'String'. +{- | Retrieves the schema name of the sequence as a 'String'. @since 1.0.0.0 -} @@ -107,8 +111,7 @@ sequenceIdSchemaNameString = i_sequenceIdSchema -{- | - Converts a 'SequenceIdentifier' for a 'String' for descriptive purposes. The +{- | Converts a 'SequenceIdentifier' for a 'String' for descriptive purposes. The name will be qualified if a schema name has been set for the identifier. Note: You should not use this function for building SQL expressions. Use diff --git a/src/Orville/PostgreSQL/Schema/TableDefinition.hs b/src/Orville/PostgreSQL/Schema/TableDefinition.hs --- a/src/Orville/PostgreSQL/Schema/TableDefinition.hs +++ b/src/Orville/PostgreSQL/Schema/TableDefinition.hs @@ -2,7 +2,7 @@ {-# LANGUAGE RankNTypes #-} {- | -Copyright : Flipstone Technology Partners 2023 +Copyright : Flipstone Technology Partners 2023-2025 License : MIT Stability : Stable @@ -18,11 +18,15 @@ , columnsToDrop , tableIdentifier , tableName + , tableComment , setTableSchema + , setTableComment , tableConstraints , addTableConstraints , tableIndexes , addTableIndexes + , tableTriggers + , addTableTriggers , tablePrimaryKey , tableMarshaller , mapTableMarshaller @@ -36,22 +40,22 @@ ) where -import Data.List.NonEmpty (NonEmpty, toList) +import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map import qualified Data.Set as Set +import qualified Data.Text as T import Orville.PostgreSQL.Execution.ReturningOption (ReturningOption (WithReturning, WithoutReturning)) import qualified Orville.PostgreSQL.Expr as Expr import Orville.PostgreSQL.Internal.IndexDefinition (IndexDefinition, IndexMigrationKey, indexMigrationKey) -import Orville.PostgreSQL.Marshall.FieldDefinition (fieldColumnDefinition, fieldColumnName, fieldValueToSqlValue) +import Orville.PostgreSQL.Marshall.FieldDefinition (fieldColumnDefinition, fieldColumnName, fieldValueToSqlValue, qualifiedFieldColumnName, qualifyField) import Orville.PostgreSQL.Marshall.SqlMarshaller (AnnotatedSqlMarshaller, MarshallerField (Natural, Synthetic), ReadOnlyColumnOption (ExcludeReadOnlyColumns, IncludeReadOnlyColumns), SqlMarshaller, annotateSqlMarshaller, annotateSqlMarshallerEmptyAnnotation, collectFromField, foldMarshallerFields, mapSqlMarshaller, marshallerDerivedColumns, marshallerTableConstraints, unannotatedSqlMarshaller) -import Orville.PostgreSQL.Raw.SqlValue (SqlValue) import Orville.PostgreSQL.Schema.ConstraintDefinition (ConstraintDefinition, TableConstraints, addConstraint, constraintSqlExpr, emptyTableConstraints, tableConstraintDefinitions) import Orville.PostgreSQL.Schema.PrimaryKey (PrimaryKey, mkPrimaryKeyExpr, primaryKeyFieldNames) import Orville.PostgreSQL.Schema.TableIdentifier (TableIdentifier, setTableIdSchema, tableIdQualifiedName, unqualifiedNameToTableId) +import Orville.PostgreSQL.Schema.TriggerDefinition (TriggerDefinition, TriggerMigrationKey, triggerMigrationKey) -{- | - Contains the definition of a SQL table for Orville to use for generating +{- | Contains the definition of a SQL table for Orville to use for generating queries and marshalling Haskell values to and from the database. * @key@ is a Haskell type used to indicate whether the table has a primary @@ -73,10 +77,11 @@ , i_tableColumnsToDrop :: Set.Set String , i_tableConstraintsFromTable :: TableConstraints , i_tableIndexes :: Map.Map IndexMigrationKey IndexDefinition + , i_tableTriggers :: Map.Map TriggerMigrationKey TriggerDefinition + , i_tableComment :: Maybe T.Text } -{- | - 'HasKey' is a type with no constructors. It is used only at the type level +{- | 'HasKey' is a type with no constructors. It is used only at the type level as the @key@ parameter to the 'TableDefinition' type to indicate that the table has a primary key and what the Haskell type of the primary key is. @@ -84,8 +89,7 @@ -} data HasKey key -{- | - 'NoKey' is a type with no constructors. It is used only at the type level +{- | 'NoKey' is a type with no constructors. It is used only at the type level as the @key@ parameter to the 'TableDefinition' type to indicate that the table does not have a primary key. @@ -93,8 +97,7 @@ -} data NoKey -{- | - INTERNAL: Use at the value level to track whether the 'TableDefinition' has a +{- | INTERNAL: Use at the value level to track whether the 'TableDefinition' has a primary key. The @key@ parameter matches the @key@ parameter of 'TableDefinition' @@ -104,8 +107,7 @@ TableHasKey :: PrimaryKey keyType -> TablePrimaryKey (HasKey keyType) TableHasNoKey :: TablePrimaryKey NoKey -{- | - Constructs a new 'TableDefinition' with the basic fields required for +{- | Constructs a new 'TableDefinition' with the basic fields required for operation. For convenience, this function accepts a 'PrimaryKey' even though this is not required for all Orville operations to work. If you need to create a table without any primary key, see 'mkTableDefinitionWithoutKey'. @@ -124,14 +126,15 @@ TableDefinition { i_tableIdentifier = unqualifiedNameToTableId name , i_tablePrimaryKey = TableHasKey primaryKey - , i_tableMarshaller = annotateSqlMarshaller (toList $ primaryKeyFieldNames primaryKey) marshaller + , i_tableMarshaller = annotateSqlMarshaller (NE.toList $ primaryKeyFieldNames primaryKey) marshaller , i_tableColumnsToDrop = Set.empty , i_tableConstraintsFromTable = emptyTableConstraints , i_tableIndexes = Map.empty + , i_tableTriggers = Map.empty + , i_tableComment = Nothing } -{- | - Constructs a new 'TableDefinition' with the minimal fields required for +{- | Constructs a new 'TableDefinition' with the minimal fields required for operation. Note: tables created via this function will not have a primary key. Certain Orville functions require a primary key. Attempting to call functions requiring a primary key will fail to compile when using a table @@ -153,10 +156,11 @@ , i_tableColumnsToDrop = Set.empty , i_tableConstraintsFromTable = emptyTableConstraints , i_tableIndexes = Map.empty + , i_tableTriggers = Map.empty + , i_tableComment = Nothing } -{- | - Annotates a 'TableDefinition' with a direction to drop columns if they are +{- | Annotates a 'TableDefinition' with a direction to drop columns if they are found in the database. Orville does not drop columns during auto-migration unless they are explicitly requested to be dropped via 'dropColumns'. @@ -179,8 +183,7 @@ { i_tableColumnsToDrop = i_tableColumnsToDrop tableDef <> Set.fromList columns } -{- | - Returns the set of columns that have been marked as dropped by 'dropColumns'. +{- | Returns the set of columns that have been marked as dropped by 'dropColumns'. @since 1.0.0.0 -} @@ -188,8 +191,7 @@ columnsToDrop = i_tableColumnsToDrop -{- | - Returns the table's 'TableIdentifier'. +{- | Returns the table's 'TableIdentifier'. @since 1.0.0.0 -} @@ -197,19 +199,25 @@ tableIdentifier = i_tableIdentifier -{- | - Returns the table's name as an expression that can be used to build SQL +{- | Returns the table's name as an expression that can be used to build SQL statements. If the table has a schema name set, the name will be qualified with it. @since 1.0.0.0 -} -tableName :: TableDefinition key writeEntity readEntity -> Expr.Qualified Expr.TableName +tableName :: TableDefinition key writeEntity readEntity -> Expr.QualifiedOrUnqualified Expr.TableName tableName = tableIdQualifiedName . i_tableIdentifier -{- | - Sets the table's schema to the name in the given 'String', which will be +{- | Returns 'Just' the comment of the table, or 'Nothing' if it has not been set. + +@since 1.1.0.0 +-} +tableComment :: TableDefinition key writeEntity readEntity -> Maybe T.Text +tableComment = + i_tableComment + +{- | Sets the table's schema to the name in the given 'String', which will be treated as a SQL identifier. If a table has a schema name set, it will be included as a qualifier on the table name for all queries involving the table. @@ -225,8 +233,20 @@ { i_tableIdentifier = setTableIdSchema schemaName (i_tableIdentifier tableDef) } -{- | - Retrieves all the table constraints that have been added to the table either +{- | Sets the table's comment. + +@since 1.1.0.0 +-} +setTableComment :: + T.Text -> + TableDefinition key writeEntity readEntity -> + TableDefinition key writeEntity readEntity +setTableComment comment tableDef = + tableDef + { i_tableComment = Just comment + } + +{- | Retrieves all the table constraints that have been added to the table either via 'addTableConstraints' or that are found on 'Orville.PostgreSQL.FieldDefinition's included with this table's 'SqlMarshaller'. @@ -240,8 +260,7 @@ tableConstraintsFromMarshaller <> tableConstraintsFromTable -{- | - Retrieves all the table constraints that have been added to the table via +{- | Retrieves all the table constraints that have been added to the table via 'addTableConstraints'. This does NOT include any table constraints from the table's 'SqlMarshaller'. @@ -253,8 +272,7 @@ tableConstraintsFromTable = i_tableConstraintsFromTable -{- | - Retrieves all the table constraints that were included in the table's +{- | Retrieves all the table constraints that were included in the table's 'SqlMarshaller' when it was created. This does NOT include any table constraints added via 'addTableConstraints'. @@ -268,8 +286,7 @@ . unannotatedSqlMarshaller . i_tableMarshaller -{- | - Adds the given table constraints to the table definition. It's also possible +{- | Adds the given table constraints to the table definition. It's also possible to add constraints that apply to only one column, adding them to the 'Orville.PostgreSQL.FieldDefinition's that are included in the table's 'SqlMarshaller'. @@ -297,8 +314,7 @@ constraintDefs } -{- | - Retrieves all the table indexes that have been added to the table via +{- | Retrieves all the table indexes that have been added to the table via 'addTableIndexes'. @since 1.0.0.0 @@ -309,8 +325,7 @@ tableIndexes = i_tableIndexes -{- | - Adds the given table indexes to the table definition. +{- | Adds the given table indexes to the table definition. Note: If multiple indexes are added with the same 'IndexMigrationKey', only the last one that is added will be part of the 'TableDefinition'. Any @@ -324,15 +339,52 @@ TableDefinition key writeEntity readEntity addTableIndexes indexDefs tableDef = let - addIndex index indexMap = - Map.insert (indexMigrationKey index) index indexMap + addIndex index = + Map.insert (indexMigrationKey index) index in tableDef { i_tableIndexes = foldr addIndex (i_tableIndexes tableDef) indexDefs } -{- | - Returns the primary key for the table, as defined at construction via +{- | Retrieves all the table indexes that have been added to the table via + 'addTableTriggers'. + +@since 1.1.0.0 +-} +tableTriggers :: + TableDefinition key writeEntity readEntity -> + Map.Map TriggerMigrationKey TriggerDefinition +tableTriggers = + i_tableTriggers + +{- | Adds the given table triggers to the table definition. + + Note: If multiple wriggers are added with the same 'Expr.TriggerName', only + the last one that is added will be part of the 'TableDefinition'. Any + previously-added constraint with the same key is replaced by the new one. + + Also Note: Orville does not currently support migrating triggers based on + their definition structure. If a trigger with the same name already exists + on the table at the time of migration nothing will be done to updated it. + To cause Orville to create a new trigger matching the definition in the code, + you need to change the name of the trigger. + +@since 1.1.0.0 +-} +addTableTriggers :: + [TriggerDefinition] -> + TableDefinition key writeEntity readEntity -> + TableDefinition key writeEntity readEntity +addTableTriggers triggerDefs tableDef = + let + addTrigger trigger = + Map.insert (triggerMigrationKey trigger) trigger + in + tableDef + { i_tableTriggers = foldr addTrigger (i_tableTriggers tableDef) triggerDefs + } + +{- | Returns the primary key for the table, as defined at construction via 'mkTableDefinition'. @since 1.0.0.0 @@ -342,8 +394,7 @@ case i_tablePrimaryKey def of TableHasKey primaryKey -> primaryKey -{- | - Returns the marshaller for the table, as defined at construction via +{- | Returns the marshaller for the table, as defined at construction via 'mkTableDefinition'. @since 1.0.0.0 @@ -351,8 +402,7 @@ tableMarshaller :: TableDefinition key writeEntity readEntity -> AnnotatedSqlMarshaller writeEntity readEntity tableMarshaller = i_tableMarshaller -{- | - Applies the provided function to the underlying 'SqlMarshaller' of the +{- | Applies the provided function to the underlying 'SqlMarshaller' of the 'TableDefinition'. @since 1.0.0.0 @@ -364,8 +414,7 @@ mapTableMarshaller f tableDef = tableDef {i_tableMarshaller = mapSqlMarshaller f $ i_tableMarshaller tableDef} -{- | - Builds a 'Expr.CreateTableExpr' that will create a SQL table matching the +{- | Builds a 'Expr.CreateTableExpr' that will create a SQL table matching the given 'TableDefinition' when it is executed. @since 1.0.0.0 @@ -380,8 +429,7 @@ (mkTablePrimaryKeyExpr tableDef) (map constraintSqlExpr . tableConstraintDefinitions . tableConstraints $ tableDef) -{- | - Builds the 'Expr.ColumnDefinitions' for all the fields described by the +{- | Builds the 'Expr.ColumnDefinitions' for all the fields described by the table definition's 'SqlMarshaller'. @since 1.0.0.0 @@ -393,10 +441,9 @@ foldMarshallerFields (unannotatedSqlMarshaller $ tableMarshaller tableDef) [] - (collectFromField IncludeReadOnlyColumns fieldColumnDefinition) + (collectFromField IncludeReadOnlyColumns (const fieldColumnDefinition)) -{- | - Builds the 'Expr.PrimaryKeyExpr' for this table, or none if this table has no +{- | Builds the 'Expr.PrimaryKeyExpr' for this table, or none if this table has no primary key. @since 1.0.0.0 @@ -411,8 +458,7 @@ TableHasNoKey -> Nothing -{- | - When 'WithReturning' is given, builds a 'Expr.ReturningExpr' that will +{- | When 'WithReturning' is given, builds a 'Expr.ReturningExpr' that will return all the columns in the given 'TableDefinition'. @since 1.0.0.0 @@ -434,8 +480,7 @@ . tableMarshaller $ tableDef -{- | - Builds an 'Expr.InsertExpr' that will insert the given entities into the SQL +{- | Builds an 'Expr.InsertExpr' that will insert the given entities into the SQL table when it is executed. A @RETURNING@ clause will either be included to return the inserted rows or not, depending on the 'ReturningOption' given. @@ -444,9 +489,10 @@ mkInsertExpr :: ReturningOption returningClause -> TableDefinition key writeEntity readEntity -> - NonEmpty writeEntity -> + Maybe Expr.OnConflictExpr -> + NE.NonEmpty writeEntity -> Expr.InsertExpr -mkInsertExpr returningOption tableDef entities = +mkInsertExpr returningOption tableDef maybeOnConflict entities = let marshaller = unannotatedSqlMarshaller $ tableMarshaller tableDef @@ -461,10 +507,10 @@ (tableName tableDef) (Just insertColumnList) insertSource + maybeOnConflict (mkTableReturningClause returningOption tableDef) -{- | - Builds an 'Expr.InsertColumnList' that specifies the columns for an +{- | Builds an 'Expr.InsertColumnList' that specifies the columns for an insert statement in the order that they appear in the given 'SqlMarshaller'. In normal circumstances you will want to build the complete insert statement @@ -477,11 +523,19 @@ SqlMarshaller writeEntity readEntity -> Expr.InsertColumnList mkInsertColumnList marshaller = - Expr.insertColumnList $ - foldMarshallerFields marshaller [] (collectFromField ExcludeReadOnlyColumns fieldColumnName) + Expr.insertColumnList + . foldMarshallerFields marshaller [] + $ collectFromField + ExcludeReadOnlyColumns + ( \mbQ -> case mbQ of + Nothing -> Expr.unqualified . fieldColumnName + Just qualifier -> + Expr.untrackQualified + . qualifiedFieldColumnName + . qualifyField qualifier + ) -{- | - Builds an 'Expr.InsertSource' that will insert the given entities with their +{- | Builds an 'Expr.InsertSource' that will insert the given entities with their values specified in the order that the fields appear in the given 'SqlMarshaller' (which matches the order of column names produced by 'mkInsertColumnList'). @@ -490,36 +544,53 @@ via 'mkInsertExpr', but this is exported in case you are composing SQL yourself and need the column list of an insert as a fragment. + If the 'SqlMarshaller' does not contain any fields, the resulting 'InsertSource' + will insert a default row using @VALUES(DEFAULT)@. + @since 1.0.0.0 -} mkInsertSource :: SqlMarshaller writeEntity readEntity -> - NonEmpty writeEntity -> + NE.NonEmpty writeEntity -> Expr.InsertSource mkInsertSource marshaller entities = let encodeRow = - foldMarshallerFields marshaller (const []) collectSqlValue + foldMarshallerFields marshaller (const Nothing) collectSqlValue in - Expr.insertSqlValues $ map encodeRow (toList entities) + Expr.valuesExprInsertSource $ + case traverse encodeRow entities of + Nothing -> + Expr.valuesExpr + (Expr.valuesExprRow (pure Expr.valuesExprDefaultValue) <$ entities) + Nothing + Nothing + Nothing + Nothing + Just valExprs -> + Expr.valuesExprFromValueExpressions valExprs -{- | - An internal helper function that collects the 'SqlValue' encoded value for a - field from a Haskell entity, adding it a list of 'SqlValue's that is being - built. +{- | An internal helper function that collects the 'SqlValue' encoded value for a field from a Haskell + entity as a 'ValueExpression', adding it a list of 'ValueExpresion's that is being built. @since 1.0.0.0 -} collectSqlValue :: MarshallerField entity -> - (entity -> [SqlValue]) -> + (entity -> Maybe (NE.NonEmpty Expr.ValueExpression)) -> entity -> - [SqlValue] + Maybe (NE.NonEmpty Expr.ValueExpression) collectSqlValue entry encodeRest entity = case entry of - Natural fieldDef (Just accessor) -> - fieldValueToSqlValue fieldDef (accessor entity) : (encodeRest entity) - Natural _ Nothing -> + Natural _ fieldDef (Just accessor) -> + let + self = Expr.valueExpression $ fieldValueToSqlValue fieldDef (accessor entity) + in + maybe + (Just $ pure self) + (Just . NE.cons self) + (encodeRest entity) + Natural _ _ Nothing -> encodeRest entity Synthetic _ -> encodeRest entity diff --git a/src/Orville/PostgreSQL/Schema/TableIdentifier.hs b/src/Orville/PostgreSQL/Schema/TableIdentifier.hs --- a/src/Orville/PostgreSQL/Schema/TableIdentifier.hs +++ b/src/Orville/PostgreSQL/Schema/TableIdentifier.hs @@ -20,8 +20,7 @@ import qualified Orville.PostgreSQL.Expr as Expr -{- | - An identifier used by Orville to identify a particular table in a particular +{- | An identifier used by Orville to identify a particular table in a particular schema. @since 1.0.0.0 @@ -30,10 +29,16 @@ { i_tableIdName :: String , i_tableIdSchema :: Maybe String } - deriving (Eq, Ord, Show) + deriving + ( -- | @since 1.0.0.0 + Eq + , -- | @since 1.0.0.0 + Ord + , -- | @since 1.0.0.0 + Show + ) -{- | - Constructs a 'TableIdentifier' where the table's name will not be qualified +{- | Constructs a 'TableIdentifier' where the table's name will not be qualified by a particular schema. @since 1.0.0.0 @@ -45,8 +50,7 @@ , i_tableIdSchema = Nothing } -{- | - Sets the schema of the 'TableIdentifier'. Wherever applicable, references to +{- | Sets the schema of the 'TableIdentifier'. Wherever applicable, references to the table will be qualified by the given schema name. @since 1.0.0.0 @@ -57,20 +61,23 @@ { i_tableIdSchema = Just schema } -{- | - Returns the 'Expr.Qualified Expr.TableName' that should be used to refer to +{- | Returns the 'Expr.Qualified Expr.TableName' that should be used to refer to the table in SQL queries. @since 1.0.0.0 -} -tableIdQualifiedName :: TableIdentifier -> Expr.Qualified Expr.TableName +tableIdQualifiedName :: TableIdentifier -> Expr.QualifiedOrUnqualified Expr.TableName tableIdQualifiedName tableId = - Expr.qualifyTable - (tableIdSchemaName tableId) - (tableIdUnqualifiedName tableId) + case tableIdSchemaName tableId of + Nothing -> + Expr.unqualified (tableIdUnqualifiedName tableId) + Just schemaName -> + Expr.untrackQualified $ + Expr.qualifyTable + schemaName + (tableIdUnqualifiedName tableId) -{- | - Returns the unqualified 'Expr.TableName' that should be used to refer to the +{- | Returns the unqualified 'Expr.TableName' that should be used to refer to the table in SQL queries where an unqualified reference is appropriate. @since 1.0.0.0 @@ -79,8 +86,7 @@ tableIdUnqualifiedName = Expr.tableName . i_tableIdName -{- | - Returns the 'Expr.SchemaName' (if any) that should be used to qualify +{- | Returns the 'Expr.SchemaName' (if any) that should be used to qualify references to the table in SQL queries. @since 1.0.0.0 @@ -89,8 +95,7 @@ tableIdSchemaName = fmap Expr.schemaName . i_tableIdSchema -{- | - Retrieves the unqualified name of the table as a 'String'. +{- | Retrieves the unqualified name of the table as a 'String'. @since 1.0.0.0 -} @@ -98,8 +103,7 @@ tableIdUnqualifiedNameString = i_tableIdName -{- | - Retrieves the schema name of the table as a 'String'. +{- | Retrieves the schema name of the table as a 'String'. @since 1.0.0.0 -} @@ -107,8 +111,7 @@ tableIdSchemaNameString = i_tableIdSchema -{- | - Converts a 'TableIdentifier' to a 'String' for descriptive purposes. The +{- | Converts a 'TableIdentifier' to a 'String' for descriptive purposes. The name will be qualified if a schema name has been set for the identifier. Note: You should not use this function for building SQL expressions. Use diff --git a/src/Orville/PostgreSQL/Schema/TriggerDefinition.hs b/src/Orville/PostgreSQL/Schema/TriggerDefinition.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Schema/TriggerDefinition.hs @@ -0,0 +1,192 @@ +{- | +Copyright : Flipstone Technology Partners 2024 +License : MIT +Stability : Stable + +@since 1.1.0.0 +-} +module Orville.PostgreSQL.Schema.TriggerDefinition + ( TriggerDefinition + , beforeInsert + , afterInsert + , beforeUpdate + , afterUpdate + , beforeDelete + , afterDelete + , mkTriggerDefinition + , TriggerMigrationKey (NamedTriggerKey) + , triggerMigrationKey + , mkCreateTriggerExpr + ) where + +import Data.List.NonEmpty (NonEmpty ((:|))) + +import qualified Orville.PostgreSQL.Expr as Expr + +{- | Defines a trigger that can be added to a + 'Orville.PostgreSQL.TableDefinition'. Use one of the constructor functions + below (such as 'mkNamedTriggerDefinition') to construct the constraint + definition you wish to have and then use 'Orville.PostgreSQL.addTableTriggers' + to add them to your table definition. Orville will then add the trigger next + time you run auto-migrations. + + Note that currently Orville will only add triggers when it sees that no trigger + with the same name exists. If you want to change the definition of the trigger + you should also change the name that you specify when making the 'TriggerDefinition' + so that Orville will drop the old trigger and create a new trigger with the new + name. + +@since 1.1.0.0 +-} +data TriggerDefinition = TriggerDefinition + { i_triggerMigrationKey :: TriggerMigrationKey + , i_triggerCreateExpr :: + Maybe Expr.OrReplace -> + Expr.QualifiedOrUnqualified Expr.TableName -> + Expr.CreateTriggerExpr + } + +{- | Orville uses 'TriggerMigration' values while performing auto migrations to + determine whether an trigger needs to be added or dropped. For most use cases + the constructor functions that build an 'TriggerDefinition' will create this + automatically for you. + +@since 1.1.0.0 +-} +newtype TriggerMigrationKey + = NamedTriggerKey String + deriving + ( -- | @since 1.1.0.0 + Eq + , -- | @since 1.1.0.0 + Ord + ) + +{- | Gets the 'TriggerMigrationKey' for the 'TriggerDefinition' + +@since 1.1.0.0 +-} +triggerMigrationKey :: TriggerDefinition -> TriggerMigrationKey +triggerMigrationKey = + i_triggerMigrationKey + +{- | Builds a 'TriggerDefinition' that will execute the named function for each row + being inserted before it is inserted. + +@since 1.1.0.0 +-} +beforeInsert :: String -> Expr.QualifiedOrUnqualified Expr.FunctionName -> TriggerDefinition +beforeInsert name = + mkTriggerDefinition + name + Expr.triggerBefore + (Expr.triggerOnInsert :| []) + Expr.triggerForEachRow + +{- | Builds a 'TriggerDefinition' that will execute the named function for each row + being inserted after it is inserted. + +@since 1.1.0.0 +-} +afterInsert :: String -> Expr.QualifiedOrUnqualified Expr.FunctionName -> TriggerDefinition +afterInsert name = + mkTriggerDefinition + name + Expr.triggerAfter + (Expr.triggerOnInsert :| []) + Expr.triggerForEachRow + +{- | Builds a 'TriggerDefinition' that will execute the named function for each row + being updated before it is updated. + +@since 1.1.0.0 +-} +beforeUpdate :: String -> Expr.QualifiedOrUnqualified Expr.FunctionName -> TriggerDefinition +beforeUpdate name = + mkTriggerDefinition + name + Expr.triggerBefore + (Expr.triggerOnUpdate :| []) + Expr.triggerForEachRow + +{- | Builds a 'TriggerDefinition' that will execute the named function for each row + being updated after it is updated. + +@since 1.1.0.0 +-} +afterUpdate :: String -> Expr.QualifiedOrUnqualified Expr.FunctionName -> TriggerDefinition +afterUpdate name = + mkTriggerDefinition + name + Expr.triggerAfter + (Expr.triggerOnUpdate :| []) + Expr.triggerForEachRow + +{- | Builds a 'TriggerDefinition' that will execute the named function for each row + being deleted before it is deleted. + +@since 1.1.0.0 +-} +beforeDelete :: String -> Expr.QualifiedOrUnqualified Expr.FunctionName -> TriggerDefinition +beforeDelete name = + mkTriggerDefinition + name + Expr.triggerBefore + (Expr.triggerOnDelete :| []) + Expr.triggerForEachRow + +{- | Builds a 'TriggerDefinition' that will execute the named function for each row + being deleted after it is deleted. + +@since 1.1.0.0 +-} +afterDelete :: String -> Expr.QualifiedOrUnqualified Expr.FunctionName -> TriggerDefinition +afterDelete name = + mkTriggerDefinition + name + Expr.triggerAfter + (Expr.triggerOnDelete :| []) + Expr.triggerForEachRow + +{- | Constructs a 'TriggerDefinition' definining a trigger with the specified name. + Note that orville is currently not capable of migrating triggers based on their + structure. The trigger will be created if no trigger exists on the table with + the specificed name. If a trigger already exists with the same name on the table + then nothing will be done. + +@since 1.1.0.0 +-} +mkTriggerDefinition :: + String -> + Expr.TriggerTiming -> + NonEmpty Expr.TriggerEvent -> + Expr.TriggerFireScope -> + Expr.QualifiedOrUnqualified Expr.FunctionName -> + TriggerDefinition +mkTriggerDefinition name timing events fireScope functionName = + TriggerDefinition + { i_triggerMigrationKey = NamedTriggerKey name + , i_triggerCreateExpr = + \orReplace tableName -> + Expr.createTrigger + orReplace + (Expr.triggerName name) + timing + events + tableName + fireScope + functionName + } + +{- | Builds a 'Expr.CreateTriggerExpr' that will create a SQL trigger matching + the given 'TriggerDefinition' when it is executed. + +@since 1.1.0.0 +-} +mkCreateTriggerExpr :: + TriggerDefinition -> + Maybe Expr.OrReplace -> + Expr.QualifiedOrUnqualified Expr.TableName -> + Expr.CreateTriggerExpr +mkCreateTriggerExpr = + i_triggerCreateExpr diff --git a/src/Orville/PostgreSQL/UnliftIO.hs b/src/Orville/PostgreSQL/UnliftIO.hs --- a/src/Orville/PostgreSQL/UnliftIO.hs +++ b/src/Orville/PostgreSQL/UnliftIO.hs @@ -39,8 +39,7 @@ import qualified Control.Monad.IO.Unlift as UL -{- | - 'liftWithConnectionViaUnliftIO' can be used as the implementation of +{- | 'liftWithConnectionViaUnliftIO' can be used as the implementation of 'Orville.PostgreSQL.liftWithConnection' for 'Orville.PostgreSQL.MonadOrvilleControl' when the 'Monad' implements 'UL.MonadUnliftIO'. @@ -55,8 +54,7 @@ liftWithConnectionViaUnliftIO ioWithConn action = UL.withRunInIO $ \runInIO -> ioWithConn (runInIO . action) -{- | - 'liftCatchViaUnliftIO' can be used as the implementation of +{- | 'liftCatchViaUnliftIO' can be used as the implementation of 'Orville.PostgreSQL.liftCatch' for 'Orville.PostgreSQL.MonadOrvilleControl' when the 'Monad' implements 'UL.MonadUnliftIO'. @@ -73,10 +71,9 @@ UL.liftIO $ ioCatch (UL.unliftIO unlio action) - (\ex -> UL.unliftIO unlio (handler ex)) + (UL.unliftIO unlio . handler) -{- | - 'liftMaskViaUnliftIO' can be used as the implementation of +{- | 'liftMaskViaUnliftIO' can be used as the implementation of 'Orville.PostgreSQL.liftMask' for 'Orville.PostgreSQL.MonadOrvilleControl' when the 'Monad' implements 'UL.MonadUnliftIO'. diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -16,17 +16,25 @@ import qualified Test.Cursor as Cursor import qualified Test.EntityOperations as EntityOperations import qualified Test.Execution as Execution +import qualified Test.Expr.Aggregate as ExprAggregate +import qualified Test.Expr.ConditionalExpr as ExprConditional import qualified Test.Expr.Count as ExprCount import qualified Test.Expr.Cursor as ExprCursor import qualified Test.Expr.GroupBy as ExprGroupBy import qualified Test.Expr.GroupByOrderBy as ExprGroupByOrderBy import qualified Test.Expr.InsertUpdateDelete as ExprInsertUpdateDelete +import qualified Test.Expr.Join as ExprJoin import qualified Test.Expr.Math as ExprMath import qualified Test.Expr.OrderBy as ExprOrderBy import qualified Test.Expr.SequenceDefinition as ExprSequenceDefinition import qualified Test.Expr.TableDefinition as ExprTableDefinition +import qualified Test.Expr.TableReferenceList as ExprTableReferenceList +import qualified Test.Expr.TextSearch as ExprTextSearch import qualified Test.Expr.Time as ExprTime +import qualified Test.Expr.Trigger as ExprTrigger +import qualified Test.Expr.Vacuum as ExprVacuum import qualified Test.Expr.Where as ExprWhere +import qualified Test.Expr.Window as ExprWindow import qualified Test.FieldDefinition as FieldDefinition import qualified Test.MarshallError as MarshallError import qualified Test.PgCatalog as PgCatalog @@ -53,8 +61,10 @@ [ Connection.connectionTests pool , RawSql.rawSqlTests pool , Execution.executionTests pool + , PgTime.pgTimeTests pool , SqlType.sqlTypeTests pool , PostgreSQLAxioms.postgreSQLAxiomTests pool + , ExprAggregate.aggregateTests pool , ExprInsertUpdateDelete.insertUpdateDeleteTests pool , ExprWhere.whereTests pool , ExprOrderBy.orderByTests pool @@ -66,6 +76,13 @@ , ExprCount.countTests pool , ExprMath.mathTests pool , ExprTime.timeTests pool + , ExprTrigger.triggerTests pool + , ExprVacuum.vacuumTests + , ExprJoin.joinTests + , ExprTableReferenceList.tableReferenceListTests + , ExprConditional.conditionalTests + , ExprWindow.windowTests + , ExprTextSearch.textSearchTests pool , FieldDefinition.fieldDefinitionTests pool , SqlMarshaller.sqlMarshallerTests , MarshallError.marshallErrorTests pool @@ -80,7 +97,6 @@ , AutoMigration.autoMigrationTests pool , Cursor.cursorTests pool , SqlCommenter.sqlCommenterTests pool - , PgTime.pgTimeTests pool ] Monad.unless (Property.allPassed summary) SE.exitFailure diff --git a/test/Test/AutoMigration.hs b/test/Test/AutoMigration.hs --- a/test/Test/AutoMigration.hs +++ b/test/Test/AutoMigration.hs @@ -17,6 +17,7 @@ import qualified Data.List.NonEmpty as NEL import qualified Data.Maybe as Maybe import qualified Data.String as String +import qualified Data.Text as T import Hedgehog ((===)) import qualified Hedgehog as HH import qualified Hedgehog.Gen as Gen @@ -29,8 +30,10 @@ import qualified Orville.PostgreSQL.Raw.Connection as Conn import qualified Orville.PostgreSQL.Raw.RawSql as RawSql import qualified Orville.PostgreSQL.Schema as Schema +import qualified Orville.PostgreSQL.Schema.TableDefinition as TableDefinition import qualified Test.Entities.Foo as Foo +import Test.Orphans () import qualified Test.PgAssert as PgAssert import qualified Test.PgGen as PgGen import qualified Test.Property as Property @@ -40,7 +43,8 @@ autoMigrationTests pool = Property.group "AutoMigration" - [ prop_raisesErrorIfMigrationLockIsLocked pool + [ prop_altersColumnAddIdentity pool + , prop_raisesErrorIfMigrationLockIsLocked pool , prop_releasesMigrationLockOnError pool , prop_createsMissingTables pool , prop_dropsRequestedTables pool @@ -58,20 +62,40 @@ , prop_altersModifiedSequences pool , prop_addsAndRemovesMixedIndexes pool , prop_arbitrarySchemaInitialMigration pool + , prop_createsMissingFunctions pool + , prop_recreatesAlteredFunctions pool + , prop_dropsRequestedFunctions pool + , prop_createsMissingTriggers pool + , prop_dropsUnrequestedTriggers pool + , prop_loadsMissingExtensions pool + , prop_unloadsPresentExtensions pool + , prop_addsTableComment pool + , prop_removesTableComment pool + , prop_modifiesTableComment pool + , prop_addsColumnCommmentsOnCreateTable pool + , prop_modifiesColumnComments pool ] prop_raisesErrorIfMigrationLockIsLocked :: Property.NamedDBProperty prop_raisesErrorIfMigrationLockIsLocked = Property.singletonNamedDBProperty "Raises an error when the migration lock is hold" $ \pool -> do + let + testLockOptions = + AutoMigration.defaultLockOptions + { AutoMigration.maxLockAttempts = 3 + , AutoMigration.delayBetweenLockAttemptsMicros = 1000 + , AutoMigration.lockDelayVariationMicros = 0 + } + errOrSuccess <- HH.evalIO $ Orville.runOrville pool $ - AutoMigration.withMigrationLock AutoMigration.defaultLockId $ + AutoMigration.withMigrationLock testLockOptions $ MIO.liftIO $ ExSafe.try $ Orville.runOrville pool $ AutoMigration.withMigrationLock - AutoMigration.defaultLockId + testLockOptions (pure ()) case errOrSuccess of @@ -95,14 +119,14 @@ Orville.runOrville pool $ ExSafe.handle (\SimulatedError -> pure ()) $ AutoMigration.withMigrationLock - AutoMigration.defaultLockId + AutoMigration.defaultLockOptions (ExSafe.throwM SimulatedError) -- If the lock is not released by the previous 'withMigrationLock' -- this second call will fail to acquire the lock and the test will -- fail AutoMigration.withMigrationLock - AutoMigration.defaultLockId + AutoMigration.defaultLockOptions (pure ()) data SimulatedError = SimulatedError @@ -160,9 +184,154 @@ PgAssert.assertTableDoesNotExist pool (Orville.tableIdUnqualifiedNameString fooTableId) migrationPlanStepStrings secondTimePlan === [] +prop_addsTableComment :: Property.NamedDBProperty +prop_addsTableComment = + Property.singletonNamedDBProperty "Adds a comment to a table" $ \pool -> do + let + comment = String.fromString "This is a comment" + + fooTableWithComment = Orville.setTableComment comment Foo.table + + fooTableId = + Orville.tableIdentifier fooTableWithComment + + firstTimePlan <- + HH.evalIO $ + Orville.runOrville pool $ do + Orville.executeVoid Orville.DDLQuery $ TestTable.dropTableDefSql fooTableWithComment + AutoMigration.generateMigrationPlan AutoMigration.defaultOptions [AutoMigration.SchemaTable fooTableWithComment] + + secondTimePlan <- + HH.evalIO $ + Orville.runOrville pool $ do + AutoMigration.executeMigrationPlan AutoMigration.defaultOptions firstTimePlan + AutoMigration.generateMigrationPlan AutoMigration.defaultOptions [AutoMigration.SchemaTable fooTableWithComment] + + length (AutoMigration.migrationPlanSteps firstTimePlan) === 2 + PgAssert.assertTableHasComment pool (Orville.tableIdUnqualifiedNameString fooTableId) comment + migrationPlanStepStrings secondTimePlan === [] + +prop_removesTableComment :: Property.NamedDBProperty +prop_removesTableComment = + Property.singletonNamedDBProperty "Removes a comment from a table" $ \pool -> do + let + comment = String.fromString "This is a comment" + + fooTableId = + Orville.tableIdentifier Foo.table + + firstTimePlan <- + HH.evalIO $ + Orville.runOrville pool $ do + Orville.executeVoid Orville.DDLQuery $ TestTable.dropTableDefSql Foo.table + Orville.executeVoid Orville.DDLQuery $ Schema.mkCreateTableExpr Foo.table + Orville.executeVoid Orville.DDLQuery $ Expr.commentTableExpr (Orville.tableName Foo.table) (Just $ Expr.commentText comment) + AutoMigration.generateMigrationPlan AutoMigration.defaultOptions [AutoMigration.SchemaTable Foo.table] + + secondTimePlan <- + HH.evalIO $ + Orville.runOrville pool $ do + AutoMigration.executeMigrationPlan AutoMigration.defaultOptions firstTimePlan + AutoMigration.generateMigrationPlan AutoMigration.defaultOptions [AutoMigration.SchemaTable Foo.table] + + length (AutoMigration.migrationPlanSteps firstTimePlan) === 1 + PgAssert.assertTableDoesNotHaveComment pool (Orville.tableIdUnqualifiedNameString fooTableId) + migrationPlanStepStrings secondTimePlan === [] + +prop_modifiesTableComment :: Property.NamedDBProperty +prop_modifiesTableComment = + Property.singletonNamedDBProperty "Modifies the comment on a table" $ \pool -> do + let + oldComment = String.fromString "This is a comment" + newComment = String.fromString "This is a new comment" + + fooTableId = + Orville.tableIdentifier Foo.table + + fooTableWithNewComment = Orville.setTableComment newComment Foo.table + + HH.evalIO $ + Orville.runOrville pool $ do + Orville.executeVoid Orville.DDLQuery $ TestTable.dropTableDefSql Foo.table + Orville.executeVoid Orville.DDLQuery $ Schema.mkCreateTableExpr Foo.table + Orville.executeVoid Orville.DDLQuery $ Expr.commentTableExpr (Orville.tableName Foo.table) (Just $ Expr.commentText oldComment) + + PgAssert.assertTableHasComment pool (Orville.tableIdUnqualifiedNameString fooTableId) oldComment + + firstTimePlan <- + HH.evalIO $ + Orville.runOrville pool $ + AutoMigration.generateMigrationPlan AutoMigration.defaultOptions [AutoMigration.SchemaTable fooTableWithNewComment] + + secondTimePlan <- + HH.evalIO $ + Orville.runOrville pool $ do + AutoMigration.executeMigrationPlan AutoMigration.defaultOptions firstTimePlan + AutoMigration.generateMigrationPlan AutoMigration.defaultOptions [AutoMigration.SchemaTable fooTableWithNewComment] + + length (AutoMigration.migrationPlanSteps firstTimePlan) === 1 + PgAssert.assertTableHasComment pool (Orville.tableIdUnqualifiedNameString fooTableId) newComment + migrationPlanStepStrings secondTimePlan === [] + +prop_addsColumnCommmentsOnCreateTable :: Property.NamedDBProperty +prop_addsColumnCommmentsOnCreateTable = + Property.singletonNamedDBProperty "Adds column comments when creating table" $ \pool -> do + let + columnsAndComments = [("foo", Just "foo comment"), ("bar", Nothing), ("baz", Just "baz comment")] + tableName = "migration_test" + tableDef = mkIntListTableWithComments tableName columnsAndComments + + firstTimePlan <- + HH.evalIO $ + Orville.runOrville pool $ do + Orville.executeVoid Orville.DDLQuery $ TestTable.dropTableDefSql tableDef + AutoMigration.generateMigrationPlan AutoMigration.defaultOptions [AutoMigration.SchemaTable tableDef] + + secondTimePlan <- + HH.evalIO $ + Orville.runOrville pool $ do + AutoMigration.executeMigrationPlan AutoMigration.defaultOptions firstTimePlan + AutoMigration.generateMigrationPlan AutoMigration.defaultOptions [AutoMigration.SchemaTable tableDef] + + length (AutoMigration.migrationPlanSteps firstTimePlan) === 3 + PgAssert.assertTableColumnsHaveOrDoNotHaveComments pool tableName columnsAndComments + migrationPlanStepStrings secondTimePlan === [] + +prop_modifiesColumnComments :: Property.NamedDBProperty +prop_modifiesColumnComments = + Property.singletonNamedDBProperty "Modifies column comments" $ \pool -> do + let + initialColumnsAndComments = [("foo", Just "foo comment"), ("bar", Nothing), ("baz", Nothing)] + finalColumnsAndComments = [("foo", Nothing), ("bar", Just "bar comment"), ("baz", Just "baz comment")] + tableName = "migration_test" + initialTableDef = mkIntListTableWithComments tableName initialColumnsAndComments + finalTableDef = mkIntListTableWithComments tableName finalColumnsAndComments + + firstTimePlan <- + HH.evalIO $ + Orville.runOrville pool $ do + Orville.executeVoid Orville.DDLQuery $ TestTable.dropTableDefSql initialTableDef + Orville.executeVoid Orville.DDLQuery $ Schema.mkCreateTableExpr initialTableDef + AutoMigration.generateMigrationPlan AutoMigration.defaultOptions [AutoMigration.SchemaTable initialTableDef] + + MIO.liftIO . Orville.runOrville pool $ + AutoMigration.executeMigrationPlan AutoMigration.defaultOptions firstTimePlan + PgAssert.assertTableColumnsHaveOrDoNotHaveComments pool tableName initialColumnsAndComments + + secondTimePlan <- + HH.evalIO . Orville.runOrville pool $ + AutoMigration.generateMigrationPlan AutoMigration.defaultOptions [AutoMigration.SchemaTable finalTableDef] + + MIO.liftIO . Orville.runOrville pool $ + AutoMigration.executeMigrationPlan AutoMigration.defaultOptions secondTimePlan + PgAssert.assertTableColumnsHaveOrDoNotHaveComments pool tableName finalColumnsAndComments + + length (AutoMigration.migrationPlanSteps firstTimePlan) === 1 + length (AutoMigration.migrationPlanSteps secondTimePlan) === 3 + prop_addsAndRemovesColumns :: Property.NamedDBProperty prop_addsAndRemovesColumns = - Property.namedDBProperty "Adds and removes columns columns" $ \pool -> do + Property.namedDBProperty "Adds and removes columns" $ \pool -> do let genColumnList = Gen.subsequence ["foo", "bar", "baz", "bat", "bax"] @@ -233,8 +402,7 @@ HH.annotate "Expected migration to fail, but it did not" HH.failure -{- | - Migration Guide: @SomeField@ has been removed. @foldMarshallerFields@ can be +{- | Migration Guide: @SomeField@ has been removed. @foldMarshallerFields@ can be used to collect data from the fields in a @SqlMarshaller@ while converting the results to whatever type you desire. @@ -356,6 +524,46 @@ , SomeField <$> genFieldWithMaybeDefault genDefaultDouble Orville.doubleDefault (Orville.doubleField "column") ] +prop_altersColumnAddIdentity :: Property.NamedDBProperty +prop_altersColumnAddIdentity = + Property.namedDBProperty "Alters an existing column to add IDENTITY" $ \pool -> do + colIdentity <- HH.forAll Gen.enumBounded + + let + originalField = Orville.integerField "column" + newField = Orville.markAsIdentity colIdentity originalField + originalTableDef = + Orville.mkTableDefinitionWithoutKey + "migration_test" + (Orville.marshallField id originalField) + + newTableDef = + Orville.mkTableDefinitionWithoutKey + "migration_test" + (Orville.marshallField id newField) + + firstTimePlan <- + HH.evalIO + . Orville.runOrville pool + $ do + Orville.executeVoid Orville.DDLQuery $ TestTable.dropTableDefSql originalTableDef + Orville.executeVoid Orville.DDLQuery $ Schema.mkCreateTableExpr originalTableDef + AutoMigration.generateMigrationPlan AutoMigration.defaultOptions [AutoMigration.SchemaTable newTableDef] + + originalTableDesc <- PgAssert.assertTableExists pool "migration_test" + + secondTimePlan <- + HH.evalIO + . Orville.runOrville pool + $ do + AutoMigration.executeMigrationPlan AutoMigration.defaultOptions firstTimePlan + AutoMigration.generateMigrationPlan AutoMigration.defaultOptions [AutoMigration.SchemaTable newTableDef] + + PgAssert.assertFieldIdentityGenerationMatches originalTableDesc "column" Nothing + newTableDesc <- PgAssert.assertTableExists pool "migration_test" + PgAssert.assertFieldIdentityGenerationMatches newTableDesc "column" (Just colIdentity) + migrationPlanStepStrings secondTimePlan === [] + prop_altersColumnDefaultValue_Bool :: Property.NamedDBProperty prop_altersColumnDefaultValue_Bool = Property.namedDBProperty "Alters default value on existing column (boolean)" $ \pool -> do @@ -654,11 +862,22 @@ Orville.addTableIndexes originalIndexes $ mkIntListTable "migration_test" originalColumns + originalTableDefWithSchema = + TableDefinition.setTableSchema "orville_migration_schema" $ + Orville.addTableIndexes originalIndexes $ + mkIntListTable "migration_test" originalColumns + newTableDef = Orville.addTableIndexes newIndexes $ Orville.dropColumns columnsToDrop $ mkIntListTable "migration_test" newColumns + newTableDefWithSchema = + TableDefinition.setTableSchema "orville_migration_schema" $ + Orville.addTableIndexes newIndexes $ + Orville.dropColumns columnsToDrop $ + mkIntListTable "migration_test" newColumns + HH.cover 5 (String.fromString "Adding Indexes") (not $ null (newTestIndexes \\ originalTestIndexes)) HH.cover 5 (String.fromString "Dropping Indexes") (not $ null (originalTestIndexes \\ newTestIndexes)) HH.cover @@ -672,9 +891,11 @@ firstTimePlan <- HH.evalIO $ Orville.runOrville pool $ do + Orville.executeVoid Orville.DDLQuery $ RawSql.fromString "DROP SCHEMA IF EXISTS orville_migration_schema CASCADE" + Orville.executeVoid Orville.DDLQuery $ RawSql.fromString "CREATE SCHEMA orville_migration_schema" Orville.executeVoid Orville.DDLQuery $ TestTable.dropTableDefSql originalTableDef - AutoMigration.autoMigrateSchema AutoMigration.defaultOptions [AutoMigration.SchemaTable originalTableDef] - AutoMigration.generateMigrationPlan AutoMigration.defaultOptions [AutoMigration.SchemaTable newTableDef] + AutoMigration.autoMigrateSchema AutoMigration.defaultOptions [AutoMigration.SchemaTable originalTableDef, AutoMigration.SchemaTable originalTableDefWithSchema] + AutoMigration.generateMigrationPlan AutoMigration.defaultOptions [AutoMigration.SchemaTable newTableDef, AutoMigration.SchemaTable newTableDefWithSchema] HH.annotate ("First time migration steps: " <> show (migrationPlanStepStrings firstTimePlan)) @@ -683,20 +904,34 @@ (PgAssert.assertIndexExists originalTableDesc <$> testIndexUniqueness <*> testIndexColumns) originalTestIndexes + originalTableWithSchemaDesc <- PgAssert.assertTableExistsInSchema pool "orville_migration_schema" "migration_test" + Fold.traverse_ + (PgAssert.assertIndexExists originalTableWithSchemaDesc <$> testIndexUniqueness <*> testIndexColumns) + originalTestIndexes + secondTimePlan <- HH.evalIO $ Orville.runOrville pool $ do AutoMigration.executeMigrationPlan AutoMigration.defaultOptions firstTimePlan - AutoMigration.generateMigrationPlan AutoMigration.defaultOptions [AutoMigration.SchemaTable newTableDef] + AutoMigration.generateMigrationPlan + AutoMigration.defaultOptions + [AutoMigration.SchemaTable newTableDef, AutoMigration.SchemaTable newTableDefWithSchema] migrationPlanStepStrings secondTimePlan === [] + newTableDesc <- PgAssert.assertTableExists pool "migration_test" + newTableWithSchemaDesc <- PgAssert.assertTableExistsInSchema pool "orville_migration_schema" "migration_test" Fold.traverse_ (PgAssert.assertIndexExists newTableDesc <$> testIndexUniqueness <*> testIndexColumns) newTestIndexes length (PgCatalog.relationIndexes newTableDesc) === length (List.nub newTestIndexes) + Fold.traverse_ + (PgAssert.assertIndexExists newTableWithSchemaDesc <$> testIndexUniqueness <*> testIndexColumns) + newTestIndexes + length (PgCatalog.relationIndexes newTableWithSchemaDesc) === length (List.nub newTestIndexes) + prop_createsMissingSequences :: Property.NamedDBProperty prop_createsMissingSequences = Property.singletonNamedDBProperty "Creates missing sequences" $ \pool -> do @@ -727,7 +962,7 @@ prop_dropsRequestedSequences :: Property.NamedDBProperty prop_dropsRequestedSequences = - Property.singletonNamedDBProperty "Drops requested tables" $ \pool -> do + Property.singletonNamedDBProperty "Drops requested sequences" $ \pool -> do let sequenceDef = Orville.mkSequenceDefinition "migration_test_sequence" @@ -884,6 +1119,258 @@ migrationPlanStepStrings migrationPlanAfterMigration === [] Fold.traverse_ (assertTableStructure pool) testTables +prop_createsMissingFunctions :: Property.NamedDBProperty +prop_createsMissingFunctions = + Property.singletonNamedDBProperty "Creates missing functions" $ \pool -> do + let + functionDef = + Orville.mkTriggerFunction + "test_create_function" + Orville.plpgsql + "BEGIN return NEW; END" + + functionId = + Orville.functionIdentifier functionDef + + firstTimePlan <- + HH.evalIO $ + Orville.runOrville pool $ do + Orville.executeVoid Orville.DDLQuery $ + Expr.dropFunction + (Just Expr.ifExists) + (Orville.functionName functionDef) + AutoMigration.generateMigrationPlan AutoMigration.defaultOptions [AutoMigration.SchemaFunction functionDef] + + secondTimePlan <- + HH.evalIO $ + Orville.runOrville pool $ do + AutoMigration.executeMigrationPlan AutoMigration.defaultOptions firstTimePlan + AutoMigration.generateMigrationPlan AutoMigration.defaultOptions [AutoMigration.SchemaFunction functionDef] + + length (AutoMigration.migrationPlanSteps firstTimePlan) === 1 + + proc <- PgAssert.assertFunctionExists pool (Orville.functionIdUnqualifiedNameString functionId) + PgCatalog.pgProcSource proc === T.pack "BEGIN return NEW; END" + + migrationPlanStepStrings secondTimePlan === [] + +prop_recreatesAlteredFunctions :: Property.NamedDBProperty +prop_recreatesAlteredFunctions = + Property.singletonNamedDBProperty "Recreates functions with altered source code" $ \pool -> do + let + oldFunctionDef = + Orville.mkTriggerFunction + "test_recreate_function" + Orville.plpgsql + "BEGIN return OLD; END" + + newFunctionDef = + Orville.mkTriggerFunction + "test_recreate_function" + Orville.plpgsql + "BEGIN return NEW; END" + + functionId = + Orville.functionIdentifier oldFunctionDef + + firstTimePlan <- + HH.evalIO $ + Orville.runOrville pool $ do + Orville.executeVoid Orville.DDLQuery $ + Expr.dropFunction (Just Expr.ifExists) (Orville.functionName oldFunctionDef) + AutoMigration.autoMigrateSchema AutoMigration.defaultOptions [AutoMigration.SchemaFunction oldFunctionDef] + AutoMigration.generateMigrationPlan AutoMigration.defaultOptions [AutoMigration.SchemaFunction newFunctionDef] + + secondTimePlan <- + HH.evalIO $ + Orville.runOrville pool $ do + AutoMigration.executeMigrationPlan AutoMigration.defaultOptions firstTimePlan + AutoMigration.generateMigrationPlan AutoMigration.defaultOptions [AutoMigration.SchemaFunction newFunctionDef] + + length (AutoMigration.migrationPlanSteps firstTimePlan) === 1 + + proc <- PgAssert.assertFunctionExists pool (Orville.functionIdUnqualifiedNameString functionId) + PgCatalog.pgProcSource proc === T.pack "BEGIN return NEW; END" + + migrationPlanStepStrings secondTimePlan === [] + +prop_dropsRequestedFunctions :: Property.NamedDBProperty +prop_dropsRequestedFunctions = + Property.singletonNamedDBProperty "Drops requested functions" $ \pool -> do + let + functionDef = + Orville.mkTriggerFunction + "test_drop_function" + Orville.plpgsql + "BEGIN return NEW; END" + + functionId = + Orville.functionIdentifier functionDef + + firstTimePlan <- + HH.evalIO $ + Orville.runOrville pool $ do + Orville.executeVoid Orville.DDLQuery $ Orville.mkCreateFunctionExpr functionDef (Just Expr.orReplace) + AutoMigration.generateMigrationPlan AutoMigration.defaultOptions [AutoMigration.SchemaDropFunction functionId] + + secondTimePlan <- + HH.evalIO $ + Orville.runOrville pool $ do + AutoMigration.executeMigrationPlan AutoMigration.defaultOptions firstTimePlan + AutoMigration.generateMigrationPlan AutoMigration.defaultOptions [AutoMigration.SchemaDropFunction functionId] + + length (AutoMigration.migrationPlanSteps firstTimePlan) === 1 + PgAssert.assertFunctionDoesNotExist pool (Orville.functionIdUnqualifiedNameString functionId) + migrationPlanStepStrings secondTimePlan === [] + +prop_createsMissingTriggers :: Property.NamedDBProperty +prop_createsMissingTriggers = + Property.singletonNamedDBProperty "Creates missing triggers" $ \pool -> do + let + functionDef = + Orville.mkTriggerFunction + "test_create_trigger_function" + Orville.plpgsql + "BEGIN return NEW; END" + + testTrigger = + Orville.beforeInsert + "before_insert_trigger" + (Orville.functionName functionDef) + + tableWithTrigger = + Orville.addTableTriggers [testTrigger] Foo.table + + schemaItems = + [ AutoMigration.SchemaFunction functionDef + , AutoMigration.SchemaTable tableWithTrigger + ] + + firstTimePlan <- + HH.evalIO $ + Orville.runOrville pool $ do + Orville.executeVoid Orville.DDLQuery $ TestTable.dropTableDefSql tableWithTrigger + Orville.executeVoid Orville.DDLQuery $ Expr.dropFunction (Just Expr.ifExists) (Orville.functionName functionDef) + AutoMigration.generateMigrationPlan AutoMigration.defaultOptions schemaItems + + secondTimePlan <- + HH.evalIO $ + Orville.runOrville pool $ do + AutoMigration.executeMigrationPlan AutoMigration.defaultOptions firstTimePlan + AutoMigration.generateMigrationPlan AutoMigration.defaultOptions schemaItems + + length (AutoMigration.migrationPlanSteps firstTimePlan) === 3 + + fooRelation <- PgAssert.assertTableExists pool "foo" + _ <- PgAssert.assertTriggerExists fooRelation "before_insert_trigger" + + migrationPlanStepStrings secondTimePlan === [] + +prop_dropsUnrequestedTriggers :: Property.NamedDBProperty +prop_dropsUnrequestedTriggers = + Property.singletonNamedDBProperty "Drops unrequested triggers" $ \pool -> do + let + functionDef = + Orville.mkTriggerFunction + "test_drop_trigger_function" + Orville.plpgsql + "BEGIN return NEW; END" + + testTrigger = + Orville.beforeInsert + "before_insert_trigger" + (Orville.functionName functionDef) + + tableWithoutTrigger = + Foo.table + + tableWithTrigger = + Orville.addTableTriggers [testTrigger] tableWithoutTrigger + + schemaItemsWithTrigger = + [ AutoMigration.SchemaFunction functionDef + , AutoMigration.SchemaTable tableWithTrigger + ] + + schemaItemsWithoutTrigger = + [ AutoMigration.SchemaFunction functionDef + , AutoMigration.SchemaTable tableWithoutTrigger + ] + + firstTimePlan <- + HH.evalIO $ + Orville.runOrville pool $ do + Orville.executeVoid Orville.DDLQuery $ TestTable.dropTableDefSql tableWithoutTrigger + Orville.executeVoid Orville.DDLQuery $ Expr.dropFunction (Just Expr.ifExists) (Orville.functionName functionDef) + AutoMigration.autoMigrateSchema AutoMigration.defaultOptions schemaItemsWithTrigger + AutoMigration.generateMigrationPlan AutoMigration.defaultOptions schemaItemsWithoutTrigger + + secondTimePlan <- + HH.evalIO $ + Orville.runOrville pool $ do + AutoMigration.executeMigrationPlan AutoMigration.defaultOptions firstTimePlan + AutoMigration.generateMigrationPlan AutoMigration.defaultOptions schemaItemsWithoutTrigger + + length (AutoMigration.migrationPlanSteps firstTimePlan) === 1 + fooRelation <- PgAssert.assertTableExists pool "foo" + _ <- PgAssert.assertTriggerDoesNotExist fooRelation "before_insert_trigger" + migrationPlanStepStrings secondTimePlan === [] + +prop_loadsMissingExtensions :: Property.NamedDBProperty +prop_loadsMissingExtensions = + Property.singletonNamedDBProperty "Loads missing extensions" $ \pool -> do + let + schemaItems = + [ AutoMigration.SchemaExtension $ Orville.nameToExtensionId "pg_trgm" + ] + + firstTimePlan <- + HH.evalIO $ + Orville.runOrville pool $ do + Orville.executeVoid Orville.DDLQuery $ Expr.dropExtensionExpr (Expr.extensionName "pg_trgm") (Just Expr.ifExists) Nothing + AutoMigration.generateMigrationPlan AutoMigration.defaultOptions schemaItems + + secondTimePlan <- + HH.evalIO $ + Orville.runOrville pool $ do + AutoMigration.executeMigrationPlan AutoMigration.defaultOptions firstTimePlan + AutoMigration.generateMigrationPlan AutoMigration.defaultOptions schemaItems + + length (AutoMigration.migrationPlanSteps firstTimePlan) === 1 + _ <- PgAssert.assertExtensionLoaded pool "pg_trgm" + migrationPlanStepStrings secondTimePlan === [] + +prop_unloadsPresentExtensions :: Property.NamedDBProperty +prop_unloadsPresentExtensions = + Property.singletonNamedDBProperty "Unloads present extensions" $ \pool -> do + let + pgtrgmExtension = Orville.nameToExtensionId "pg_trgm" + + schemaItemsLoadExtension = + [ AutoMigration.SchemaExtension pgtrgmExtension + ] + + schemaItemsUnloadExtension = + [ AutoMigration.SchemaDropExtension pgtrgmExtension + ] + + firstTimePlan <- + HH.evalIO $ + Orville.runOrville pool $ do + AutoMigration.autoMigrateSchema AutoMigration.defaultOptions schemaItemsLoadExtension + AutoMigration.generateMigrationPlan AutoMigration.defaultOptions schemaItemsUnloadExtension + + secondTimePlan <- + HH.evalIO $ + Orville.runOrville pool $ do + AutoMigration.executeMigrationPlan AutoMigration.defaultOptions firstTimePlan + AutoMigration.generateMigrationPlan AutoMigration.defaultOptions schemaItemsUnloadExtension + + length (AutoMigration.migrationPlanSteps firstTimePlan) === 1 + PgAssert.assertExtensionNotLoaded pool "pg_trgm" + + migrationPlanStepStrings secondTimePlan === [] + assertTableStructure :: (HH.MonadTest m, MIO.MonadIO m) => Orville.ConnectionPool -> @@ -905,8 +1392,8 @@ (testTableUniqueConstraints testTable) Fold.traverse_ - (PgAssert.assertForeignKeyConstraintExists tableDesc) - (map mkForeignKeyInfo . testTableForeignKeys $ testTable) + (PgAssert.assertForeignKeyConstraintExists tableDesc . mkForeignKeyInfo) + (testTableForeignKeys testTable) mkForeignKeyInfo :: TestForeignKey -> PgAssert.ForeignKeyInfo mkForeignKeyInfo testForeignKey = @@ -991,9 +1478,8 @@ tableName <- PgGen.pgIdentifierWithPrefix "t_" 1 - TestTable tableName - <$> pure columns - <*> Gen.subsequence columns + TestTable tableName columns + <$> Gen.subsequence columns <*> generateTestIndexes columns tableName <*> generateTestUniqueConstraints columns <*> pure [] -- No foreign keys can be generated until we've generate test tables @@ -1166,14 +1652,23 @@ List.nub <$> Gen.list (Range.constant 0 10) PgGen.pgIdentifier mkIntListTable :: String -> [String] -> Orville.TableDefinition Orville.NoKey [Int32] [Int32] -mkIntListTable tableName columns = - Orville.mkTableDefinitionWithoutKey tableName (intColumnsMarshaller columns) +mkIntListTable tableName = + mkIntListTableWithComments tableName . fmap (\c -> (c, Nothing)) +mkIntListTableWithComments :: String -> [(String, Maybe String)] -> Orville.TableDefinition Orville.NoKey [Int32] [Int32] +mkIntListTableWithComments tableName columnsAndComments = + Orville.mkTableDefinitionWithoutKey tableName (intColumnsMarshallerWithComments columnsAndComments) + intColumnsMarshaller :: [String] -> Orville.SqlMarshaller [Int32] [Int32] -intColumnsMarshaller columns = +intColumnsMarshaller = intColumnsMarshallerWithComments . fmap (\c -> (c, Nothing)) + +intColumnsMarshallerWithComments :: [(String, Maybe String)] -> Orville.SqlMarshaller [Int32] [Int32] +intColumnsMarshallerWithComments columns = let - field (idx, column) = - Orville.marshallField (!! idx) $ Orville.integerField column + field (idx, (column, mbComment)) = + Orville.marshallField (!! idx) + . maybe id Orville.setFieldDescription mbComment + $ Orville.integerField column in traverse field (zip [0 ..] columns) diff --git a/test/Test/Connection.hs b/test/Test/Connection.hs --- a/test/Test/Connection.hs +++ b/test/Test/Connection.hs @@ -27,6 +27,7 @@ , prop_errorOnSafeNulByte pool , prop_truncateValuesAtUnsafeNulByte pool , prop_errorOnInvalidSql pool + , prop_returningAConnectionToPoolWithOpenTransactionCausesException pool ] prop_safeOrUnsafeNonNullBytes :: Property.NamedDBProperty @@ -137,4 +138,21 @@ Conn.sqlExecutionErrorSqlState err === Just syntaxErrorState Right _ -> do HH.footnote "Expected 'executeRow' to return failure, but it did not" + HH.failure + +prop_returningAConnectionToPoolWithOpenTransactionCausesException :: Property.NamedDBProperty +prop_returningAConnectionToPoolWithOpenTransactionCausesException = + Property.singletonNamedDBProperty "returning a connection to the pool with an open transaction causes an exception" $ \pool -> do + result <- + MIO.liftIO . E.try . Conn.withPoolConnection pool $ \connection -> + Conn.executeRaw + connection + (B8.pack "BEGIN TRANSACTION") + [] + + case result of + Left (_err :: Conn.ConnectionError) -> + pure () + Right _ -> do + HH.footnote "Expected 'withPoolConnection' to return failure, but it did not" HH.failure diff --git a/test/Test/Entities/Bar.hs b/test/Test/Entities/Bar.hs --- a/test/Test/Entities/Bar.hs +++ b/test/Test/Entities/Bar.hs @@ -1,5 +1,6 @@ module Test.Entities.Bar ( Bar (..) + , BarId , table , generate , generateList @@ -49,7 +50,8 @@ barNameField :: Orville.FieldDefinition Orville.NotNull BarName barNameField = - Orville.unboundedTextField "name" + Orville.setDefaultValue (Orville.textDefault $ T.pack "default") $ + Orville.unboundedTextField "name" generate :: HH.Gen BarWrite generate = diff --git a/test/Test/Entities/Foo.hs b/test/Test/Entities/Foo.hs --- a/test/Test/Entities/Foo.hs +++ b/test/Test/Entities/Foo.hs @@ -1,13 +1,18 @@ +{-# LANGUAGE CPP #-} + module Test.Entities.Foo ( Foo (..) , FooId , FooName + , FooAge , table , generate , generateFooWithName + , generateFooWithNameAndAge , generateFooWithId , generateFooId , generateFooName + , generateFooAge , generateList , generateListUsing , generateNonEmpty @@ -16,10 +21,16 @@ , fooNameField , fooAgeField , hasName + , hasAge , averageFooAge + , nameAndAgeMarshaller ) where +#if MIN_VERSION_base(4,18,0) +#else +import Control.Applicative (liftA2) +#endif import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.Function (on) import Data.Int (Int32) @@ -90,6 +101,13 @@ <*> pure name <*> generateFooAge +generateFooWithNameAndAge :: FooName -> FooAge -> HH.Gen Foo +generateFooWithNameAndAge name age = + Foo + <$> generateFooId + <*> pure name + <*> pure age + generateFooId :: HH.Gen FooId generateFooId = PgGen.pgInt32 @@ -116,6 +134,10 @@ hasName name foo = fooName foo == name +hasAge :: FooAge -> Foo -> Bool +hasAge age foo = + fooAge foo == age + generateList :: HH.Range Int -> HH.Gen [Foo] generateList = flip generateListUsing generate @@ -138,3 +160,10 @@ Conn.withPoolConnection pool $ \connection -> TestTable.dropAndRecreateTableDef connection table Orville.runOrville pool operation + +nameAndAgeMarshaller :: Orville.SqlMarshaller (FooName, FooAge) (FooName, FooAge) +nameAndAgeMarshaller = + liftA2 + (,) + (Orville.marshallField fst fooNameField) + (Orville.marshallField snd fooAgeField) diff --git a/test/Test/Expr/Aggregate.hs b/test/Test/Expr/Aggregate.hs new file mode 100644 --- /dev/null +++ b/test/Test/Expr/Aggregate.hs @@ -0,0 +1,163 @@ +module Test.Expr.Aggregate + ( aggregateTests + ) +where + +import qualified Control.Monad.IO.Class as MIO +import qualified Data.ByteString.Char8 as B8 +import qualified Data.Int as Int +import qualified Data.List.NonEmpty as NE +import qualified Data.Text as T +import qualified Hedgehog as HH + +import qualified Orville.PostgreSQL as Orville +import qualified Orville.PostgreSQL.Execution as Execution +import qualified Orville.PostgreSQL.Expr as Expr +import qualified Orville.PostgreSQL.Raw.Connection as Conn +import qualified Orville.PostgreSQL.Raw.RawSql as RawSql +import qualified Orville.PostgreSQL.Raw.SqlValue as SqlValue + +import qualified Test.Property as Property + +data FooBar = FooBar + { foo :: Int.Int32 + , bar :: String + } + +newtype DoubleRes = DoubleRes + {doubleRes :: Double} + +aggregateTests :: Orville.ConnectionPool -> Property.Group +aggregateTests pool = + Property.group + "Expr - Aggregate" + [ prop_avgAggregate pool + , prop_maxAggregate pool + , prop_minAggregate pool + , prop_sumAggregate pool + ] + +prop_avgAggregate :: Property.NamedDBProperty +prop_avgAggregate = + aggregateFunctionTest "avgAggregateFunction computes simple average" $ + AggregateTest + { valuesToInsert = NE.fromList [FooBar 1 "dog", FooBar 2 "dingo", FooBar 3 "dog"] + , groupByExpectedQueryResults = + [ DoubleRes 2.00000 + ] + , aggregateFunctionExpr = + Expr.avgAggregateFunction + Nothing + (Expr.columnReference fooColumn) + Nothing + Nothing + } + +prop_maxAggregate :: Property.NamedDBProperty +prop_maxAggregate = + aggregateFunctionTest "maxAggregateFunction computes maximum" $ + AggregateTest + { valuesToInsert = NE.fromList [FooBar 1 "dog", FooBar 2 "dingo", FooBar 3 "dog"] + , groupByExpectedQueryResults = + [ DoubleRes 3.0 + ] + , aggregateFunctionExpr = + Expr.maxAggregateFunction + Nothing + (Expr.columnReference fooColumn) + Nothing + Nothing + } + +prop_minAggregate :: Property.NamedDBProperty +prop_minAggregate = + aggregateFunctionTest "minAggregateFunction computes minimum" $ + AggregateTest + { valuesToInsert = NE.fromList [FooBar 1 "dog", FooBar 2 "dingo", FooBar 3 "dog"] + , groupByExpectedQueryResults = + [ DoubleRes 1.0 + ] + , aggregateFunctionExpr = + Expr.minAggregateFunction + Nothing + (Expr.columnReference fooColumn) + Nothing + Nothing + } + +prop_sumAggregate :: Property.NamedDBProperty +prop_sumAggregate = + aggregateFunctionTest "sumAggregateFunction computes simple sum" $ + AggregateTest + { valuesToInsert = NE.fromList [FooBar 1 "dog", FooBar 2 "dingo", FooBar 3 "dog"] + , groupByExpectedQueryResults = + [ DoubleRes 6.0 + ] + , aggregateFunctionExpr = + Expr.sumAggregateFunction + Nothing + (Expr.columnReference fooColumn) + Nothing + Nothing + } + +data AggregateTest = AggregateTest + { valuesToInsert :: NE.NonEmpty FooBar + , aggregateFunctionExpr :: Expr.ValueExpression + , groupByExpectedQueryResults :: [DoubleRes] + } + +aggregateFunctionTest :: String -> AggregateTest -> Property.NamedDBProperty +aggregateFunctionTest testName test = + Property.singletonNamedDBProperty testName $ \pool -> do + rows <- MIO.liftIO . Conn.withPoolConnection pool $ \connection -> do + dropAndRecreateTestTable connection + + RawSql.executeVoid connection $ + Expr.insertExpr testTable Nothing (mkAggregateTestInsertSource test) Nothing Nothing + + result <- + RawSql.execute connection $ + Expr.queryExpr + (Expr.selectClause $ Expr.selectExpr Nothing) + (Expr.selectDerivedColumns . pure $ Expr.deriveColumnAs (aggregateFunctionExpr test) (RawSql.unsafeFromRawSql $ RawSql.fromString "agg")) + (Just $ Expr.tableExpr (Expr.singleTableReferenceList testTable) Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing) + + Execution.readRows result + + ((fmap . fmap . fmap) SqlValue.toDouble rows) HH.=== ((fmap . fmap . fmap) SqlValue.toDouble $ mkAggregateTestExpectedRows test) + +mkAggregateTestInsertSource :: AggregateTest -> Expr.InsertSource +mkAggregateTestInsertSource test = + let + mkRow foobar = + NE.fromList + [ Expr.valueExpression $ SqlValue.fromInt32 (foo foobar) + , Expr.valueExpression $ SqlValue.fromText (T.pack $ bar foobar) + ] + in + Expr.valuesExprInsertSource + . Expr.valuesExprFromValueExpressions + $ fmap mkRow (valuesToInsert test) + +mkAggregateTestExpectedRows :: AggregateTest -> [[(Maybe B8.ByteString, SqlValue.SqlValue)]] +mkAggregateTestExpectedRows test = + let + mkRow res = + [ (Just (B8.pack "agg"), SqlValue.fromDouble (doubleRes res)) + ] + in + fmap mkRow (groupByExpectedQueryResults test) + +testTable :: Expr.QualifiedOrUnqualified Expr.TableName +testTable = + Expr.unqualified (Expr.tableName "expr_test") + +fooColumn :: Expr.QualifiedOrUnqualified Expr.ColumnName +fooColumn = + Expr.unqualified (Expr.columnName "foo") + +dropAndRecreateTestTable :: Orville.Connection -> IO () +dropAndRecreateTestTable connection = do + RawSql.executeVoid connection (RawSql.fromString "DROP TABLE IF EXISTS " <> RawSql.toRawSql testTable) + RawSql.executeVoid connection (RawSql.fromString "CREATE TABLE " <> RawSql.toRawSql testTable <> RawSql.fromString "(foo INTEGER, bar TEXT)") diff --git a/test/Test/Expr/ConditionalExpr.hs b/test/Test/Expr/ConditionalExpr.hs new file mode 100644 --- /dev/null +++ b/test/Test/Expr/ConditionalExpr.hs @@ -0,0 +1,75 @@ +module Test.Expr.ConditionalExpr + ( conditionalTests + ) +where + +import qualified Data.ByteString.Char8 as B8 +import qualified Data.List.NonEmpty as NE +import GHC.Stack (HasCallStack, withFrozenCallStack) +import qualified Hedgehog as HH + +import qualified Orville.PostgreSQL.Expr as Expr +import qualified Orville.PostgreSQL.Raw.RawSql as RawSql +import qualified Orville.PostgreSQL.Raw.SqlValue as SqlValue + +import qualified Test.Property as Property + +conditionalTests :: Property.Group +conditionalTests = + Property.group + "Expr - Conditional" + [ prop_caseWithNoElse + , prop_caseWithElse + , prop_caseMultipleWhenWithElse + ] + +prop_caseWithNoElse :: Property.NamedProperty +prop_caseWithNoElse = + let + whenTrueThen1 = + Expr.whenExpr (Expr.literalBooleanExpr True) (Expr.valueExpression $ SqlValue.fromInt32 1) + caseExpr = Expr.caseExpr (pure whenTrueThen1) Nothing + in + Property.singletonNamedProperty "caseExpr with a trivial WHEN and no ELSE generates expected sql." $ + assertConditionalEquals + "CASE WHEN TRUE THEN $1 END" + caseExpr + +prop_caseWithElse :: Property.NamedProperty +prop_caseWithElse = + let + firstEqualsSecond = + Expr.equals (Expr.valueExpression $ SqlValue.fromInt32 1) (Expr.valueExpression $ SqlValue.fromInt32 1) + whenExpr = + Expr.whenExpr firstEqualsSecond (Expr.valueExpression $ SqlValue.fromInt32 1) + caseExpr = Expr.caseExpr (pure whenExpr) (Just . Expr.valueExpression $ SqlValue.fromInt32 1) + in + Property.singletonNamedProperty "caseExpr with a simple WHEN and simple ELSE generates expected sql." $ + assertConditionalEquals + "CASE WHEN ($1) = ($2) THEN $3 ELSE $4 END" + caseExpr + +prop_caseMultipleWhenWithElse :: Property.NamedProperty +prop_caseMultipleWhenWithElse = + let + firstVal = Expr.valueExpression $ SqlValue.fromInt32 1 + secondVal = Expr.valueExpression $ SqlValue.fromInt32 1 + firstGreaterSecond = + Expr.greaterThan firstVal secondVal + firstLessSecond = + Expr.lessThan firstVal secondVal + whenGreaterExpr = + Expr.whenExpr firstGreaterSecond (Expr.valueExpression $ SqlValue.fromInt32 1) + whenLessExpr = + Expr.whenExpr firstLessSecond (Expr.valueExpression $ SqlValue.fromInt32 1) + caseExpr = Expr.caseExpr (whenGreaterExpr NE.:| [whenLessExpr]) (Just . Expr.valueExpression $ SqlValue.fromInt32 1) + in + Property.singletonNamedProperty "caseExpr with a simple WHEN and simple ELSE generates expected sql." $ + assertConditionalEquals + "CASE WHEN ($1) > ($2) THEN $3 WHEN ($4) < ($5) THEN $6 ELSE $7 END" + caseExpr + +assertConditionalEquals :: (HH.MonadTest m, HasCallStack) => String -> Expr.ValueExpression -> m () +assertConditionalEquals valueExpressionStr valueExpr = + withFrozenCallStack $ + RawSql.toExampleBytes valueExpr HH.=== B8.pack valueExpressionStr diff --git a/test/Test/Expr/Count.hs b/test/Test/Expr/Count.hs --- a/test/Test/Expr/Count.hs +++ b/test/Test/Expr/Count.hs @@ -32,7 +32,7 @@ Expr.queryExpr (Expr.selectClause (Expr.selectExpr Nothing)) ( Expr.selectDerivedColumns - [ Expr.deriveColumnAs Expr.count1 (Expr.columnName "count") + [ Expr.deriveColumnAs Expr.count1AggregateFunction (Expr.columnName "count") ] ) Nothing @@ -57,11 +57,23 @@ (Expr.selectClause (Expr.selectExpr Nothing)) ( Expr.selectDerivedColumns [ Expr.deriveColumnAs - (Expr.countColumn (Orville.fieldColumnName Foo.fooIdField)) + (Expr.countColumnAggregateFunction . Expr.unqualified $ Orville.fieldColumnName Foo.fooIdField) (Expr.columnName "count") ] ) - (Just (Expr.tableExpr (Expr.referencesTable $ Orville.tableName Foo.table) Nothing Nothing Nothing Nothing Nothing)) + ( Just + ( Expr.tableExpr + (Expr.singleTableReferenceList (Orville.tableName Foo.table)) + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + ) + ) marshaller = Orville.annotateSqlMarshallerEmptyAnnotation $ diff --git a/test/Test/Expr/Cursor.hs b/test/Test/Expr/Cursor.hs --- a/test/Test/Expr/Cursor.hs +++ b/test/Test/Expr/Cursor.hs @@ -7,6 +7,7 @@ import qualified Control.Monad.IO.Class as MIO import qualified Data.ByteString.Char8 as B8 import qualified Data.Int as Int +import qualified Data.List.NonEmpty as NE import Hedgehog ((===)) import qualified Hedgehog as HH @@ -47,7 +48,7 @@ prop_cursorInTransaction = Property.singletonNamedDBProperty "In transaction" $ \pool -> do result <- - withFooBarData pool [row 1, row 2] $ \connection -> + withFooBarData pool (NE.fromList [row 1, row 2]) $ \connection -> withTestTransaction connection $ withTestCursor connection Nothing Nothing findAllFooBars $ \cursorName -> do result <- RawSql.execute connection $ Expr.fetch Nothing cursorName @@ -59,7 +60,7 @@ prop_cursorOutsideTransactionWithHold = Property.singletonNamedDBProperty "Outside transaction (with hold)" $ \pool -> do result <- - withFooBarData pool [row 1, row 2] $ \connection -> + withFooBarData pool (NE.fromList [row 1, row 2]) $ \connection -> withTestCursor connection Nothing (Just Expr.withHold) findAllFooBars $ \cursorName -> do result <- RawSql.execute connection $ Expr.fetch Nothing cursorName Execution.readRows result @@ -89,7 +90,7 @@ prop_cursorMove = Property.singletonNamedDBProperty "Move" $ \pool -> do result <- - withFooBarData pool [row 1, row 2, row 3] $ \connection -> + withFooBarData pool (NE.fromList [row 1, row 2, row 3]) $ \connection -> withTestCursor connection Nothing (Just Expr.withHold) findAllFooBars $ \cursorName -> do RawSql.executeVoid connection $ Expr.move (Just $ Expr.rowCount 2) cursorName result <- RawSql.execute connection $ Expr.fetch Nothing cursorName @@ -101,7 +102,7 @@ prop_cursorNoScroll = Property.singletonNamedDBProperty "Move" $ \pool -> do scrollBackResult <- - withFooBarData pool [row 1, row 2] $ \connection -> + withFooBarData pool (NE.fromList [row 1, row 2]) $ \connection -> withTestCursor connection (Just Expr.noScroll) (Just Expr.withHold) findAllFooBars $ \cursorName -> do RawSql.executeVoid connection $ Expr.move (Just Expr.next) cursorName ExSafe.try $ RawSql.executeVoid connection $ Expr.move (Just Expr.prior) cursorName @@ -122,7 +123,7 @@ runFetchDirectionsOnData pool Nothing - [row 1, row 2] + (NE.fromList [row 1, row 2]) [Expr.fetchAll] assertEqualFooBarRows first [row 1, row 2] @@ -134,7 +135,7 @@ runFetchDirectionsOnData pool Nothing - [row 1, row 2, row 3] + (NE.fromList [row 1, row 2, row 3]) [Expr.rowCount 2, Expr.rowCount 2] assertEqualFooBarRows first [row 1, row 2] @@ -147,7 +148,7 @@ runFetchDirectionsOnData pool Nothing - [row 1, row 2] + (NE.fromList [row 1, row 2]) [Expr.forward, Expr.forward] assertEqualFooBarRows first [row 1] @@ -160,7 +161,7 @@ runFetchDirectionsOnData pool Nothing - [row 1, row 2, row 3] + (NE.fromList [row 1, row 2, row 3]) [Expr.forwardCount 2, Expr.forwardCount 2] assertEqualFooBarRows first [row 1, row 2] @@ -173,7 +174,7 @@ runFetchDirectionsOnData pool Nothing - [row 1, row 2] + (NE.fromList [row 1, row 2]) [Expr.forwardAll] assertEqualFooBarRows first [row 1, row 2] @@ -185,7 +186,7 @@ runFetchDirectionsOnData pool (Just Expr.scroll) - [row 1, row 2] + (NE.fromList [row 1, row 2]) [Expr.forwardCount 2, Expr.backward] assertEqualFooBarRows first [row 1, row 2] @@ -198,7 +199,7 @@ runFetchDirectionsOnData pool (Just Expr.scroll) - [row 1, row 2, row 3] + (NE.fromList [row 1, row 2, row 3]) [Expr.forwardCount 3, Expr.backwardCount 2] assertEqualFooBarRows first [row 1, row 2, row 3] @@ -211,7 +212,7 @@ runFetchDirectionsOnData pool (Just Expr.scroll) - [row 1, row 2, row 3] + (NE.fromList [row 1, row 2, row 3]) [Expr.forwardCount 4, Expr.backwardAll] assertEqualFooBarRows first [row 1, row 2, row 3] @@ -224,7 +225,7 @@ runFetchDirectionsOnData pool Nothing - [row 1, row 2, row 3] + (NE.fromList [row 1, row 2, row 3]) [Expr.first, Expr.last] assertEqualFooBarRows first [row 1] @@ -237,7 +238,7 @@ runFetchDirectionsOnData pool (Just Expr.scroll) - [row 1, row 2, row 3] + (NE.fromList [row 1, row 2, row 3]) [Expr.next, Expr.next, Expr.prior] assertEqualFooBarRows first [row 1] @@ -251,7 +252,7 @@ runFetchDirectionsOnData pool (Just Expr.scroll) - [row 1, row 2, row 3] + (NE.fromList [row 1, row 2, row 3]) [Expr.absolute 3, Expr.absolute (-1)] assertEqualFooBarRows first [row 3] @@ -264,7 +265,7 @@ runFetchDirectionsOnData pool (Just Expr.scroll) - [row 1, row 2, row 3] + (NE.fromList [row 1, row 2, row 3]) [Expr.relative 1, Expr.relative 2, Expr.relative (-1), Expr.relative 0] assertEqualFooBarRows first [row 1] @@ -278,7 +279,7 @@ runFetchDirectionsOnData :: Orville.ConnectionPool -> Maybe Expr.ScrollExpr -> - [FooBar] -> + NE.NonEmpty FooBar -> [Expr.CursorDirection] -> HH.PropertyT IO [[[(Maybe B8.ByteString, SqlValue.SqlValue)]]] runFetchDirectionsOnData pool scroll fooBars directions = diff --git a/test/Test/Expr/GroupBy.hs b/test/Test/Expr/GroupBy.hs --- a/test/Test/Expr/GroupBy.hs +++ b/test/Test/Expr/GroupBy.hs @@ -6,7 +6,7 @@ import qualified Control.Monad.IO.Class as MIO import qualified Data.ByteString.Char8 as B8 import qualified Data.Int as Int -import Data.List.NonEmpty (NonEmpty ((:|))) +import qualified Data.List.NonEmpty as NE import qualified Data.Text as T import qualified Orville.PostgreSQL as Orville @@ -36,19 +36,19 @@ prop_groupByColumnsExpr = groupByTest "groupByColumnsExpr groups by columns" $ GroupByTest - { groupByValuesToInsert = [FooBar 1 "dog", FooBar 2 "dingo", FooBar 3 "dog"] + { groupByValuesToInsert = NE.fromList [FooBar 1 "dog", FooBar 2 "dingo", FooBar 3 "dog"] , groupByExpectedQueryResults = [FooBar 3 "dog", FooBar 2 "dingo", FooBar 1 "dog"] , groupByClause = Just . Expr.groupByClause $ Expr.groupByColumnsExpr $ - barColumn :| [fooColumn] + barColumn NE.:| [fooColumn] } prop_appendGroupByExpr :: Property.NamedDBProperty prop_appendGroupByExpr = groupByTest "appendGroupByExpr causes grouping on both clauses" $ GroupByTest - { groupByValuesToInsert = [FooBar 1 "dog", FooBar 2 "dingo", FooBar 1 "dog", FooBar 3 "dingo", FooBar 1 "dog", FooBar 2 "dingo"] + { groupByValuesToInsert = NE.fromList [FooBar 1 "dog", FooBar 2 "dingo", FooBar 1 "dog", FooBar 3 "dingo", FooBar 1 "dog", FooBar 2 "dingo"] , groupByExpectedQueryResults = [FooBar 2 "dingo", FooBar 1 "dog", FooBar 3 "dingo"] , groupByClause = Just . Expr.groupByClause $ @@ -58,7 +58,7 @@ } data GroupByTest = GroupByTest - { groupByValuesToInsert :: [FooBar] + { groupByValuesToInsert :: NE.NonEmpty FooBar , groupByClause :: Maybe Expr.GroupByClause , groupByExpectedQueryResults :: [FooBar] } @@ -67,11 +67,15 @@ mkGroupByTestInsertSource test = let mkRow foobar = - [ SqlValue.fromInt32 (foo foobar) - , SqlValue.fromText (T.pack $ bar foobar) - ] + NE.fromList + [ Expr.valueExpression $ SqlValue.fromInt32 (foo foobar) + , Expr.valueExpression $ SqlValue.fromText (T.pack $ bar foobar) + ] in - Expr.insertSqlValues (map mkRow $ groupByValuesToInsert test) + Expr.valuesExprInsertSource + . Expr.valuesExprFromValueExpressions + . fmap mkRow + $ (groupByValuesToInsert test) mkGroupByTestExpectedRows :: GroupByTest -> [[(Maybe B8.ByteString, SqlValue.SqlValue)]] mkGroupByTestExpectedRows test = @@ -90,30 +94,30 @@ dropAndRecreateTestTable connection RawSql.executeVoid connection $ - Expr.insertExpr testTable Nothing (mkGroupByTestInsertSource test) Nothing + Expr.insertExpr testTable Nothing (mkGroupByTestInsertSource test) Nothing Nothing result <- RawSql.execute connection $ Expr.queryExpr (Expr.selectClause $ Expr.selectExpr Nothing) (Expr.selectColumns [fooColumn, barColumn]) - (Just $ Expr.tableExpr (Expr.referencesTable testTable) Nothing (groupByClause test) Nothing Nothing Nothing) + (Just $ Expr.tableExpr (Expr.singleTableReferenceList testTable) Nothing (groupByClause test) Nothing Nothing Nothing Nothing Nothing Nothing) Execution.readRows result rows `assertEqualSqlRows` mkGroupByTestExpectedRows test -testTable :: Expr.Qualified Expr.TableName +testTable :: Expr.QualifiedOrUnqualified Expr.TableName testTable = - Expr.qualifyTable Nothing (Expr.tableName "expr_test") + Expr.unqualified (Expr.tableName "expr_test") -fooColumn :: Expr.ColumnName +fooColumn :: Expr.QualifiedOrUnqualified Expr.ColumnName fooColumn = - Expr.columnName "foo" + Expr.unqualified (Expr.columnName "foo") -barColumn :: Expr.ColumnName +barColumn :: Expr.QualifiedOrUnqualified Expr.ColumnName barColumn = - Expr.columnName "bar" + Expr.unqualified (Expr.columnName "bar") dropAndRecreateTestTable :: Orville.Connection -> IO () dropAndRecreateTestTable connection = do diff --git a/test/Test/Expr/GroupByOrderBy.hs b/test/Test/Expr/GroupByOrderBy.hs --- a/test/Test/Expr/GroupByOrderBy.hs +++ b/test/Test/Expr/GroupByOrderBy.hs @@ -6,6 +6,7 @@ import qualified Control.Monad.IO.Class as MIO import qualified Data.ByteString.Char8 as B8 import qualified Data.Int as Int +import qualified Data.List.NonEmpty as NE import qualified Data.Text as T import qualified Orville.PostgreSQL as Orville @@ -34,7 +35,7 @@ prop_groupByOrderByExpr = groupByOrderByTest "GroupBy and OrderBy clauses can be used together" $ GroupByOrderByTest - { valuesToInsert = [FooBar 1 "shiba", FooBar 2 "dingo", FooBar 1 "dog", FooBar 2 "dingo", FooBar 1 "shiba"] + { valuesToInsert = NE.fromList [FooBar 1 "shiba", FooBar 2 "dingo", FooBar 1 "dog", FooBar 2 "dingo", FooBar 1 "shiba"] , expectedQueryResults = [FooBar 2 "dingo", FooBar 1 "dog", FooBar 1 "shiba"] , groupByClause = Just . Expr.groupByClause $ @@ -47,7 +48,7 @@ } data GroupByOrderByTest = GroupByOrderByTest - { valuesToInsert :: [FooBar] + { valuesToInsert :: NE.NonEmpty FooBar , groupByClause :: Maybe Expr.GroupByClause , orderByClause :: Maybe Expr.OrderByClause , expectedQueryResults :: [FooBar] @@ -57,11 +58,15 @@ mkGroupByOrderByTestInsertSource test = let mkRow foobar = - [ SqlValue.fromInt32 (foo foobar) - , SqlValue.fromText (T.pack $ bar foobar) - ] + NE.fromList + [ Expr.valueExpression $ SqlValue.fromInt32 (foo foobar) + , Expr.valueExpression $ SqlValue.fromText (T.pack $ bar foobar) + ] in - Expr.insertSqlValues (map mkRow $ valuesToInsert test) + Expr.valuesExprInsertSource + . Expr.valuesExprFromValueExpressions + . fmap mkRow + $ valuesToInsert test mkGroupByOrderByTestExpectedRows :: GroupByOrderByTest -> [[(Maybe B8.ByteString, SqlValue.SqlValue)]] mkGroupByOrderByTestExpectedRows test = @@ -80,30 +85,30 @@ dropAndRecreateTestTable connection RawSql.executeVoid connection $ - Expr.insertExpr testTable Nothing (mkGroupByOrderByTestInsertSource test) Nothing + Expr.insertExpr testTable Nothing (mkGroupByOrderByTestInsertSource test) Nothing Nothing result <- RawSql.execute connection $ Expr.queryExpr (Expr.selectClause $ Expr.selectExpr Nothing) (Expr.selectColumns [fooColumn, barColumn]) - (Just $ Expr.tableExpr (Expr.referencesTable testTable) Nothing (groupByClause test) (orderByClause test) Nothing Nothing) + (Just $ Expr.tableExpr (Expr.singleTableReferenceList testTable) Nothing (groupByClause test) (orderByClause test) Nothing Nothing Nothing Nothing Nothing) Execution.readRows result rows `assertEqualSqlRows` mkGroupByOrderByTestExpectedRows test -testTable :: Expr.Qualified Expr.TableName +testTable :: Expr.QualifiedOrUnqualified Expr.TableName testTable = - Expr.qualifyTable Nothing (Expr.tableName "expr_test") + Expr.unqualified (Expr.tableName "expr_test") -fooColumn :: Expr.ColumnName +fooColumn :: Expr.QualifiedOrUnqualified Expr.ColumnName fooColumn = - Expr.columnName "foo" + Expr.unqualified (Expr.columnName "foo") -barColumn :: Expr.ColumnName +barColumn :: Expr.QualifiedOrUnqualified Expr.ColumnName barColumn = - Expr.columnName "bar" + Expr.unqualified (Expr.columnName "bar") dropAndRecreateTestTable :: Orville.Connection -> IO () dropAndRecreateTestTable connection = do diff --git a/test/Test/Expr/InsertUpdateDelete.hs b/test/Test/Expr/InsertUpdateDelete.hs --- a/test/Test/Expr/InsertUpdateDelete.hs +++ b/test/Test/Expr/InsertUpdateDelete.hs @@ -4,7 +4,7 @@ where import qualified Control.Monad.IO.Class as MIO -import Data.List.NonEmpty (NonEmpty ((:|))) +import qualified Data.List.NonEmpty as NE import qualified Data.Text as T import qualified Orville.PostgreSQL as Orville @@ -14,14 +14,15 @@ import qualified Orville.PostgreSQL.Raw.RawSql as RawSql import qualified Orville.PostgreSQL.Raw.SqlValue as SqlValue -import Test.Expr.TestSchema (assertEqualFooBarRows, barColumn, barColumnRef, dropAndRecreateTestTable, findAllFooBars, fooBarTable, fooColumn, insertFooBarSource, mkFooBar) +import Test.Expr.TestSchema (assertEqualFooBarRows, barColumn, barColumnRef, dropAndRecreateTestTable, findAllFooBars, findAllFooBarsInTable, fooBarTable, fooColumn, insertFooBarSource, mkFooBar) import qualified Test.Property as Property insertUpdateDeleteTests :: Orville.ConnectionPool -> Property.Group insertUpdateDeleteTests pool = Property.group - "Expr - Insert/Update/Delete" + "Expr - Insert/Update/Delete/Truncate" [ prop_insertExpr pool + , prop_insertExprWithOnConflictDoNothing pool , prop_insertExprWithReturning pool , prop_updateExpr pool , prop_updateExprWithWhere pool @@ -29,13 +30,16 @@ , prop_deleteExpr pool , prop_deleteExprWithWhere pool , prop_deleteExprWithReturning pool + , prop_truncateTablesExpr pool + , prop_insertExprWithOnConflictDoUpdate pool + , prop_updateTableRefList pool ] prop_insertExpr :: Property.NamedDBProperty prop_insertExpr = Property.singletonNamedDBProperty "insertExpr inserts values" $ \pool -> do let - fooBars = [mkFooBar 1 "dog", mkFooBar 2 "cat"] + fooBars = NE.fromList [mkFooBar 1 "dog", mkFooBar 2 "cat"] rows <- MIO.liftIO $ @@ -43,19 +47,75 @@ dropAndRecreateTestTable connection RawSql.executeVoid connection $ - Expr.insertExpr fooBarTable Nothing (insertFooBarSource fooBars) Nothing + Expr.insertExpr fooBarTable Nothing (insertFooBarSource fooBars) Nothing Nothing result <- RawSql.execute connection findAllFooBars Execution.readRows result - assertEqualFooBarRows rows fooBars + assertEqualFooBarRows rows (NE.toList fooBars) +prop_insertExprWithOnConflictDoNothing :: Property.NamedDBProperty +prop_insertExprWithOnConflictDoNothing = + Property.singletonNamedDBProperty "insertExpr with on conflict do nothing does not modify table" $ \pool -> do + let + fooBars = NE.fromList [mkFooBar 1 "dog", mkFooBar 2 "cat"] + addIndex = RawSql.fromString "CREATE UNIQUE INDEX ON " <> RawSql.toRawSql fooBarTable <> RawSql.fromString "( foo )" + + rows <- + MIO.liftIO $ + Conn.withPoolConnection pool $ \connection -> do + dropAndRecreateTestTable connection + RawSql.executeVoid connection addIndex + + RawSql.executeVoid connection $ + Expr.insertExpr fooBarTable Nothing (insertFooBarSource fooBars) Nothing Nothing + + RawSql.executeVoid connection $ + Expr.insertExpr fooBarTable Nothing (insertFooBarSource fooBars) (Just Expr.onConflictDoNothing) Nothing + + result <- RawSql.execute connection findAllFooBars + + Execution.readRows result + + assertEqualFooBarRows rows (NE.toList fooBars) + +prop_insertExprWithOnConflictDoUpdate :: Property.NamedDBProperty +prop_insertExprWithOnConflictDoUpdate = + Property.singletonNamedDBProperty "insertExpr with on conflict do update updates conflicting row" $ \pool -> do + let + fooBars0 = pure $ mkFooBar 1 "dog" + fooBars1 = pure $ mkFooBar 1 "eagel" + addIndex = RawSql.fromString "CREATE UNIQUE INDEX ON " <> RawSql.toRawSql fooBarTable <> RawSql.fromString "( foo )" + fooColumnName = Expr.unqualified (Expr.columnName "foo") + barColumnName = Expr.unqualified (Expr.columnName "bar") + conflictTarget = Expr.conflictTargetForIndexColumn fooColumnName Nothing + setExcludedColumn = Expr.setColumnNameExcluded barColumnName + onConflictDoUpdate = Expr.onConflictDoUpdate (Just conflictTarget) (pure setExcludedColumn) Nothing + + rows <- + MIO.liftIO $ + Conn.withPoolConnection pool $ \connection -> do + dropAndRecreateTestTable connection + RawSql.executeVoid connection addIndex + + RawSql.executeVoid connection $ + Expr.insertExpr fooBarTable Nothing (insertFooBarSource fooBars0) (Just onConflictDoUpdate) Nothing + + RawSql.executeVoid connection $ + Expr.insertExpr fooBarTable Nothing (insertFooBarSource fooBars1) (Just onConflictDoUpdate) Nothing + + result <- RawSql.execute connection findAllFooBars + + Execution.readRows result + + assertEqualFooBarRows rows (NE.toList fooBars1) + prop_insertExprWithReturning :: Property.NamedDBProperty prop_insertExprWithReturning = Property.singletonNamedDBProperty "insertExpr with returning clause returns the requested columns" $ \pool -> do let - fooBars = [mkFooBar 1 "dog", mkFooBar 2 "cat"] + fooBars = NE.fromList [mkFooBar 1 "dog", mkFooBar 2 "cat"] rows <- MIO.liftIO $ @@ -68,25 +128,28 @@ fooBarTable Nothing (insertFooBarSource fooBars) + Nothing (Just $ Expr.returningExpr $ Expr.selectColumns [fooColumn, barColumn]) Execution.readRows result - assertEqualFooBarRows rows fooBars + assertEqualFooBarRows rows (NE.toList fooBars) prop_updateExpr :: Property.NamedDBProperty prop_updateExpr = Property.singletonNamedDBProperty "updateExpr updates rows in the db" $ \pool -> do let - oldFooBars = [mkFooBar 1 "dog", mkFooBar 2 "cat"] - newFooBars = [mkFooBar 1 "ferret", mkFooBar 2 "ferret"] + oldFooBars = NE.fromList [mkFooBar 1 "dog", mkFooBar 2 "cat"] + newFooBars = NE.fromList [mkFooBar 1 "ferret", mkFooBar 2 "ferret"] setBarToFerret = Expr.updateExpr fooBarTable - (Expr.setClauseList (Expr.setColumn barColumn (SqlValue.fromText (T.pack "ferret")) :| [])) Nothing + (Expr.setClauseList (pure $ Expr.setColumn barColumn (SqlValue.fromText (T.pack "ferret")))) Nothing + Nothing + Nothing rows <- MIO.liftIO $ @@ -94,7 +157,7 @@ dropAndRecreateTestTable connection RawSql.executeVoid connection $ - Expr.insertExpr fooBarTable Nothing (insertFooBarSource oldFooBars) Nothing + Expr.insertExpr fooBarTable Nothing (insertFooBarSource oldFooBars) Nothing Nothing RawSql.executeVoid connection setBarToFerret @@ -102,19 +165,21 @@ Execution.readRows result - assertEqualFooBarRows rows newFooBars + assertEqualFooBarRows rows (NE.toList newFooBars) prop_updateExprWithWhere :: Property.NamedDBProperty prop_updateExprWithWhere = Property.singletonNamedDBProperty "updateExpr uses a where clause when given" $ \pool -> do let - oldFooBars = [mkFooBar 1 "dog", mkFooBar 2 "cat"] - newFooBars = [mkFooBar 1 "ferret", mkFooBar 2 "cat"] + oldFooBars = NE.fromList [mkFooBar 1 "dog", mkFooBar 2 "cat"] + newFooBars = NE.fromList [mkFooBar 1 "ferret", mkFooBar 2 "cat"] updateDogToForret = Expr.updateExpr fooBarTable - (Expr.setClauseList (Expr.setColumn barColumn (SqlValue.fromText (T.pack "ferret")) :| [])) + Nothing + (Expr.setClauseList (pure $ Expr.setColumn barColumn (SqlValue.fromText (T.pack "ferret")))) + Nothing (Just (Expr.whereClause (Expr.equals barColumnRef (Expr.valueExpression (SqlValue.fromText (T.pack "dog")))))) Nothing @@ -124,7 +189,7 @@ dropAndRecreateTestTable connection RawSql.executeVoid connection $ - Expr.insertExpr fooBarTable Nothing (insertFooBarSource oldFooBars) Nothing + Expr.insertExpr fooBarTable Nothing (insertFooBarSource oldFooBars) Nothing Nothing RawSql.executeVoid connection updateDogToForret @@ -132,20 +197,22 @@ Execution.readRows result - assertEqualFooBarRows rows newFooBars + assertEqualFooBarRows rows (NE.toList newFooBars) prop_updateExprWithReturning :: Property.NamedDBProperty prop_updateExprWithReturning = Property.singletonNamedDBProperty "updateExpr with returning clause returns the new records" $ \pool -> do let - oldFooBars = [mkFooBar 1 "dog", mkFooBar 2 "cat"] - newFooBars = [mkFooBar 1 "ferret", mkFooBar 2 "ferret"] + oldFooBars = NE.fromList [mkFooBar 1 "dog", mkFooBar 2 "cat"] + newFooBars = NE.fromList [mkFooBar 1 "ferret", mkFooBar 2 "ferret"] setBarToFerret = Expr.updateExpr fooBarTable - (Expr.setClauseList (Expr.setColumn barColumn (SqlValue.fromText (T.pack "ferret")) :| [])) Nothing + (Expr.setClauseList (pure $ Expr.setColumn barColumn (SqlValue.fromText (T.pack "ferret")))) + Nothing + Nothing (Just $ Expr.returningExpr $ Expr.selectColumns [fooColumn, barColumn]) rows <- @@ -154,19 +221,19 @@ dropAndRecreateTestTable connection RawSql.executeVoid connection $ - Expr.insertExpr fooBarTable Nothing (insertFooBarSource oldFooBars) Nothing + Expr.insertExpr fooBarTable Nothing (insertFooBarSource oldFooBars) Nothing Nothing result <- RawSql.execute connection setBarToFerret Execution.readRows result - assertEqualFooBarRows rows newFooBars + assertEqualFooBarRows rows (NE.toList newFooBars) prop_deleteExpr :: Property.NamedDBProperty prop_deleteExpr = Property.singletonNamedDBProperty "deleteExpr deletes rows in the db" $ \pool -> do let - oldFooBars = [mkFooBar 1 "dog", mkFooBar 2 "cat"] + oldFooBars = NE.fromList [mkFooBar 1 "dog", mkFooBar 2 "cat"] deleteRows = Expr.deleteExpr @@ -180,7 +247,7 @@ dropAndRecreateTestTable connection RawSql.executeVoid connection $ - Expr.insertExpr fooBarTable Nothing (insertFooBarSource oldFooBars) Nothing + Expr.insertExpr fooBarTable Nothing (insertFooBarSource oldFooBars) Nothing Nothing RawSql.executeVoid connection deleteRows @@ -194,8 +261,8 @@ prop_deleteExprWithWhere = Property.singletonNamedDBProperty "deleteExpr uses a where clause when given" $ \pool -> do let - oldFooBars = [mkFooBar 1 "dog", mkFooBar 2 "cat"] - newFooBars = [mkFooBar 2 "cat"] + oldFooBars = NE.fromList [mkFooBar 1 "dog", mkFooBar 2 "cat"] + newFooBars = pure $ mkFooBar 2 "cat" deleteDogs = Expr.deleteExpr @@ -209,7 +276,7 @@ dropAndRecreateTestTable connection RawSql.executeVoid connection $ - Expr.insertExpr fooBarTable Nothing (insertFooBarSource oldFooBars) Nothing + Expr.insertExpr fooBarTable Nothing (insertFooBarSource oldFooBars) Nothing Nothing RawSql.executeVoid connection deleteDogs @@ -217,13 +284,13 @@ Execution.readRows result - assertEqualFooBarRows rows newFooBars + assertEqualFooBarRows rows (NE.toList newFooBars) prop_deleteExprWithReturning :: Property.NamedDBProperty prop_deleteExprWithReturning = Property.singletonNamedDBProperty "deleteExpr with returning returns the original rows" $ \pool -> do let - oldFooBars = [mkFooBar 1 "dog", mkFooBar 2 "cat"] + oldFooBars = NE.fromList [mkFooBar 1 "dog", mkFooBar 2 "cat"] deleteDogs = Expr.deleteExpr @@ -237,10 +304,115 @@ dropAndRecreateTestTable connection RawSql.executeVoid connection $ - Expr.insertExpr fooBarTable Nothing (insertFooBarSource oldFooBars) Nothing + Expr.insertExpr fooBarTable Nothing (insertFooBarSource oldFooBars) Nothing Nothing result <- RawSql.execute connection deleteDogs Execution.readRows result - assertEqualFooBarRows rows oldFooBars + assertEqualFooBarRows rows (NE.toList oldFooBars) + +prop_truncateTablesExpr :: Property.NamedDBProperty +prop_truncateTablesExpr = + Property.singletonNamedDBProperty "truncateTablesExpr clears out inserted values from all tables" $ \pool -> do + let + fooBars = NE.fromList [mkFooBar 1 "dog", mkFooBar 2 "cat"] + fooBar2Table = + Expr.unqualified (Expr.tableName "foobar2") + dropAndRecreateSecondTable connection = do + RawSql.executeVoid connection (RawSql.fromString "DROP TABLE IF EXISTS " <> RawSql.toRawSql fooBar2Table) + RawSql.executeVoid connection (RawSql.fromString "CREATE TABLE " <> RawSql.toRawSql fooBar2Table <> RawSql.fromString "(foo INTEGER, bar TEXT)") + + recreateAndInsert = + MIO.liftIO $ + Conn.withPoolConnection pool $ \connection -> do + dropAndRecreateTestTable connection + dropAndRecreateSecondTable connection + + RawSql.executeVoid connection $ + Expr.insertExpr fooBarTable Nothing (insertFooBarSource fooBars) Nothing Nothing + RawSql.executeVoid connection $ + Expr.insertExpr fooBar2Table Nothing (insertFooBarSource fooBars) Nothing Nothing + + truncateTables = + MIO.liftIO $ + Conn.withPoolConnection pool $ \connection -> do + RawSql.executeVoid connection $ + Expr.truncateTablesExpr (fooBarTable NE.:| (pure fooBar2Table)) + + _ <- recreateAndInsert + _ <- truncateTables + + fooBarRows <- + MIO.liftIO $ + Conn.withPoolConnection pool $ \connection -> do + result <- RawSql.execute connection findAllFooBars + + Execution.readRows result + + fooBar2Rows <- + MIO.liftIO $ + Conn.withPoolConnection pool $ \connection -> do + result <- RawSql.execute connection $ findAllFooBarsInTable fooBar2Table + + Execution.readRows result + + assertEqualFooBarRows fooBarRows [] + assertEqualFooBarRows fooBar2Rows [] + +prop_updateTableRefList :: Property.NamedDBProperty +prop_updateTableRefList = + Property.singletonNamedDBProperty "updateExpr includes a tableReferenceList to allow where condition to reference another table" $ \pool -> do + let + fooBars = NE.fromList [mkFooBar 1 "dog", mkFooBar 2 "cat", mkFooBar 3 "ferret"] + fooBars2 = NE.fromList [mkFooBar 1 "bird", mkFooBar 3 "fish", mkFooBar 4 "snake"] + expectedFooBars = NE.fromList [mkFooBar 1 "bird", mkFooBar 2 "cat", mkFooBar 3 "fish"] + fooBar2Table = + Expr.unqualified (Expr.tableName "foobar2") + dropAndRecreateSecondTable connection = do + RawSql.executeVoid connection (RawSql.fromString "DROP TABLE IF EXISTS " <> RawSql.toRawSql fooBar2Table) + RawSql.executeVoid connection (RawSql.fromString "CREATE TABLE " <> RawSql.toRawSql fooBar2Table <> RawSql.fromString "(foo INTEGER, bar TEXT)") + + fooBar2TableRef = Expr.tableNameReference fooBar2Table (Just (Expr.stringToAliasExpr "f2")) + + setClauseList = RawSql.unsafeSqlExpression "bar = f2.bar" + + whereClause = RawSql.unsafeSqlExpression "WHERE foobar.foo = f2.foo" + + updateExpr = + Expr.updateExpr + fooBarTable + Nothing + setClauseList + (Just $ Expr.tableReferenceList [fooBar2TableRef]) + (Just whereClause) + (Just $ Expr.returningExpr $ Expr.selectColumns [RawSql.unsafeSqlExpression "foobar.foo", RawSql.unsafeSqlExpression "foobar.bar"]) + + recreateAndInsert = + MIO.liftIO $ + Conn.withPoolConnection pool $ \connection -> do + dropAndRecreateTestTable connection + dropAndRecreateSecondTable connection + + RawSql.executeVoid connection $ + Expr.insertExpr fooBarTable Nothing (insertFooBarSource fooBars) Nothing Nothing + RawSql.executeVoid connection $ + Expr.insertExpr fooBar2Table Nothing (insertFooBarSource fooBars2) Nothing Nothing + + _ <- recreateAndInsert + + _ <- + MIO.liftIO $ + Conn.withPoolConnection pool $ \connection -> do + result <- RawSql.execute connection updateExpr + + Execution.readRows result + + fooBarRows <- + MIO.liftIO $ + Conn.withPoolConnection pool $ \connection -> do + result <- RawSql.execute connection findAllFooBars + + Execution.readRows result + + assertEqualFooBarRows fooBarRows (NE.toList expectedFooBars) diff --git a/test/Test/Expr/Join.hs b/test/Test/Expr/Join.hs new file mode 100644 --- /dev/null +++ b/test/Test/Expr/Join.hs @@ -0,0 +1,78 @@ +module Test.Expr.Join + ( joinTests + ) +where + +import qualified Data.ByteString.Char8 as B8 +import Data.Function ((&)) +import GHC.Stack (HasCallStack, withFrozenCallStack) +import Hedgehog ((===)) +import qualified Hedgehog as HH + +import qualified Orville.PostgreSQL.Expr as Expr +import qualified Orville.PostgreSQL.Raw.RawSql as RawSql + +import qualified Test.Property as Property + +joinTests :: Property.Group +joinTests = + Property.group + "Expr - Join" + [ prop_joinedTable + , prop_join + , prop_joining + ] + +prop_joinedTable :: Property.NamedProperty +prop_joinedTable = + Property.singletonNamedProperty "joinedTable produces a table ref that joins two tables together" + $ assertTableRefEquals + "\"foo\" LEFT JOIN \"bar\" ON TRUE" + $ Expr.joinedTable fooTableRef Expr.leftJoinType barTableRef joinOnTrue + +prop_join :: Property.NamedProperty +prop_join = + Property.singletonNamedProperty "join allows 'joinedTable' to be used more naturally" $ + let + joinedTableRef = + fooTableRef + & Expr.join Expr.leftJoinType barTableRef joinOnTrue + & Expr.join Expr.leftJoinType bazTableRef joinOnTrue + in + assertTableRefEquals + "\"foo\" LEFT JOIN \"bar\" ON TRUE LEFT JOIN \"baz\" ON TRUE" + joinedTableRef + +prop_joining :: Property.NamedProperty +prop_joining = + Property.singletonNamedProperty "joining allows 'join' to be used without the user needing to use (&)" $ + let + joinedTableRef = + Expr.joining + fooTableRef + [ Expr.join Expr.leftJoinType barTableRef joinOnTrue + , Expr.join Expr.leftJoinType bazTableRef joinOnTrue + ] + in + assertTableRefEquals + "\"foo\" LEFT JOIN \"bar\" ON TRUE LEFT JOIN \"baz\" ON TRUE" + joinedTableRef + +assertTableRefEquals :: + (HH.MonadTest m, HasCallStack) => String -> Expr.TableReference -> m () +assertTableRefEquals expectedString tableRef = + withFrozenCallStack $ + RawSql.toExampleBytes tableRef === B8.pack expectedString + +joinOnTrue :: Expr.JoinConstraint +joinOnTrue = + Expr.joinOnConstraint $ Expr.literalBooleanExpr True + +fooTableRef :: Expr.TableReference +fooTableRef = Expr.tableNameReference (Expr.unqualified $ Expr.tableName "foo") Nothing + +barTableRef :: Expr.TableReference +barTableRef = Expr.tableNameReference (Expr.unqualified $ Expr.tableName "bar") Nothing + +bazTableRef :: Expr.TableReference +bazTableRef = Expr.tableNameReference (Expr.unqualified $ Expr.tableName "baz") Nothing diff --git a/test/Test/Expr/OrderBy.hs b/test/Test/Expr/OrderBy.hs --- a/test/Test/Expr/OrderBy.hs +++ b/test/Test/Expr/OrderBy.hs @@ -25,14 +25,17 @@ , prop_orderByColumnsExpr pool , prop_ascendingOrderWithExpr pool , prop_descendingOrderWithExpr pool + , prop_distinctOnExpr pool ] prop_ascendingExpr :: Property.NamedDBProperty prop_ascendingExpr = orderByTest "ascendingExpr sorts a text column" $ OrderByTest - { orderByValuesToInsert = [mkFooBar 1 "dog", mkFooBar 2 "dingo", mkFooBar 3 "dog"] + { orderByValuesToInsert = NE.fromList [mkFooBar 1 "dog", mkFooBar 2 "dingo", mkFooBar 3 "dog"] , orderByExpectedQueryResults = [mkFooBar 2 "dingo", mkFooBar 1 "dog", mkFooBar 3 "dog"] + , orderByDistinctOn = + Nothing , orderByClause = Just . Expr.orderByClause $ Expr.orderByColumnName barColumn Expr.ascendingOrder @@ -42,8 +45,10 @@ prop_descendingExpr = orderByTest "descendingExpr sorts a text column" $ OrderByTest - { orderByValuesToInsert = [mkFooBar 1 "dog", mkFooBar 2 "dingo", mkFooBar 3 "dog"] + { orderByValuesToInsert = NE.fromList [mkFooBar 1 "dog", mkFooBar 2 "dingo", mkFooBar 3 "dog"] , orderByExpectedQueryResults = [mkFooBar 1 "dog", mkFooBar 3 "dog", mkFooBar 2 "dingo"] + , orderByDistinctOn = + Nothing , orderByClause = Just . Expr.orderByClause $ Expr.orderByColumnName barColumn Expr.descendingOrder @@ -53,8 +58,10 @@ prop_appendOrderByExpr = orderByTest "appendOrderByExpr causes ordering on both columns" $ OrderByTest - { orderByValuesToInsert = [mkFooBar 1 "dog", mkFooBar 2 "dingo", mkFooBar 3 "dog"] + { orderByValuesToInsert = NE.fromList [mkFooBar 1 "dog", mkFooBar 2 "dingo", mkFooBar 3 "dog"] , orderByExpectedQueryResults = [mkFooBar 2 "dingo", mkFooBar 3 "dog", mkFooBar 1 "dog"] + , orderByDistinctOn = + Nothing , orderByClause = Just . Expr.orderByClause $ Expr.appendOrderByExpr @@ -66,8 +73,10 @@ prop_orderByColumnsExpr = orderByTest "orderByColumnsExpr orders by columns" $ OrderByTest - { orderByValuesToInsert = [mkFooBar 1 "dog", mkFooBar 2 "dingo", mkFooBar 3 "dog"] + { orderByValuesToInsert = NE.fromList [mkFooBar 1 "dog", mkFooBar 2 "dingo", mkFooBar 3 "dog"] , orderByExpectedQueryResults = [mkFooBar 2 "dingo", mkFooBar 3 "dog", mkFooBar 1 "dog"] + , orderByDistinctOn = + Nothing , orderByClause = Just . Expr.orderByClause $ Expr.orderByColumnsExpr $ @@ -80,9 +89,11 @@ orderByTest "ascendingOrderWith sorts columns with nulls first/last" $ OrderByTest { orderByValuesToInsert = - [FooBar Nothing Nothing, FooBar (Just 1) Nothing, mkFooBar 2 "dog", FooBar Nothing (Just "dog")] + NE.fromList [FooBar Nothing Nothing, FooBar (Just 1) Nothing, mkFooBar 2 "dog", FooBar Nothing (Just "dog")] , orderByExpectedQueryResults = [FooBar Nothing (Just "dog"), FooBar Nothing Nothing, FooBar (Just 1) Nothing, mkFooBar 2 "dog"] + , orderByDistinctOn = + Nothing , orderByClause = Just . Expr.orderByClause $ Expr.appendOrderByExpr @@ -95,9 +106,11 @@ orderByTest "descendingOrderWith sorts columns with nulls first/last" $ OrderByTest { orderByValuesToInsert = - [FooBar Nothing Nothing, FooBar (Just 1) Nothing, mkFooBar 2 "dog", FooBar Nothing (Just "dog")] + NE.fromList [FooBar Nothing Nothing, FooBar (Just 1) Nothing, mkFooBar 2 "dog", FooBar Nothing (Just "dog")] , orderByExpectedQueryResults = [FooBar Nothing (Just "dog"), FooBar Nothing Nothing, mkFooBar 2 "dog", FooBar (Just 1) Nothing] + , orderByDistinctOn = + Nothing , orderByClause = Just . Expr.orderByClause $ Expr.appendOrderByExpr @@ -105,9 +118,25 @@ (Expr.orderByColumnName barColumn $ Expr.descendingOrderWith Expr.NullsLast) } +prop_distinctOnExpr :: Property.NamedDBProperty +prop_distinctOnExpr = + orderByTest "descendingExpr sorts a text column as expected with distinctOn" $ + OrderByTest + { orderByValuesToInsert = NE.fromList [mkFooBar 1 "dog", mkFooBar 2 "dingo", mkFooBar 3 "dog"] + , orderByExpectedQueryResults = [mkFooBar 2 "dingo", mkFooBar 1 "dog"] + , orderByDistinctOn = + Just . pure . RawSql.unsafeFromRawSql $ RawSql.toRawSql barColumn + , orderByClause = + Just . Expr.orderByClause $ + Expr.appendOrderByExpr + (Expr.orderByColumnName barColumn Expr.ascendingOrder) + (Expr.orderByColumnName fooColumn Expr.ascendingOrder) + } + data OrderByTest = OrderByTest - { orderByValuesToInsert :: [FooBar] + { orderByValuesToInsert :: NE.NonEmpty FooBar , orderByClause :: Maybe Expr.OrderByClause + , orderByDistinctOn :: Maybe (NE.NonEmpty Expr.DistinctOnExpr) , orderByExpectedQueryResults :: [FooBar] } @@ -120,14 +149,25 @@ dropAndRecreateTestTable connection RawSql.executeVoid connection $ - Expr.insertExpr fooBarTable Nothing (insertFooBarSource $ orderByValuesToInsert test) Nothing + Expr.insertExpr fooBarTable Nothing (insertFooBarSource $ orderByValuesToInsert test) Nothing Nothing result <- RawSql.execute connection $ Expr.queryExpr - (Expr.selectClause $ Expr.selectExpr Nothing) + (Expr.selectClause . Expr.selectDistinctOnExpr $ orderByDistinctOn test) (Expr.selectColumns [fooColumn, barColumn]) - (Just $ Expr.tableExpr (Expr.referencesTable fooBarTable) Nothing Nothing (orderByClause test) Nothing Nothing) + ( Just $ + Expr.tableExpr + (Expr.singleTableReferenceList fooBarTable) + Nothing + Nothing + (orderByClause test) + Nothing + Nothing + Nothing + Nothing + Nothing + ) Execution.readRows result diff --git a/test/Test/Expr/SequenceDefinition.hs b/test/Test/Expr/SequenceDefinition.hs --- a/test/Test/Expr/SequenceDefinition.hs +++ b/test/Test/Expr/SequenceDefinition.hs @@ -57,9 +57,9 @@ PgCatalog.pgSequenceCache pgSequence === 10 PgCatalog.pgSequenceCycle pgSequence === True -exprSequenceName :: Expr.Qualified Expr.SequenceName +exprSequenceName :: Expr.QualifiedOrUnqualified Expr.SequenceName exprSequenceName = - Expr.qualifySequence Nothing (Expr.sequenceName sequenceNameString) + Expr.unqualified (Expr.sequenceName sequenceNameString) sequenceNameString :: String sequenceNameString = diff --git a/test/Test/Expr/TableDefinition.hs b/test/Test/Expr/TableDefinition.hs --- a/test/Test/Expr/TableDefinition.hs +++ b/test/Test/Expr/TableDefinition.hs @@ -18,6 +18,7 @@ "Expr - TableDefinition" [ prop_createWithOneColumn pool , prop_createWithMultipleColumns pool + , prop_renameTable pool , prop_addOneColumn pool , prop_addMultipleColumns pool ] @@ -39,11 +40,28 @@ MIO.liftIO $ Orville.runOrville pool $ do Orville.executeVoid Orville.DDLQuery $ Expr.dropTableExpr (Just Expr.ifExists) exprTableName - Orville.executeVoid Orville.DDLQuery $ Expr.createTableExpr exprTableName [column1Definition, column2Definition] Nothing [] + Orville.executeVoid Orville.DDLQuery $ Expr.createTableExpr exprTableName [column1Definition, column2Definition, column1DefinitionGenAlways, column1DefinitionGenByDefault] Nothing [] tableDesc <- PgAssert.assertTableExists pool tableNameString - PgAssert.assertColumnNamesEqual tableDesc [column1NameString, column2NameString] + PgAssert.assertColumnNamesEqual tableDesc [column1NameString, column1AlwaysNameString, column1ByDefaultNameString, column2NameString] +prop_renameTable :: Property.NamedDBProperty +prop_renameTable = + Property.singletonNamedDBProperty "Rename table results in the new name existing and the old name not" $ \pool -> do + let + newTableNameString = "renamed_" <> tableNameString + newTableName = Expr.unqualified $ Expr.tableName newTableNameString + MIO.liftIO $ + Orville.runOrville pool $ do + Orville.executeVoid Orville.DDLQuery $ Expr.dropTableExpr (Just Expr.ifExists) exprTableName + Orville.executeVoid Orville.DDLQuery $ Expr.dropTableExpr (Just Expr.ifExists) newTableName + Orville.executeVoid Orville.DDLQuery $ Expr.createTableExpr exprTableName [column1Definition] Nothing [] + Orville.executeVoid Orville.DDLQuery $ Expr.renameTableExpr exprTableName newTableName + + PgAssert.assertTableDoesNotExist pool tableNameString + tableDesc <- PgAssert.assertTableExists pool newTableNameString + PgAssert.assertColumnNamesEqual tableDesc [column1NameString] + prop_addOneColumn :: Property.NamedDBProperty prop_addOneColumn = Property.singletonNamedDBProperty "Alter table adds one column" $ \pool -> do @@ -63,14 +81,14 @@ Orville.runOrville pool $ do Orville.executeVoid Orville.DDLQuery $ Expr.dropTableExpr (Just Expr.ifExists) exprTableName Orville.executeVoid Orville.DDLQuery $ Expr.createTableExpr exprTableName [] Nothing [] - Orville.executeVoid Orville.DDLQuery $ Expr.alterTableExpr exprTableName (Expr.addColumn column1Definition :| [Expr.addColumn column2Definition]) + Orville.executeVoid Orville.DDLQuery $ Expr.alterTableExpr exprTableName (Expr.addColumn column1Definition :| [Expr.addColumn column1DefinitionGenAlways, Expr.addColumn column1DefinitionGenByDefault, Expr.addColumn column2Definition]) tableDesc <- PgAssert.assertTableExists pool tableNameString - PgAssert.assertColumnNamesEqual tableDesc [column1NameString, column2NameString] + PgAssert.assertColumnNamesEqual tableDesc [column1NameString, column2NameString, column1AlwaysNameString, column1ByDefaultNameString] -exprTableName :: Expr.Qualified Expr.TableName +exprTableName :: Expr.QualifiedOrUnqualified Expr.TableName exprTableName = - Expr.qualifyTable Nothing (Expr.tableName tableNameString) + Expr.unqualified (Expr.tableName tableNameString) tableNameString :: String tableNameString = @@ -81,19 +99,43 @@ Expr.columnDefinition (Expr.columnName column1NameString) Expr.text + mempty Nothing + +column1DefinitionGenByDefault :: Expr.ColumnDefinition +column1DefinitionGenByDefault = + Expr.columnDefinition + (Expr.columnName column1ByDefaultNameString) + Expr.int + [Expr.notNullConstraint, Expr.identityColumnConstraint Expr.byDefaultColumnIdentityGeneration] Nothing +column1DefinitionGenAlways :: Expr.ColumnDefinition +column1DefinitionGenAlways = + Expr.columnDefinition + (Expr.columnName column1AlwaysNameString) + Expr.int + [Expr.notNullConstraint, Expr.identityColumnConstraint Expr.alwaysColumnIdentityGeneration] + Nothing + column1NameString :: String column1NameString = "column1" +column1AlwaysNameString :: String +column1AlwaysNameString = + "column1_always" + +column1ByDefaultNameString :: String +column1ByDefaultNameString = + "column1_by_default" + column2Definition :: Expr.ColumnDefinition column2Definition = Expr.columnDefinition (Expr.columnName column2NameString) Expr.text - Nothing + mempty Nothing column2NameString :: String diff --git a/test/Test/Expr/TableReferenceList.hs b/test/Test/Expr/TableReferenceList.hs new file mode 100644 --- /dev/null +++ b/test/Test/Expr/TableReferenceList.hs @@ -0,0 +1,42 @@ +module Test.Expr.TableReferenceList + ( tableReferenceListTests + ) where + +import qualified Data.ByteString.Char8 as B8 +import GHC.Stack (HasCallStack, withFrozenCallStack) +import Hedgehog ((===)) +import qualified Hedgehog as HH + +import qualified Orville.PostgreSQL.Expr as Expr +import qualified Orville.PostgreSQL.Raw.RawSql as RawSql + +import qualified Test.Property as Property + +tableReferenceListTests :: Property.Group +tableReferenceListTests = + Property.group + "Expr - TableReferenceList" + [ prop_tableReferenceList + ] + +prop_tableReferenceList :: Property.NamedProperty +prop_tableReferenceList = + Property.singletonNamedProperty "creates a comma delimited table list" + $ assertTableReferenteListEquals + "\"foo\", \"bar\"" + $ Expr.tableReferenceList [fooTable, barTable] + +assertTableReferenteListEquals :: + (HH.MonadTest m, HasCallStack) => + String -> + Expr.TableReferenceList -> + m () +assertTableReferenteListEquals expectedString tableReferenceList = + withFrozenCallStack $ + RawSql.toExampleBytes tableReferenceList === B8.pack expectedString + +fooTable :: Expr.TableReference +fooTable = Expr.tableNameReference (Expr.unqualified $ Expr.tableName "foo") Nothing + +barTable :: Expr.TableReference +barTable = Expr.tableNameReference (Expr.unqualified $ Expr.tableName "bar") Nothing diff --git a/test/Test/Expr/TestSchema.hs b/test/Test/Expr/TestSchema.hs --- a/test/Test/Expr/TestSchema.hs +++ b/test/Test/Expr/TestSchema.hs @@ -2,6 +2,7 @@ ( FooBar (..) , mkFooBar , findAllFooBars + , findAllFooBarsInTable , fooBarTable , fooColumn , fooColumnRef @@ -21,6 +22,7 @@ import qualified Control.Monad.IO.Class as MIO import qualified Data.ByteString.Char8 as B8 import qualified Data.Int as Int +import qualified Data.List.NonEmpty as NE import qualified Data.Text as T import GHC.Stack (HasCallStack, withFrozenCallStack) import Hedgehog ((===)) @@ -41,22 +43,26 @@ mkFooBar :: Int.Int32 -> String -> FooBar mkFooBar f b = FooBar (Just f) (Just b) -fooBarTable :: Expr.Qualified Expr.TableName +fooBarTable :: Expr.QualifiedOrUnqualified Expr.TableName fooBarTable = - Expr.qualifyTable Nothing (Expr.tableName "foobar") + Expr.unqualified (Expr.tableName "foobar") -fooColumn :: Expr.ColumnName +fooColumn :: Expr.QualifiedOrUnqualified Expr.ColumnName fooColumn = - Expr.columnName "foo" + Expr.unqualified $ Expr.columnName "foo" fooColumnRef :: Expr.ValueExpression fooColumnRef = Expr.columnReference fooColumn -barColumn :: Expr.ColumnName +barColumn :: Expr.QualifiedOrUnqualified Expr.ColumnName barColumn = - Expr.columnName "bar" + Expr.unqualified $ Expr.columnName "bar" +barColumnAliased :: Expr.Qualified Expr.ColumnName +barColumnAliased = + Expr.aliasQualifyColumn (Expr.stringToAliasExpr "b") $ Expr.columnName "bar" + barColumnRef :: Expr.ValueExpression barColumnRef = Expr.columnReference barColumn @@ -68,33 +74,46 @@ findAllFooBars :: Expr.QueryExpr findAllFooBars = - Expr.queryExpr - (Expr.selectClause $ Expr.selectExpr Nothing) - (Expr.selectColumns [fooColumn, barColumn]) - (Just $ Expr.tableExpr (Expr.referencesTable fooBarTable) Nothing Nothing (Just orderByFoo) Nothing Nothing) + findAllFooBarsInTable fooBarTable +findAllFooBarsInTable :: Expr.QualifiedOrUnqualified Expr.TableName -> Expr.QueryExpr +findAllFooBarsInTable tableName = + let + tableRefList = + Expr.tableReferenceList + [ Expr.tableNameReference tableName (Just (Expr.stringToAliasExpr "b")) + ] + in + Expr.queryExpr + (Expr.selectClause $ Expr.selectExpr Nothing) + (Expr.selectColumns [fooColumn, Expr.untrackQualified barColumnAliased]) + (Just $ Expr.tableExpr tableRefList Nothing Nothing (Just orderByFoo) Nothing Nothing Nothing Nothing Nothing) + encodeFooBar :: FooBar -> [(Maybe B8.ByteString, SqlValue.SqlValue)] encodeFooBar fooBar = [ (Just (B8.pack "foo"), nullOr SqlValue.fromInt32 (foo fooBar)) , (Just (B8.pack "bar"), nullOr SqlValue.fromText (T.pack <$> bar fooBar)) ] -insertFooBarSource :: [FooBar] -> Expr.InsertSource +insertFooBarSource :: NE.NonEmpty FooBar -> Expr.InsertSource insertFooBarSource fooBars = let mkRow fooBar = - [ nullOr SqlValue.fromInt32 (foo fooBar) - , nullOr SqlValue.fromText (T.pack <$> bar fooBar) - ] + NE.fromList + [ Expr.valueExpression $ nullOr SqlValue.fromInt32 (foo fooBar) + , Expr.valueExpression $ nullOr SqlValue.fromText (T.pack <$> bar fooBar) + ] in - Expr.insertSqlValues (map mkRow fooBars) + Expr.valuesExprInsertSource + . Expr.valuesExprFromValueExpressions + $ fmap mkRow fooBars nullOr :: (a -> SqlValue.SqlValue) -> Maybe a -> SqlValue.SqlValue nullOr = maybe SqlValue.sqlNull withFooBarData :: Orville.ConnectionPool -> - [FooBar] -> + NE.NonEmpty FooBar -> (Orville.Connection -> IO a) -> HH.PropertyT IO a withFooBarData pool fooBars action = @@ -103,7 +122,7 @@ dropAndRecreateTestTable connection RawSql.executeVoid connection $ - Expr.insertExpr fooBarTable Nothing (insertFooBarSource fooBars) Nothing + Expr.insertExpr fooBarTable Nothing (insertFooBarSource fooBars) Nothing Nothing action connection diff --git a/test/Test/Expr/TextSearch.hs b/test/Test/Expr/TextSearch.hs new file mode 100644 --- /dev/null +++ b/test/Test/Expr/TextSearch.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Expr.TextSearch + ( textSearchTests + ) +where + +import qualified Control.Monad.IO.Class as MIO +import qualified Data.List.NonEmpty as NE +import Data.Text (Text) + +import qualified Orville.PostgreSQL as Orville +import qualified Orville.PostgreSQL.Execution as Execution +import qualified Orville.PostgreSQL.Expr as Expr +import qualified Orville.PostgreSQL.Raw.Connection as Conn +import qualified Orville.PostgreSQL.Raw.RawSql as RawSql +import qualified Orville.PostgreSQL.Raw.SqlValue as SqlValue + +import Test.Expr.TestSchema (FooBar (..), assertEqualFooBarRows, barColumn, barColumnRef, dropAndRecreateTestTable, fooBarTable, fooColumn, insertFooBarSource, mkFooBar) +import qualified Test.Property as Property + +textSearchTests :: Orville.ConnectionPool -> Property.Group +textSearchTests pool = + Property.group + "Expr - TSVector" + [ prop_matchesOneRow pool + , prop_toTSRank pool + , prop_plainToTSQuery pool + , prop_setTSWeight pool + ] + +prop_matchesOneRow :: Property.NamedDBProperty +prop_matchesOneRow = + tsVectorTest "TSVector @@ TSQuery finds one result" $ + TSVectorTest + { tsVectorValuesToInsert = NE.fromList [mkFooBar 1 "ant", mkFooBar 2 "bee", mkFooBar 3 "chihuahua"] + , tsVectorExpectedQueryResults = [mkFooBar 2 "bee"] + , whereClause = + Just . Expr.whereClause $ + Expr.tsMatch + ( Expr.toTSVector + barColumnRef + (Just Expr.englishRegConfig) + ) + ( Expr.toTSQuery + (Expr.valueExpression $ SqlValue.fromText ("bee" :: Text)) + Nothing + ) + , orderByClause = Nothing + } + +prop_setTSWeight :: Property.NamedDBProperty +prop_setTSWeight = + tsVectorTest "Sets weight on a TSVector" $ + TSVectorTest + { tsVectorValuesToInsert = NE.fromList [mkFooBar 1 "weighted"] + , tsVectorExpectedQueryResults = [mkFooBar 1 "weighted"] + , whereClause = + Just . Expr.whereClause $ + Expr.tsMatch + ( Expr.setTSWeight + (Expr.toTSVector barColumnRef Nothing) + Expr.tsWeightA + ) + (Expr.toTSQuery (Expr.valueExpression $ SqlValue.fromText ("weighted" :: Text)) Nothing) + , orderByClause = Nothing + } + +prop_plainToTSQuery :: Property.NamedDBProperty +prop_plainToTSQuery = + tsVectorTest "Creates TSQuery from plain text" $ + TSVectorTest + { tsVectorValuesToInsert = NE.fromList [mkFooBar 1 "plain query"] + , tsVectorExpectedQueryResults = [mkFooBar 1 "plain query"] + , whereClause = + Just . Expr.whereClause $ + Expr.tsMatch + (Expr.toTSVector barColumnRef Nothing) + (Expr.plainToTSQuery (Expr.valueExpression $ SqlValue.fromText ("plain query" :: Text)) Nothing) + , orderByClause = Nothing + } + +prop_toTSRank :: Property.NamedDBProperty +prop_toTSRank = + tsVectorTest "Calculates rank of TSVector and TSQuery" $ + TSVectorTest + { tsVectorValuesToInsert = NE.fromList [mkFooBar 1 "foo", mkFooBar 2 "bar"] + , tsVectorExpectedQueryResults = [mkFooBar 2 "bar", mkFooBar 1 "foo"] + , whereClause = Nothing + , orderByClause = + Just . Expr.orderByClause $ + Expr.orderByValueExpression + ( Expr.toTSRank + ( Expr.setTSWeight + (Expr.toTSVector barColumnRef Nothing) + Expr.tsWeightA + ) + (Expr.toTSQuery (Expr.valueExpression $ SqlValue.fromText ("bar" :: Text)) Nothing) + ) + Expr.descendingOrder + } + +data TSVectorTest = TSVectorTest + { tsVectorValuesToInsert :: NE.NonEmpty FooBar + , whereClause :: Maybe Expr.WhereClause + , orderByClause :: Maybe Expr.OrderByClause + , tsVectorExpectedQueryResults :: [FooBar] + } + +tsVectorTest :: String -> TSVectorTest -> Property.NamedDBProperty +tsVectorTest testName test = + Property.singletonNamedDBProperty testName $ \pool -> do + rows <- + MIO.liftIO $ + Conn.withPoolConnection pool $ \connection -> do + dropAndRecreateTestTable connection + + RawSql.executeVoid connection $ + Expr.insertExpr fooBarTable Nothing (insertFooBarSource $ tsVectorValuesToInsert test) Nothing Nothing + + result <- + RawSql.execute connection $ + Expr.queryExpr + (Expr.selectClause $ Expr.selectExpr Nothing) + (Expr.selectColumns [fooColumn, barColumn]) + (Just $ Expr.tableExpr (Expr.singleTableReferenceList fooBarTable) (whereClause test) Nothing (orderByClause test) Nothing Nothing Nothing Nothing Nothing) + + Execution.readRows result + + assertEqualFooBarRows rows (tsVectorExpectedQueryResults test) diff --git a/test/Test/Expr/Trigger.hs b/test/Test/Expr/Trigger.hs new file mode 100644 --- /dev/null +++ b/test/Test/Expr/Trigger.hs @@ -0,0 +1,73 @@ +module Test.Expr.Trigger + ( triggerTests + ) where + +import qualified Control.Monad.IO.Class as MIO + +import qualified Orville.PostgreSQL as Orville +import qualified Orville.PostgreSQL.Execution as Execution +import qualified Orville.PostgreSQL.Expr as Expr +import qualified Orville.PostgreSQL.Raw.Connection as Conn +import qualified Orville.PostgreSQL.Raw.RawSql as RawSql + +import Test.Expr.TestSchema (assertEqualFooBarRows, dropAndRecreateTestTable, findAllFooBars, fooBarTable, insertFooBarSource, mkFooBar) +import qualified Test.Property as Property + +triggerTests :: Orville.ConnectionPool -> Property.Group +triggerTests pool = + Property.group + "Expr - Trigger" + [ prop_triggers pool + ] + +prop_triggers :: Property.NamedDBProperty +prop_triggers = + Property.singletonNamedDBProperty "creates a trigger on a table" $ \pool -> do + let + fooBars = + pure $ mkFooBar 1 "dog" + + expectedFooBars = + [mkFooBar 1 "god"] + + triggerBody = + "BEGIN \ + \ NEW.bar = reverse (NEW.bar); \ + \ return NEW; \ + \END" + + triggerFunctionName = + Expr.unqualified $ Expr.functionName "test_trigger_function" + + createTriggerFunction = + Expr.createFunction + (Just Expr.orReplace) + triggerFunctionName + (Expr.returns Expr.returnTypeTrigger) + (Expr.language Expr.plpgsql) + (Expr.asDefinition triggerBody) + + createTrigger = + Expr.createTrigger + Nothing + (Expr.triggerName "test_trigger") + Expr.triggerBefore + (pure Expr.triggerOnInsert) + fooBarTable + Expr.triggerForEachRow + triggerFunctionName + + rows <- + MIO.liftIO $ + Conn.withPoolConnection pool $ \connection -> do + dropAndRecreateTestTable connection + RawSql.executeVoid connection createTriggerFunction + RawSql.executeVoid connection createTrigger + RawSql.executeVoid connection $ + Expr.insertExpr fooBarTable Nothing (insertFooBarSource fooBars) Nothing Nothing + + result <- RawSql.execute connection findAllFooBars + + Execution.readRows result + + assertEqualFooBarRows rows expectedFooBars diff --git a/test/Test/Expr/Vacuum.hs b/test/Test/Expr/Vacuum.hs new file mode 100644 --- /dev/null +++ b/test/Test/Expr/Vacuum.hs @@ -0,0 +1,90 @@ +module Test.Expr.Vacuum + ( vacuumTests + ) +where + +import qualified Data.ByteString.Char8 as B8 +import Data.List.NonEmpty (NonEmpty ((:|))) +import GHC.Stack (HasCallStack, withFrozenCallStack) +import qualified Hedgehog as HH + +import qualified Orville.PostgreSQL.Expr as Expr +import qualified Orville.PostgreSQL.Raw.RawSql as RawSql + +import qualified Test.Property as Property + +vacuumTests :: Property.Group +vacuumTests = + Property.group + "Expr - Vacuum" + [ prop_vacuumNoOptionsSingleTable + , prop_vacuumNoOptionsTwoTables + , prop_vacuumOneOptionSingleTable + , prop_vacuumOneOptionTwoTables + , prop_vacuumTwoOptionsOneTable + , prop_vacuumTwoOptionsTwoTables + ] + +prop_vacuumNoOptionsSingleTable :: Property.NamedProperty +prop_vacuumNoOptionsSingleTable = + Property.singletonNamedProperty "vacuumExpr with empty options and a single table generates expected sql" $ + assertVacuumEquals + "VACUUM \"foo\"" + [] + singleTable + +prop_vacuumNoOptionsTwoTables :: Property.NamedProperty +prop_vacuumNoOptionsTwoTables = + Property.singletonNamedProperty "vacuumExpr with empty options and a pair of tables generates expected sql" $ + assertVacuumEquals + "VACUUM \"foo\", \"bar\"" + [] + twoTables + +prop_vacuumOneOptionSingleTable :: Property.NamedProperty +prop_vacuumOneOptionSingleTable = + Property.singletonNamedProperty "vacuumExpr with one option and a single table generates expected sql" $ + assertVacuumEquals + "VACUUM (FULL TRUE) \"foo\"" + [Expr.vacuumFull True] + singleTable + +prop_vacuumOneOptionTwoTables :: Property.NamedProperty +prop_vacuumOneOptionTwoTables = + Property.singletonNamedProperty "vacuumExpr with one option and a pair of tables generates expected sql" $ + assertVacuumEquals + "VACUUM (FULL TRUE) \"foo\", \"bar\"" + [Expr.vacuumFull True] + twoTables + +prop_vacuumTwoOptionsOneTable :: Property.NamedProperty +prop_vacuumTwoOptionsOneTable = + Property.singletonNamedProperty "vacuumExpr with two options and a single table generates expected sql" $ + assertVacuumEquals + "VACUUM (FULL TRUE, VERBOSE TRUE) \"foo\"" + [ Expr.vacuumFull True + , Expr.vacuumVerbose True + ] + singleTable + +prop_vacuumTwoOptionsTwoTables :: Property.NamedProperty +prop_vacuumTwoOptionsTwoTables = + Property.singletonNamedProperty "vacuumExpr with two options and a pair of tables generates expected sql" $ + assertVacuumEquals + "VACUUM (FULL TRUE, VERBOSE TRUE) \"foo\", \"bar\"" + [ Expr.vacuumFull True + , Expr.vacuumVerbose True + ] + twoTables + +assertVacuumEquals :: (HH.MonadTest m, HasCallStack) => String -> [Expr.VacuumOption] -> NonEmpty (Expr.QualifiedOrUnqualified Expr.TableName) -> m () +assertVacuumEquals mbVacuum vacuumOptions vacuumTables = + withFrozenCallStack $ + RawSql.toExampleBytes (Expr.vacuumExpr vacuumOptions vacuumTables) HH.=== B8.pack mbVacuum + +singleTable :: NonEmpty (Expr.QualifiedOrUnqualified Expr.TableName) +singleTable = pure . Expr.unqualified $ Expr.tableName "foo" + +twoTables :: NonEmpty (Expr.QualifiedOrUnqualified Expr.TableName) +twoTables = + (Expr.unqualified $ Expr.tableName "foo") :| [Expr.unqualified $ Expr.tableName "bar"] diff --git a/test/Test/Expr/Where.hs b/test/Test/Expr/Where.hs --- a/test/Test/Expr/Where.hs +++ b/test/Test/Expr/Where.hs @@ -6,6 +6,7 @@ import qualified Control.Monad.IO.Class as MIO import Data.Int (Int32) import Data.List.NonEmpty (NonEmpty ((:|))) +import qualified Data.List.NonEmpty as NE import qualified Data.Text as T import qualified Orville.PostgreSQL as Orville @@ -23,12 +24,15 @@ Property.group "Expr - WhereClause" $ [ prop_noWhereClauseSpecified pool , prop_equalsOp pool + , prop_isDistinctFromOp pool + , prop_isNotDistinctFromOp pool , prop_greaterThanOp pool , prop_greaterThanOrEqualsOp pool , prop_lessThanOp pool , prop_lessThanOrEqualsToOp pool , prop_andExpr pool , prop_orExpr pool + , prop_notExpr pool , prop_valueIn pool , prop_valueNotIn pool , prop_tupleIn pool @@ -39,7 +43,7 @@ prop_noWhereClauseSpecified = whereConditionTest "Returns all rows when where clause is specified" $ WhereConditionTest - { whereValuesToInsert = [mkFooBar 1 "ant", mkFooBar 2 "bee", mkFooBar 3 "chihuahua"] + { whereValuesToInsert = NE.fromList [mkFooBar 1 "ant", mkFooBar 2 "bee", mkFooBar 3 "chihuahua"] , whereExpectedQueryResults = [mkFooBar 1 "ant", mkFooBar 2 "bee", mkFooBar 3 "chihuahua"] , whereClause = Nothing } @@ -48,18 +52,43 @@ prop_equalsOp = whereConditionTest "equalsOp matches exact value" $ WhereConditionTest - { whereValuesToInsert = [mkFooBar 1 "ant", mkFooBar 2 "bee", mkFooBar 3 "chihuahua"] + { whereValuesToInsert = NE.fromList [mkFooBar 1 "ant", mkFooBar 2 "bee", mkFooBar 3 "chihuahua"] , whereExpectedQueryResults = [mkFooBar 2 "bee"] , whereClause = Just . Expr.whereClause $ Expr.equals fooColumnRef (int32ValueExpr 2) } +prop_isDistinctFromOp :: Property.NamedDBProperty +prop_isDistinctFromOp = + whereConditionTest "isDistinctFromOp matches on null correctly" $ + WhereConditionTest + { whereValuesToInsert = NE.fromList [FooBar Nothing (Just "ant"), mkFooBar 2 "bee", FooBar Nothing (Just "chihuahua")] + , whereExpectedQueryResults = [mkFooBar 2 "bee"] + , whereClause = + Just . Expr.whereClause $ + Expr.isDistinctFrom fooColumnRef (Expr.valueExpression SqlValue.sqlNull) + } + +prop_isNotDistinctFromOp :: Property.NamedDBProperty +prop_isNotDistinctFromOp = + whereConditionTest "isNotDistinctFromOp matches on null correctly" $ + let + expectedResults = [FooBar Nothing (Just "ant"), FooBar Nothing (Just "chihuahua")] + in + WhereConditionTest + { whereValuesToInsert = mkFooBar 2 "bee" :| expectedResults + , whereExpectedQueryResults = expectedResults + , whereClause = + Just . Expr.whereClause $ + Expr.isNotDistinctFrom fooColumnRef (Expr.valueExpression SqlValue.sqlNull) + } + prop_greaterThanOp :: Property.NamedDBProperty prop_greaterThanOp = whereConditionTest "greaterThanOp matches greater values" $ WhereConditionTest - { whereValuesToInsert = [mkFooBar 1 "ant", mkFooBar 2 "bee", mkFooBar 3 "chihuahua"] + { whereValuesToInsert = NE.fromList [mkFooBar 1 "ant", mkFooBar 2 "bee", mkFooBar 3 "chihuahua"] , whereExpectedQueryResults = [mkFooBar 3 "chihuahua"] , whereClause = Just . Expr.whereClause $ @@ -70,7 +99,7 @@ prop_greaterThanOrEqualsOp = whereConditionTest "greaterThanOrEqualsOp matches greater or equal values" $ WhereConditionTest - { whereValuesToInsert = [mkFooBar 1 "ant", mkFooBar 2 "bee", mkFooBar 3 "chihuahua"] + { whereValuesToInsert = NE.fromList [mkFooBar 1 "ant", mkFooBar 2 "bee", mkFooBar 3 "chihuahua"] , whereExpectedQueryResults = [mkFooBar 2 "bee", mkFooBar 3 "chihuahua"] , whereClause = Just . Expr.whereClause $ @@ -81,7 +110,7 @@ prop_lessThanOp = whereConditionTest "lessThanOp matches lesser values" $ WhereConditionTest - { whereValuesToInsert = [mkFooBar 1 "ant", mkFooBar 2 "bee", mkFooBar 3 "chihuahua"] + { whereValuesToInsert = NE.fromList [mkFooBar 1 "ant", mkFooBar 2 "bee", mkFooBar 3 "chihuahua"] , whereExpectedQueryResults = [mkFooBar 1 "ant"] , whereClause = Just . Expr.whereClause $ @@ -92,7 +121,7 @@ prop_lessThanOrEqualsToOp = whereConditionTest "lessThanOrEqualsOp matches lesser or equal values" $ WhereConditionTest - { whereValuesToInsert = [mkFooBar 1 "ant", mkFooBar 2 "bee", mkFooBar 3 "chihuahua"] + { whereValuesToInsert = NE.fromList [mkFooBar 1 "ant", mkFooBar 2 "bee", mkFooBar 3 "chihuahua"] , whereExpectedQueryResults = [mkFooBar 1 "ant", mkFooBar 2 "bee"] , whereClause = Just . Expr.whereClause $ @@ -103,7 +132,7 @@ prop_andExpr = whereConditionTest "andExpr requires both conditions to be true" $ WhereConditionTest - { whereValuesToInsert = [mkFooBar 1 "dog", mkFooBar 2 "dingo", mkFooBar 3 "dog"] + { whereValuesToInsert = NE.fromList [mkFooBar 1 "dog", mkFooBar 2 "dingo", mkFooBar 3 "dog"] , whereExpectedQueryResults = [mkFooBar 3 "dog"] , whereClause = Just . Expr.whereClause $ @@ -116,7 +145,7 @@ prop_orExpr = whereConditionTest "orExpr requires either conditions to be true" $ WhereConditionTest - { whereValuesToInsert = [mkFooBar 1 "dog", mkFooBar 2 "dingo", mkFooBar 3 "dog"] + { whereValuesToInsert = NE.fromList [mkFooBar 1 "dog", mkFooBar 2 "dingo", mkFooBar 3 "dog"] , whereExpectedQueryResults = [mkFooBar 2 "dingo", mkFooBar 3 "dog"] , whereClause = Just . Expr.whereClause $ @@ -125,11 +154,24 @@ (Expr.equals barColumnRef (textValueExpr "dingo")) } +prop_notExpr :: Property.NamedDBProperty +prop_notExpr = + whereConditionTest "notExpr inverts condition" $ + WhereConditionTest + { whereValuesToInsert = NE.fromList [mkFooBar 1 "dog", mkFooBar 2 "dingo", mkFooBar 3 "dog"] + , whereExpectedQueryResults = [mkFooBar 2 "dingo"] + , whereClause = + Just . Expr.whereClause . Expr.notExpr $ + Expr.orExpr + (Expr.equals fooColumnRef (int32ValueExpr 3)) + (Expr.equals barColumnRef (textValueExpr "dog")) + } + prop_valueIn :: Property.NamedDBProperty prop_valueIn = whereConditionTest "valueIn requires the column's value to be in the list" $ WhereConditionTest - { whereValuesToInsert = [mkFooBar 1 "dog", mkFooBar 2 "dingo", mkFooBar 3 "dog"] + { whereValuesToInsert = NE.fromList [mkFooBar 1 "dog", mkFooBar 2 "dingo", mkFooBar 3 "dog"] , whereExpectedQueryResults = [mkFooBar 1 "dog", mkFooBar 3 "dog"] , whereClause = Just . Expr.whereClause $ @@ -142,7 +184,7 @@ prop_valueNotIn = whereConditionTest "valueNotIn requires the column's value to not be in the list" $ WhereConditionTest - { whereValuesToInsert = [mkFooBar 1 "dog", mkFooBar 2 "dingo", mkFooBar 3 "dog"] + { whereValuesToInsert = NE.fromList [mkFooBar 1 "dog", mkFooBar 2 "dingo", mkFooBar 3 "dog"] , whereExpectedQueryResults = [mkFooBar 2 "dingo"] , whereClause = Just . Expr.whereClause $ @@ -155,7 +197,7 @@ prop_tupleIn = whereConditionTest "tupleIn requires the column value combination to be in the list" $ WhereConditionTest - { whereValuesToInsert = [mkFooBar 1 "dog", mkFooBar 2 "dingo", mkFooBar 3 "dog"] + { whereValuesToInsert = NE.fromList [mkFooBar 1 "dog", mkFooBar 2 "dingo", mkFooBar 3 "dog"] , whereExpectedQueryResults = [mkFooBar 1 "dog", mkFooBar 2 "dingo"] , whereClause = Just . Expr.whereClause $ @@ -170,7 +212,7 @@ prop_tupleNotIn = whereConditionTest "tupleNotIn requires the column value combination to not be in the list" $ WhereConditionTest - { whereValuesToInsert = [mkFooBar 1 "dog", mkFooBar 2 "dingo", mkFooBar 3 "dog"] + { whereValuesToInsert = NE.fromList [mkFooBar 1 "dog", mkFooBar 2 "dingo", mkFooBar 3 "dog"] , whereExpectedQueryResults = [mkFooBar 3 "dog"] , whereClause = Just . Expr.whereClause $ @@ -190,7 +232,7 @@ Expr.valueExpression . SqlValue.fromText . T.pack data WhereConditionTest = WhereConditionTest - { whereValuesToInsert :: [FooBar] + { whereValuesToInsert :: NE.NonEmpty FooBar , whereClause :: Maybe Expr.WhereClause , whereExpectedQueryResults :: [FooBar] } @@ -204,14 +246,14 @@ dropAndRecreateTestTable connection RawSql.executeVoid connection $ - Expr.insertExpr fooBarTable Nothing (insertFooBarSource $ whereValuesToInsert test) Nothing + Expr.insertExpr fooBarTable Nothing (insertFooBarSource $ whereValuesToInsert test) Nothing Nothing result <- RawSql.execute connection $ Expr.queryExpr (Expr.selectClause $ Expr.selectExpr Nothing) (Expr.selectColumns [fooColumn, barColumn]) - (Just $ Expr.tableExpr (Expr.referencesTable fooBarTable) (whereClause test) Nothing Nothing Nothing Nothing) + (Just $ Expr.tableExpr (Expr.singleTableReferenceList fooBarTable) (whereClause test) Nothing Nothing Nothing Nothing Nothing Nothing Nothing) Execution.readRows result diff --git a/test/Test/Expr/Window.hs b/test/Test/Expr/Window.hs new file mode 100644 --- /dev/null +++ b/test/Test/Expr/Window.hs @@ -0,0 +1,60 @@ +module Test.Expr.Window + ( windowTests + ) +where + +import qualified Data.ByteString.Char8 as B8 +import GHC.Stack (HasCallStack, withFrozenCallStack) +import qualified Hedgehog as HH + +import qualified Orville.PostgreSQL.Expr as Expr +import qualified Orville.PostgreSQL.Raw.RawSql as RawSql +import qualified Orville.PostgreSQL.Raw.SqlValue as SqlValue + +import Test.Expr.TestSchema (barColumn) +import qualified Test.Property as Property + +windowTests :: Property.Group +windowTests = + Property.group + "Expr - Window" + [ prop_windowClauseSingleDef + , prop_windowClauseMultiDef + ] + +prop_windowClauseSingleDef :: Property.NamedProperty +prop_windowClauseSingleDef = + let + windowDef = Expr.windowDefinition Nothing (Just partitionBy) (Just orderBy) (Just frameClause) + windowDefName = Expr.fromIdentifier $ Expr.identifier "a" + partitionBy = Expr.partitionBy (pure . Expr.valueExpression $ SqlValue.fromInt32 1) + orderBy = Expr.orderByClause $ Expr.orderByColumnName barColumn Expr.ascendingOrder + frameClause = Expr.frameClause (Just Expr.rowsFrameMode) Expr.unboundedPrecedingFrameStart (Just Expr.unboundedFollowingFrameEnd) (Just Expr.tiesFrameExclusion) + in + Property.singletonNamedProperty "window clause with single window definition containing a partition by, an order by, and a frame clause generates expected sql." + . assertWindowEquals + "WINDOW \"a\" AS (PARTITION BY $1 ORDER BY \"bar\" ASC ROWS BETWEEN UNBOUNDED PRECEDING AND UNBOUNDED FOLLOWING EXCLUDE TIES)" + . Expr.windowClause + $ Expr.namedWindowDefinition windowDefName windowDef + +prop_windowClauseMultiDef :: Property.NamedProperty +prop_windowClauseMultiDef = + let + windowDef1 = Expr.windowDefinition Nothing (Just partitionBy) Nothing Nothing + windowDef1Name = Expr.fromIdentifier $ Expr.identifier "a" + windowDef2 = Expr.windowDefinition (Just windowDef1Name) Nothing (Just orderBy) (Just frameClause) + windowDef2Name = Expr.fromIdentifier $ Expr.identifier "b" + partitionBy = Expr.partitionBy (pure . Expr.valueExpression $ SqlValue.fromInt32 1) + orderBy = Expr.orderByClause $ Expr.orderByColumnName barColumn Expr.ascendingOrder + frameClause = Expr.frameClause (Just Expr.rowsFrameMode) Expr.unboundedPrecedingFrameStart (Just Expr.unboundedFollowingFrameEnd) (Just Expr.tiesFrameExclusion) + in + Property.singletonNamedProperty "window clause with two window definitions, where the second \"copies\" the first, generates expected sql." + . assertWindowEquals + "WINDOW \"a\" AS (PARTITION BY $1), \"b\" AS (\"a\" ORDER BY \"bar\" ASC ROWS BETWEEN UNBOUNDED PRECEDING AND UNBOUNDED FOLLOWING EXCLUDE TIES)" + . Expr.windowClause + $ Expr.namedWindowDefinition windowDef1Name windowDef1 <> Expr.namedWindowDefinition windowDef2Name windowDef2 + +assertWindowEquals :: (HH.MonadTest m, HasCallStack) => String -> Expr.WindowClause -> m () +assertWindowEquals windowClauseStr windowClause = + withFrozenCallStack $ + RawSql.toExampleBytes windowClause HH.=== B8.pack windowClauseStr diff --git a/test/Test/FieldDefinition.hs b/test/Test/FieldDefinition.hs --- a/test/Test/FieldDefinition.hs +++ b/test/Test/FieldDefinition.hs @@ -248,15 +248,22 @@ Expr.insertExpr testTable Nothing - (Expr.insertSqlValues [[Marshall.fieldValueToSqlValue fieldDef value]]) + ( Expr.valuesExprInsertSource + . Expr.valuesExprFromValueExpressions + . pure + . pure + . Expr.valueExpression + $ Marshall.toComparableSqlValue fieldDef value + ) Nothing + Nothing result <- RawSql.execute connection $ Expr.queryExpr (Expr.selectClause $ Expr.selectExpr Nothing) - (Expr.selectColumns [Marshall.fieldColumnName fieldDef]) - (Just $ Expr.tableExpr (Expr.referencesTable testTable) Nothing Nothing Nothing Nothing Nothing) + (Expr.selectColumns [Expr.unqualified (Marshall.fieldColumnName fieldDef)]) + (Just $ Expr.tableExpr (Expr.singleTableReferenceList testTable) Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing) Execution.readRows result @@ -292,15 +299,22 @@ Expr.insertExpr testTable Nothing - (Expr.insertSqlValues [[Marshall.fieldValueToSqlValue fieldDef value]]) + ( Expr.valuesExprInsertSource + . Expr.valuesExprFromValueExpressions + . pure + . pure + . Expr.valueExpression + $ Marshall.toComparableSqlValue fieldDef value + ) Nothing + Nothing result <- RawSql.execute connection $ Expr.queryExpr (Expr.selectClause $ Expr.selectExpr Nothing) - (Expr.selectColumns [Marshall.fieldColumnName fieldDef]) - (Just $ Expr.tableExpr (Expr.referencesTable testTable) Nothing Nothing Nothing Nothing Nothing) + (Expr.selectColumns [Expr.unqualified (Marshall.fieldColumnName fieldDef)]) + (Just $ Expr.tableExpr (Expr.singleTableReferenceList testTable) Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing) Execution.readRows result @@ -327,8 +341,14 @@ Expr.insertExpr testTable Nothing - (Expr.insertSqlValues [[SqlValue.sqlNull]]) + ( Expr.valuesExprInsertSource + . Expr.valuesExprFromValueExpressions + . pure + . pure + $ Expr.valueExpression SqlValue.sqlNull + ) Nothing + Nothing case result of Left err -> @@ -362,13 +382,14 @@ Nothing (RawSql.unsafeSqlExpression "VALUES(DEFAULT)") Nothing + Nothing result <- RawSql.execute connection $ Expr.queryExpr (Expr.selectClause $ Expr.selectExpr Nothing) - (Expr.selectColumns [Marshall.fieldColumnName fieldDef]) - (Just $ Expr.tableExpr (Expr.referencesTable testTable) Nothing Nothing Nothing Nothing Nothing) + (Expr.selectColumns [Expr.unqualified (Marshall.fieldColumnName fieldDef)]) + (Just $ Expr.tableExpr (Expr.singleTableReferenceList testTable) Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing) Execution.readRows result @@ -401,10 +422,11 @@ Nothing (RawSql.unsafeSqlExpression "VALUES(DEFAULT)") Nothing + Nothing -testTable :: Expr.Qualified Expr.TableName +testTable :: Expr.QualifiedOrUnqualified Expr.TableName testTable = - Expr.qualifyTable Nothing (Expr.tableName "field_definition_test") + Expr.unqualified (Expr.tableName "field_definition_test") dropAndRecreateTestTable :: Marshall.FieldDefinition nullability a -> Orville.Connection -> IO () dropAndRecreateTestTable fieldDef connection = do diff --git a/test/Test/MarshallError.hs b/test/Test/MarshallError.hs --- a/test/Test/MarshallError.hs +++ b/test/Test/MarshallError.hs @@ -33,9 +33,7 @@ , prop_showMarshallErrorRaisedFromOrvilleContext pool ] -{- | - Shared example used to test error detail level rendering of decoding errors - below. +{- | Shared example used to test error detail level rendering of decoding errors below. @since 1.0.0.0 -} @@ -134,9 +132,7 @@ \Unable to decode columns from result set: [REDACTED]. \ \Value(s) that failed to decode: [bar = baz]" -{- | - Shared example used to test error detail level rendering of missing column - errors below. +{- | Shared example used to test error detail level rendering of missing column errors below. @since 1.0.0.0 -} diff --git a/test/Test/Orphans.hs b/test/Test/Orphans.hs new file mode 100644 --- /dev/null +++ b/test/Test/Orphans.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.Orphans () where + +import qualified Data.ByteString.Char8 as B8 +import qualified Data.List as List +import qualified Data.List.NonEmpty as NE + +import qualified Orville.PostgreSQL.Marshall as Marshall +import qualified Orville.PostgreSQL.Raw.PgTextFormatValue as PgTextFormatValue +import qualified Orville.PostgreSQL.Raw.SqlValue as SqlValue + +instance Show SqlValue.SqlValue where + show = + SqlValue.foldSqlValue + (B8.unpack . PgTextFormatValue.toByteString) + (\vals -> "(" <> List.intercalate ", " (NE.toList vals) <> ")") + "NULL" + +deriving instance Show Marshall.FieldIdentityGeneration +deriving instance Enum Marshall.FieldIdentityGeneration +deriving instance Bounded Marshall.FieldIdentityGeneration diff --git a/test/Test/PgAssert.hs b/test/Test/PgAssert.hs --- a/test/Test/PgAssert.hs +++ b/test/Test/PgAssert.hs @@ -12,25 +12,41 @@ , assertColumnExists , assertColumnDefaultExists , assertColumnDefaultMatches + , assertFieldIdentityGenerationMatches , assertUniqueConstraintExists , assertForeignKeyConstraintExists , assertIndexExists + , assertFunctionExists + , assertFunctionExistsInSchema + , assertFunctionDoesNotExist + , assertFunctionDoesNotExistInSchema + , assertTriggerExists + , assertTriggerDoesNotExist + , assertExtensionLoaded + , assertExtensionNotLoaded , ForeignKeyInfo (..) + , assertTableHasComment + , assertTableDoesNotHaveComment + , assertTableColumnsHaveOrDoNotHaveComments ) where +import qualified Control.Exception.Safe as SafeEx import qualified Control.Monad as Monad import qualified Control.Monad.IO.Class as MIO +import qualified Data.Foldable as Fold import qualified Data.List as List import qualified Data.List.NonEmpty as NEL import qualified Data.Map.Strict as Map import qualified Data.String as String +import qualified Data.Text as T import qualified Data.Text.Encoding as Enc import GHC.Stack (HasCallStack, withFrozenCallStack) import Hedgehog ((===)) import qualified Hedgehog as HH import qualified Orville.PostgreSQL as Orville +import qualified Orville.PostgreSQL.Marshall as Marshall import qualified Orville.PostgreSQL.PgCatalog as PgCatalog import qualified Orville.PostgreSQL.Raw.RawSql as RawSql @@ -126,8 +142,10 @@ dbDesc <- MIO.liftIO $ Orville.runOrville pool $ do - PgCatalog.describeDatabaseRelations + PgCatalog.describeDatabase [(String.fromString schemaName, String.fromString relationName)] + [] + [] case PgCatalog.lookupRelation (String.fromString schemaName, String.fromString relationName) dbDesc of Nothing -> do @@ -148,9 +166,11 @@ assertRelationDoesNotExistInSchema pool schemaName tableName relationKind = do dbDesc <- MIO.liftIO $ - Orville.runOrville pool $ do - PgCatalog.describeDatabaseRelations + Orville.runOrville pool $ + PgCatalog.describeDatabase [(String.fromString schemaName, String.fromString tableName)] + [] + [] case PgCatalog.lookupRelation (String.fromString schemaName, String.fromString tableName) dbDesc of Nothing -> @@ -198,6 +218,29 @@ Just attr -> pure attr +assertFieldIdentityGenerationMatches :: + (HH.MonadTest m, HasCallStack) => + PgCatalog.RelationDescription -> + String -> + Maybe Marshall.FieldIdentityGeneration -> + m () +assertFieldIdentityGenerationMatches relationDesc columnName mbExpectedIdentityGeneration = do + attr <- assertColumnExists relationDesc columnName + case (PgCatalog.pgAttributeIdentity attr, mbExpectedIdentityGeneration) of + (Nothing, Nothing) -> pure () + (Nothing, Just _) -> do + HH.annotate $ columnName <> " expected to be an identity but was not" + HH.failure + (Just _, Nothing) -> do + HH.annotate $ columnName <> " expected to not be an identity but was" + HH.failure + (Just colId, Just expectedIdentityGeneration) -> + if colId == expectedIdentityGeneration + then pure () + else do + HH.annotate $ columnName <> " did not match expected identity generation" + HH.failure + assertColumnDefaultExists :: (HH.MonadTest m, HasCallStack) => PgCatalog.RelationDescription -> @@ -371,3 +414,228 @@ List.any predicate (PgCatalog.relationIndexes relationDesc) + +assertFunctionExists :: + (HH.MonadTest m, MIO.MonadIO m, SafeEx.MonadCatch m, HasCallStack) => + Orville.ConnectionPool -> + String -> + m PgCatalog.PgProc +assertFunctionExists pool = + assertFunctionExistsInSchema pool "public" + +assertFunctionExistsInSchema :: + (HH.MonadTest m, MIO.MonadIO m, SafeEx.MonadCatch m, HasCallStack) => + Orville.ConnectionPool -> + String -> + String -> + m PgCatalog.PgProc +assertFunctionExistsInSchema pool schemaName functionName = do + namespaceOid <- + HH.evalMaybeM + . MIO.liftIO + . Orville.runOrville pool + . fmap (fmap PgCatalog.pgNamespaceOid) + $ Orville.findFirstEntityBy + PgCatalog.pgNamespaceTable + ( Orville.where_ + (Orville.fieldEquals PgCatalog.namespaceNameField (String.fromString schemaName)) + ) + + mbProc <- + MIO.liftIO $ + Orville.runOrville pool $ do + Orville.findFirstEntityBy + PgCatalog.pgProcTable + ( Orville.where_ + ( Orville.andExpr + (Orville.fieldEquals PgCatalog.procNamespaceOidField namespaceOid) + (Orville.fieldEquals PgCatalog.procNameField (String.fromString functionName)) + ) + ) + + case mbProc of + Nothing -> do + withFrozenCallStack $ do + HH.annotate $ functionName <> " function not found" + HH.failure + Just proc -> do + pure proc + +assertFunctionDoesNotExist :: + (HH.MonadTest m, MIO.MonadIO m, SafeEx.MonadCatch m, HasCallStack) => + Orville.ConnectionPool -> + String -> + m () +assertFunctionDoesNotExist pool = + assertFunctionDoesNotExistInSchema pool "public" + +assertFunctionDoesNotExistInSchema :: + (HH.MonadTest m, MIO.MonadIO m, SafeEx.MonadCatch m, HasCallStack) => + Orville.ConnectionPool -> + String -> + String -> + m () +assertFunctionDoesNotExistInSchema pool schemaName functionName = do + namespaceOid <- + HH.evalMaybeM + . MIO.liftIO + . Orville.runOrville pool + . fmap (fmap PgCatalog.pgNamespaceOid) + $ Orville.findFirstEntityBy + PgCatalog.pgNamespaceTable + ( Orville.where_ + (Orville.fieldEquals PgCatalog.namespaceNameField (String.fromString schemaName)) + ) + + mbProc <- + MIO.liftIO $ + Orville.runOrville pool $ do + Orville.findFirstEntityBy + PgCatalog.pgProcTable + ( Orville.where_ + ( Orville.andExpr + (Orville.fieldEquals PgCatalog.procNamespaceOidField namespaceOid) + (Orville.fieldEquals PgCatalog.procNameField (String.fromString functionName)) + ) + ) + + case mbProc of + Nothing -> do + pure () + Just _proc -> do + withFrozenCallStack $ do + HH.annotate $ functionName <> " function was found, but was not expected" + HH.failure + +assertTriggerExists :: + (HH.MonadTest m, HasCallStack) => + PgCatalog.RelationDescription -> + String -> + m () +assertTriggerExists relationDesc triggerName = + let + nameMatches trigger = + PgCatalog.pgTriggerName trigger == String.fromString triggerName + in + case List.find nameMatches (PgCatalog.relationTriggers relationDesc) of + Nothing -> + withFrozenCallStack $ do + HH.annotate $ triggerName <> " trigger not found" + HH.failure + Just _trigger -> + pure () + +assertTriggerDoesNotExist :: + (HH.MonadTest m, HasCallStack) => + PgCatalog.RelationDescription -> + String -> + m () +assertTriggerDoesNotExist relationDesc triggerName = + let + nameMatches trigger = + PgCatalog.pgTriggerName trigger == String.fromString triggerName + in + case List.find nameMatches (PgCatalog.relationTriggers relationDesc) of + Nothing -> + pure () + Just _trigger -> + withFrozenCallStack $ do + HH.annotate $ triggerName <> " trigger was found, but was not expected" + HH.failure + +assertExtensionLoaded :: + (HH.MonadTest m, MIO.MonadIO m, HasCallStack) => + Orville.ConnectionPool -> + String -> + m PgCatalog.PgExtension +assertExtensionLoaded pool extensionName = do + dbDesc <- + MIO.liftIO $ + Orville.runOrville pool $ do + PgCatalog.describeDatabase + [] + [] + [String.fromString extensionName] + + case PgCatalog.lookupExtension (String.fromString extensionName) dbDesc of + Nothing -> do + withFrozenCallStack $ do + HH.annotate $ extensionName <> " extension not found" + HH.failure + Just ext -> + pure ext + +assertExtensionNotLoaded :: + (HH.MonadTest m, MIO.MonadIO m, HasCallStack) => + Orville.ConnectionPool -> + String -> + m () +assertExtensionNotLoaded pool extensionName = do + dbDesc <- + MIO.liftIO $ + Orville.runOrville pool $ do + PgCatalog.describeDatabase + [] + [] + [String.fromString extensionName] + + case PgCatalog.lookupExtension (String.fromString extensionName) dbDesc of + Nothing -> + pure () + Just _ -> + withFrozenCallStack $ do + HH.annotate $ extensionName <> " was found but not expected" + HH.failure + +assertTableHasComment :: + (HH.MonadTest m, MIO.MonadIO m, HasCallStack) => + Orville.ConnectionPool -> + String -> + T.Text -> + m () +assertTableHasComment pool tableName expectedComment = do + relationDesc <- assertTableExists pool tableName + PgCatalog.relationComment relationDesc HH.=== Just expectedComment + +assertTableDoesNotHaveComment :: + (HH.MonadTest m, MIO.MonadIO m, HasCallStack) => + Orville.ConnectionPool -> + String -> + m () +assertTableDoesNotHaveComment pool tableName = do + relationDesc <- assertTableExists pool tableName + PgCatalog.relationComment relationDesc HH.=== Nothing + +assertTableColumnHasComment :: + (HH.MonadTest m, MIO.MonadIO m, HasCallStack) => + Orville.ConnectionPool -> + String -> + String -> + T.Text -> + m () +assertTableColumnHasComment pool tableName fieldName expectedComment = do + relationDesc <- assertTableExists pool tableName + PgCatalog.lookupAttributeComment (String.fromString fieldName) relationDesc HH.=== Just expectedComment + +assertTableColumnDoesNotHaveComment :: + (HH.MonadTest m, MIO.MonadIO m, HasCallStack) => + Orville.ConnectionPool -> + String -> + String -> + m () +assertTableColumnDoesNotHaveComment pool tableName fieldName = do + relationDesc <- assertTableExists pool tableName + PgCatalog.lookupAttributeComment (String.fromString fieldName) relationDesc HH.=== Nothing + +assertTableColumnsHaveOrDoNotHaveComments :: + (HH.MonadTest m, MIO.MonadIO m, HasCallStack) => + Orville.ConnectionPool -> + String -> + [(String, Maybe String)] -> + m () +assertTableColumnsHaveOrDoNotHaveComments pool tableName = + Fold.traverse_ + ( \(colName, mbComment) -> case mbComment of + Just comment -> assertTableColumnHasComment pool tableName colName (T.pack comment) + Nothing -> assertTableColumnDoesNotHaveComment pool tableName colName + ) diff --git a/test/Test/PgCatalog.hs b/test/Test/PgCatalog.hs --- a/test/Test/PgCatalog.hs +++ b/test/Test/PgCatalog.hs @@ -4,6 +4,7 @@ where import qualified Control.Monad.IO.Class as MIO +import Data.List.NonEmpty (NonEmpty ((:|))) import qualified Data.Map.Strict as Map import qualified Data.Set as Set import qualified Data.String as String @@ -12,6 +13,7 @@ import qualified Hedgehog as HH import qualified Orville.PostgreSQL as Orville +import qualified Orville.PostgreSQL.Expr as Expr import qualified Orville.PostgreSQL.PgCatalog as PgCatalog import qualified Test.Entities.Foo as Foo @@ -26,6 +28,8 @@ , prop_queryPgAttribute pool , prop_queryPgAttributeDefault pool , prop_queryPgConstraint pool + , prop_queryPgTrigger pool + , prop_queryPgProc pool , prop_describeDatabaseRelations pool ] @@ -128,6 +132,80 @@ map PgCatalog.pgConstraintType constraints === [PgCatalog.PrimaryKeyConstraint] map PgCatalog.pgConstraintKey constraints === [Just [1]] +prop_queryPgTrigger :: Property.NamedDBProperty +prop_queryPgTrigger = + Property.singletonNamedDBProperty "Can query the pg_trigger table to find out about a trigger" $ \pool -> do + let + triggerFunctionName = + Expr.unqualified $ Expr.functionName "test_trigger_function" + + createTriggerFunction = + Expr.createFunction + (Just Expr.orReplace) + triggerFunctionName + (Expr.returns Expr.returnTypeTrigger) + (Expr.language Expr.plpgsql) + (Expr.asDefinition "BEGIN return NEW; END") + + createTrigger = + Expr.createTrigger + Nothing + (Expr.triggerName "test_trigger") + Expr.triggerBefore + (Expr.triggerOnInsert :| []) + (Orville.tableIdQualifiedName (Orville.tableIdentifier Foo.table)) + Expr.triggerForEachRow + triggerFunctionName + + maybePgClassRecord <- + HH.evalIO . Foo.withTable pool $ do + Orville.executeVoid Orville.DDLQuery createTriggerFunction + Orville.executeVoid Orville.DDLQuery createTrigger + Orville.findFirstEntityBy + PgCatalog.pgClassTable + (Orville.where_ $ Orville.fieldEquals PgCatalog.relationNameField fooRelation) + + pgClassOid <- + case maybePgClassRecord of + Nothing -> do + HH.annotate "Expected to find pg_class table, but did not" + HH.failure + Just pgClassRecord -> + pure $ PgCatalog.pgClassOid pgClassRecord + + triggers <- HH.evalIO . Orville.runOrville pool $ do + Orville.findEntitiesBy + PgCatalog.pgTriggerTable + (Orville.where_ $ Orville.fieldEquals PgCatalog.triggerRelationOidField pgClassOid) + + fmap PgCatalog.pgTriggerName triggers === [String.fromString "test_trigger"] + +prop_queryPgProc :: Property.NamedDBProperty +prop_queryPgProc = + Property.singletonNamedDBProperty "Can query the pg_proc table to find out about a proc" $ \pool -> do + let + procFunctionName = + Expr.unqualified $ Expr.functionName "test_proc" + + procName = + String.fromString "test_proc" + + createProcFunction = + Expr.createFunction + (Just Expr.orReplace) + procFunctionName + (Expr.returns Expr.returnTypeTrigger) + (Expr.language Expr.plpgsql) + (Expr.asDefinition "BEGIN return NEW; END") + + procs <- HH.evalIO . Orville.runOrville pool $ do + Orville.executeVoid Orville.DDLQuery createProcFunction + Orville.findEntitiesBy + PgCatalog.pgProcTable + (Orville.where_ $ Orville.fieldEquals PgCatalog.procNameField procName) + + fmap PgCatalog.pgProcName procs === [procName] + prop_describeDatabaseRelations :: Property.NamedDBProperty prop_describeDatabaseRelations = Property.singletonNamedDBProperty "Can describe relations from different schemas at once" $ \pool -> do @@ -139,7 +217,7 @@ ] desc <- HH.evalIO . Orville.runOrville pool $ do - PgCatalog.describeDatabaseRelations relationsToDescribe + PgCatalog.describeDatabase relationsToDescribe [] [] Map.keysSet (PgCatalog.databaseRelations desc) === Set.fromList relationsToDescribe diff --git a/test/Test/PgGen.hs b/test/Test/PgGen.hs --- a/test/Test/PgGen.hs +++ b/test/Test/PgGen.hs @@ -29,14 +29,12 @@ pgInt32 = Gen.integral (Range.linearFrom 0 minBound maxBound) -{- | - Produces a double value that can be reliably round tripped through - PostgreSQL, which only allows 15 digits of decimal precision. +{- | Produces a double value that can be reliably round tripped through PostgreSQL, which only allows + 15 digits of decimal precision. - Generating doubles naively using 'Gen.double' produces large numbers with - more than 15 digits of precisio, so we use 'encodeFloat' to directly ensure - the precision of large numbers is within PostgreSQL's limit. Precision of - small numbers is enforced by rounding excess digits off. + Generating doubles naively using 'Gen.double' produces large numbers with more than 15 digits of + precisio, so we use 'encodeFloat' to directly ensure the precision of large numbers is within + PostgreSQL's limit. Precision of small numbers is enforced by rounding excess digits off. @since 1.0.0.0 -} @@ -85,12 +83,10 @@ pgIdentifier = Gen.string (Range.linear 1 63) $ Gen.element pgIdentifierChars -{- | - Relation names must be unique in PostgreSQL, so we sometimes generate - names with prefixes to avoid conflicts between different types of - relations such as tables and indexes. The min length value allows the - caller to length of the random strings that will be appended to prefix, - which case be useful to avoid conflicts. +{- | Relation names must be unique in PostgreSQL, so we sometimes generate names with prefixes to + avoid conflicts between different types of relations such as tables and indexes. The min length + value allows the caller to length of the random strings that will be appended to prefix, which + case be useful to avoid conflicts. @since 1.0.0.0 -} @@ -101,10 +97,8 @@ . Gen.element $ pgIdentifierChars -{- | - A list of characters to include in identifiers when testing. Not all of these - are valid in unquoted identifiers -- this helps ensure that Orville is - properly quoting ids. +{- | A list of characters to include in identifiers when testing. Not all of these are valid in + unquoted identifiers -- this helps ensure that Orville is properly quoting ids. @since 1.0.0.0 -} @@ -125,11 +119,20 @@ pgDay :: HH.Gen Time.Day pgDay = do - year <- Gen.integral (Range.linearFrom 2000 0 3000) + year <- Gen.integral (Range.constantFrom 2000 (-4713) 294276) month <- Gen.integral (Range.constant 1 12) day <- Gen.integral (Range.constant 1 (Time.gregorianMonthLength year month)) - pure (Time.fromGregorian year month day) + Gen.frequency + [ (1, feb29thBCE) + , (49, pure (Time.fromGregorian year month day)) + ] + +-- Edge case to help catch mistakes in date parsing/printing +feb29thBCE :: HH.Gen Time.Day +feb29thBCE = do + year <- Gen.filter Time.isLeapYear (Gen.integral (Range.linear (-4713) 0)) + pure (Time.fromGregorian year 2 29) pgTimeOfDay :: HH.Gen Time.TimeOfDay pgTimeOfDay = fmap Time.timeToTimeOfDay pgDiffTime diff --git a/test/Test/Plan.hs b/test/Test/Plan.hs --- a/test/Test/Plan.hs +++ b/test/Test/Plan.hs @@ -11,11 +11,13 @@ where import qualified Control.Exception as Exception +import qualified Control.Monad as Monad import qualified Control.Monad.IO.Class as MIO import qualified Data.Either as Either import Data.Foldable (traverse_) import qualified Data.List as List import qualified Data.List.NonEmpty as NEL +import qualified Data.Map.Strict as Map import qualified Data.String as String import Hedgehog ((===)) import qualified Hedgehog as HH @@ -43,13 +45,22 @@ Property.group "Plan" $ [ prop_askParam pool , prop_findMaybeOne pool + , prop_findMaybeOneByMarshaller pool , prop_findMaybeOneWhere pool + , prop_findMaybeOneWhereByMarshaller pool , prop_findAll pool + , prop_findAllByMarshaller pool , prop_findAllWhere pool + , prop_findAllWhereByMarshaller pool , prop_planMany_findMaybeOne pool + , prop_planMany_findMaybeOneByMarshaller pool , prop_planMany_findMaybeOneWhere pool + , prop_planMany_findMaybeOneWhereByMarshaller pool , prop_planMany_findAll pool + , prop_planTraversable_Map_findAll pool + , prop_planMany_findAllByMarshaller pool , prop_planMany_findAllWhere pool + , prop_planMany_findAllWhereByMarshaller pool , prop_planEither pool , prop_planMany_planEither pool , prop_bindAndUse pool @@ -84,7 +95,7 @@ plan :: Plan.Plan scope Foo.FooName (Maybe Foo.Foo) plan = Plan.findMaybeOne Foo.table Foo.fooNameField - (targetName, foos) <- HH.forAll generateSearchTargetAndSubjects + (targetName, _, foos) <- HH.forAll generateSearchTargetAndSubjects maybeResult <- Foo.withTable pool $ do traverse_ (Orville.insertEntities Foo.table) (NEL.nonEmpty foos) @@ -96,6 +107,25 @@ coverSearchResultCases isMatch foos assertMatchIsFromPredicate maybeResult isMatch foos +prop_findMaybeOneByMarshaller :: Property.NamedDBProperty +prop_findMaybeOneByMarshaller = + Property.namedDBProperty "findMaybeOneByMarshaller finds a row where the marshaller matches (if any)" $ \pool -> do + let + plan :: Plan.Plan scope (Foo.FooName, Foo.FooAge) (Maybe Foo.Foo) + plan = Plan.findMaybeOneByMarshaller Foo.table Foo.nameAndAgeMarshaller + + (targetName, targetAge, foos) <- HH.forAll generateSearchTargetAndSubjects + maybeResult <- + Foo.withTable pool $ do + traverse_ (Orville.insertEntities Foo.table) (NEL.nonEmpty foos) + Plan.execute plan (targetName, targetAge) + + let + isMatch foo = Foo.hasName targetName foo && Foo.hasAge targetAge foo + + coverSearchResultCases isMatch foos + assertMatchIsFromPredicate maybeResult isMatch foos + prop_planMany_findMaybeOne :: Property.NamedDBProperty prop_planMany_findMaybeOne = Property.namedDBProperty "(planMany findMaybeOne) finds a row where the field matches for each input" $ \pool -> do @@ -103,7 +133,7 @@ plan :: Plan.Plan scope [Foo.FooName] (Many.Many Foo.FooName (Maybe Foo.Foo)) plan = Plan.planMany $ Plan.findMaybeOne Foo.table Foo.fooNameField - (targetNames, foos) <- HH.forAll generateSearchTargetListAndSubjects + (targetNames, _, foos) <- HH.forAll generateSearchTargetListAndSubjects results <- Foo.withTable pool $ do traverse_ (Orville.insertEntities Foo.table) (NEL.nonEmpty foos) @@ -120,6 +150,32 @@ (\foo -> Foo.hasName targetName foo && isMatch foo) foos +prop_planMany_findMaybeOneByMarshaller :: Property.NamedDBProperty +prop_planMany_findMaybeOneByMarshaller = + Property.namedDBProperty "(planMany findMaybeOneByMarshaller) finds a row where the marshaller matches for each input" $ \pool -> do + let + plan :: Plan.Plan scope [(Foo.FooName, Foo.FooAge)] (Many.Many (Foo.FooName, Foo.FooAge) (Maybe Foo.Foo)) + plan = Plan.planMany $ Plan.findMaybeOneByMarshaller Foo.table Foo.nameAndAgeMarshaller + + (targetNames, targetAges, foos) <- HH.forAll generateSearchTargetListAndSubjects + let + target = zip targetNames targetAges + results <- + Foo.withTable pool $ do + traverse_ (Orville.insertEntities Foo.table) (NEL.nonEmpty foos) + Plan.execute plan target + + let + isMatch foo = elem (Foo.fooName foo, Foo.fooAge foo) target + + coverSearchResultCases isMatch foos + + assertEachManyResult target results $ \(name, age) maybeFoo -> + assertMatchIsFromPredicate + maybeFoo + (\foo -> Foo.hasName name foo && Foo.hasAge age foo && isMatch foo) + foos + prop_findMaybeOneWhere :: Property.NamedDBProperty prop_findMaybeOneWhere = Property.namedDBProperty "findMaybeOneWhere finds a row where the field matches (if any), with the given condition" $ \pool -> do @@ -131,7 +187,7 @@ Foo.fooNameField (Orville.fieldGreaterThan Foo.fooAgeField Foo.averageFooAge) - (targetName, foos) <- HH.forAll generateSearchTargetAndSubjects + (targetName, _, foos) <- HH.forAll generateSearchTargetAndSubjects maybeResult <- Foo.withTable pool $ do traverse_ (Orville.insertEntities Foo.table) (NEL.nonEmpty foos) @@ -143,6 +199,29 @@ coverSearchResultCases isMatch foos assertMatchIsFromPredicate maybeResult isMatch foos +prop_findMaybeOneWhereByMarshaller :: Property.NamedDBProperty +prop_findMaybeOneWhereByMarshaller = + Property.namedDBProperty "findMaybeOneWhereByMarshaller finds a row where the marshaller matches (if any), with the given condition" $ \pool -> do + let + plan :: Plan.Plan scope (Foo.FooName, Foo.FooAge) (Maybe Foo.Foo) + plan = + Plan.findMaybeOneWhereByMarshaller + Foo.table + Foo.nameAndAgeMarshaller + (Orville.fieldGreaterThan Foo.fooAgeField Foo.averageFooAge) + + (targetName, targetAge, foos) <- HH.forAll generateSearchTargetAndSubjects + maybeResult <- + Foo.withTable pool $ do + traverse_ (Orville.insertEntities Foo.table) (NEL.nonEmpty foos) + Plan.execute plan (targetName, targetAge) + + let + isMatch foo = Foo.hasName targetName foo && Foo.hasAge targetAge foo && Foo.fooAge foo > Foo.averageFooAge + + coverSearchResultCases isMatch foos + assertMatchIsFromPredicate maybeResult isMatch foos + prop_planMany_findMaybeOneWhere :: Property.NamedDBProperty prop_planMany_findMaybeOneWhere = Property.namedDBProperty "(planMany findMaybeOneWhere) finds a row where the field matches for each input, with the given condition" $ \pool -> do @@ -155,7 +234,7 @@ Foo.fooNameField (Orville.fieldGreaterThan Foo.fooAgeField Foo.averageFooAge) - (targetNames, foos) <- HH.forAll generateSearchTargetListAndSubjects + (targetNames, _, foos) <- HH.forAll generateSearchTargetListAndSubjects results <- Foo.withTable pool $ do traverse_ (Orville.insertEntities Foo.table) (NEL.nonEmpty foos) @@ -174,6 +253,41 @@ (\foo -> Foo.hasName targetName foo && isMatch foo) foos +prop_planMany_findMaybeOneWhereByMarshaller :: Property.NamedDBProperty +prop_planMany_findMaybeOneWhereByMarshaller = + Property.namedDBProperty "(planMany findMaybeOneWhereByMarshaller) finds a row where the marshaller matches for each input, with the given condition" $ \pool -> do + let + plan :: Plan.Plan scope [(Foo.FooName, Foo.FooAge)] (Many.Many (Foo.FooName, Foo.FooAge) (Maybe Foo.Foo)) + plan = + Plan.planMany $ + Plan.findMaybeOneWhereByMarshaller + Foo.table + Foo.nameAndAgeMarshaller + (Orville.fieldGreaterThan Foo.fooAgeField Foo.averageFooAge) + + (targetNames, targetAges, foos) <- HH.forAll generateSearchTargetListAndSubjects + + let + target = zip targetNames targetAges + + results <- + Foo.withTable pool $ do + traverse_ (Orville.insertEntities Foo.table) (NEL.nonEmpty foos) + Plan.execute plan target + + let + isMatch foo = + elem (Foo.fooName foo, Foo.fooAge foo) target + && Foo.fooAge foo > Foo.averageFooAge + + coverSearchResultCases isMatch foos + + assertEachManyResult target results $ \(name, age) maybeFoo -> + assertMatchIsFromPredicate + maybeFoo + (\foo -> Foo.hasName name foo && Foo.hasAge age foo && isMatch foo) + foos + prop_findAll :: Property.NamedDBProperty prop_findAll = Property.namedDBProperty "findAll finds all rows where the field matches" $ \pool -> do @@ -181,7 +295,7 @@ plan :: Plan.Plan scope Foo.FooName [Foo.Foo] plan = Plan.findAll Foo.table Foo.fooNameField - (targetName, foos) <- HH.forAll generateSearchTargetAndSubjects + (targetName, _, foos) <- HH.forAll generateSearchTargetAndSubjects results <- Foo.withTable pool $ do traverse_ (Orville.insertEntities Foo.table) (NEL.nonEmpty foos) @@ -193,14 +307,33 @@ coverSearchResultCases isMatch foos assertAllMatchesFound Foo.fooId results isMatch foos +prop_findAllByMarshaller :: Property.NamedDBProperty +prop_findAllByMarshaller = + Property.namedDBProperty "findAllByMarshaller finds all rows where the marshaller matches" $ \pool -> do + let + plan :: Plan.Plan scope (Foo.FooName, Foo.FooAge) [Foo.Foo] + plan = Plan.findAllByMarshaller Foo.table Foo.nameAndAgeMarshaller + + (targetName, targetAge, foos) <- HH.forAll generateSearchTargetAndSubjects + results <- + Foo.withTable pool $ do + traverse_ (Orville.insertEntities Foo.table) (NEL.nonEmpty foos) + Plan.execute plan (targetName, targetAge) + + let + isMatch foo = Foo.hasName targetName foo && Foo.hasAge targetAge foo + + coverSearchResultCases isMatch foos + assertAllMatchesFound Foo.fooId results isMatch foos + prop_planMany_findAll :: Property.NamedDBProperty prop_planMany_findAll = - Property.namedDBProperty "(planMany findAll) finds all rows where the field matches for each list of inputs" $ \pool -> do + Property.namedDBProperty "(planMany findAll) finds all rows where the field matches for each element in a list of inputs" $ \pool -> do let plan :: Plan.Plan scope [Foo.FooName] (Many.Many Foo.FooName [Foo.Foo]) plan = Plan.planMany (Plan.findAll Foo.table Foo.fooNameField) - (targetNames, foos) <- HH.forAll generateSearchTargetListAndSubjects + (targetNames, _, foos) <- HH.forAll generateSearchTargetListAndSubjects results <- Foo.withTable pool $ do traverse_ (Orville.insertEntities Foo.table) (NEL.nonEmpty foos) @@ -213,6 +346,55 @@ assertEachManyResult targetNames results $ \targetName foundFoos -> assertAllMatchesFound Foo.fooId foundFoos (\foo -> Foo.hasName targetName foo && isMatch foo) foos +prop_planTraversable_Map_findAll :: Property.NamedDBProperty +prop_planTraversable_Map_findAll = + Property.namedDBProperty "(planTraversable findAll) finds all rows where the field matches for each element in a map of inputs" $ \pool -> do + let + plan :: Plan.Plan scope (Map.Map Foo.FooName Foo.FooName) (Map.Map Foo.FooName [Foo.Foo]) + plan = Plan.planTraversable (Plan.findAll Foo.table Foo.fooNameField) + + (targetNames, _, foos) <- HH.forAll generateSearchTargetListAndSubjects + let + targetNamesMap = Map.fromList $ Monad.join zip targetNames + results <- + Foo.withTable pool $ do + traverse_ (Orville.insertEntities Foo.table) (NEL.nonEmpty foos) + Plan.execute plan targetNamesMap + + let + isMatch foo = elem (Foo.fooName foo) targetNames + + coverSearchResultCases isMatch foos + length targetNamesMap === length results + traverse_ + ( \targetName -> do + Just foundFoos <- pure $ Map.lookup targetName results + assertAllMatchesFound Foo.fooId foundFoos (\foo -> Foo.hasName targetName foo && isMatch foo) foos + ) + targetNames + +prop_planMany_findAllByMarshaller :: Property.NamedDBProperty +prop_planMany_findAllByMarshaller = + Property.namedDBProperty "(planMany findAllByMarshaller) finds all rows where the marshaller matches for each list of inputs" $ \pool -> do + let + plan :: Plan.Plan scope [(Foo.FooName, Foo.FooAge)] (Many.Many (Foo.FooName, Foo.FooAge) [Foo.Foo]) + plan = Plan.planMany (Plan.findAllByMarshaller Foo.table Foo.nameAndAgeMarshaller) + + (targetNames, targetAges, foos) <- HH.forAll generateSearchTargetListAndSubjects + let + target = zip targetNames targetAges + results <- + Foo.withTable pool $ do + traverse_ (Orville.insertEntities Foo.table) (NEL.nonEmpty foos) + Plan.execute plan target + + let + isMatch foo = elem (Foo.fooName foo, Foo.fooAge foo) target + + coverSearchResultCases isMatch foos + assertEachManyResult target results $ \(name, age) foundFoos -> + assertAllMatchesFound Foo.fooId foundFoos (\foo -> Foo.hasName name foo && Foo.hasAge age foo) foos + prop_findAllWhere :: Property.NamedDBProperty prop_findAllWhere = Property.namedDBProperty "findAllWhere finds all rows where the field matches, with the given condition" $ \pool -> do @@ -224,7 +406,7 @@ Foo.fooNameField (Orville.fieldGreaterThan Foo.fooAgeField Foo.averageFooAge) - (targetName, foos) <- HH.forAll generateSearchTargetAndSubjects + (targetName, _, foos) <- HH.forAll generateSearchTargetAndSubjects results <- Foo.withTable pool $ do traverse_ (Orville.insertEntities Foo.table) (NEL.nonEmpty foos) @@ -236,9 +418,32 @@ coverSearchResultCases isMatch foos assertAllMatchesFound Foo.fooId results isMatch foos +prop_findAllWhereByMarshaller :: Property.NamedDBProperty +prop_findAllWhereByMarshaller = + Property.namedDBProperty "findAllWhereByMarshaller finds all rows where the marshaller matches, with the given condition" $ \pool -> do + let + plan :: Plan.Plan scope (Foo.FooName, Foo.FooAge) [Foo.Foo] + plan = + Plan.findAllWhereByMarshaller + Foo.table + Foo.nameAndAgeMarshaller + (Orville.fieldGreaterThan Foo.fooAgeField Foo.averageFooAge) + + (targetName, targetAge, foos) <- HH.forAll generateSearchTargetAndSubjects + results <- + Foo.withTable pool $ do + traverse_ (Orville.insertEntities Foo.table) (NEL.nonEmpty foos) + Plan.execute plan (targetName, targetAge) + + let + isMatch foo = Foo.hasName targetName foo && Foo.hasAge targetAge foo && Foo.fooAge foo > Foo.averageFooAge + + coverSearchResultCases isMatch foos + assertAllMatchesFound Foo.fooId results isMatch foos + prop_planMany_findAllWhere :: Property.NamedDBProperty prop_planMany_findAllWhere = - Property.namedDBProperty "(planMany findAllWhere) finds all rows where the field matches for each list of inputs, with the given condition" $ \pool -> do + Property.namedDBProperty "(planMany findAllWhere) finds all rows where the field matches for each element in a list of inputs, with the given condition" $ \pool -> do let plan :: Plan.Plan scope [Foo.FooName] (Many.Many Foo.FooName [Foo.Foo]) plan = @@ -248,7 +453,7 @@ Foo.fooNameField (Orville.fieldGreaterThan Foo.fooAgeField Foo.averageFooAge) - (targetNames, foos) <- HH.forAll generateSearchTargetListAndSubjects + (targetNames, _, foos) <- HH.forAll generateSearchTargetListAndSubjects results <- Foo.withTable pool $ do traverse_ (Orville.insertEntities Foo.table) (NEL.nonEmpty foos) @@ -261,6 +466,33 @@ assertEachManyResult targetNames results $ \targetName foundFoos -> assertAllMatchesFound Foo.fooId foundFoos (\foo -> Foo.hasName targetName foo && isMatch foo) foos +prop_planMany_findAllWhereByMarshaller :: Property.NamedDBProperty +prop_planMany_findAllWhereByMarshaller = + Property.namedDBProperty "(planMany findAllWhereByMarshaller) finds all rows where the marshaller matches for each list of inputs, with the given condition" $ \pool -> do + let + plan :: Plan.Plan scope [(Foo.FooName, Foo.FooAge)] (Many.Many (Foo.FooName, Foo.FooAge) [Foo.Foo]) + plan = + Plan.planMany $ + Plan.findAllWhereByMarshaller + Foo.table + Foo.nameAndAgeMarshaller + (Orville.fieldGreaterThan Foo.fooAgeField Foo.averageFooAge) + + (targetNames, targetAges, foos) <- HH.forAll generateSearchTargetListAndSubjects + let + target = zip targetNames targetAges + results <- + Foo.withTable pool $ do + traverse_ (Orville.insertEntities Foo.table) (NEL.nonEmpty foos) + Plan.execute plan target + + let + isMatch foo = elem (Foo.fooName foo, Foo.fooAge foo) target && Foo.fooAge foo > Foo.averageFooAge + + coverSearchResultCases isMatch foos + assertEachManyResult target results $ \(name, age) foundFoos -> + assertAllMatchesFound Foo.fooId foundFoos (\foo -> Foo.hasName name foo && Foo.hasAge age foo && isMatch foo) foos + prop_planEither :: Property.NamedDBProperty prop_planEither = Property.namedDBProperty "planEither executes either the right or left plan based on input" $ \pool -> do @@ -494,48 +726,46 @@ , "SELECT \"foo_id\",\"id\",\"foo_id\" FROM \"foo_child\" WHERE (\"foo_id\") = ($1)" ] -{- | - Generates a list of Foos that along with FooName that could plausibly be - found in the list zero, one or more times. +{- | Generates a list of Foos that along with FooName and FooAge that could plausibly be found in the + list zero, one or more times. @since 1.0.0.0 -} -generateSearchTargetAndSubjects :: HH.Gen (Foo.FooName, [Foo.Foo]) +generateSearchTargetAndSubjects :: HH.Gen (Foo.FooName, Foo.FooAge, [Foo.Foo]) generateSearchTargetAndSubjects = do targetName <- Foo.generateFooName + targetAge <- Foo.generateFooAge let generatePossibleTargetFoo = Gen.choice - [ Foo.generateFooWithName targetName + [ Foo.generateFooWithNameAndAge targetName targetAge , Foo.generate ] foos <- Foo.generateListUsing (Range.linear 0 5) generatePossibleTargetFoo - pure (targetName, foos) + pure (targetName, targetAge, foos) -{- | - Generates a list of Foos that along with FooName that could plausibly be - found in the list zero, one or more times. +{- | Generates a list of Foos that along with FooName that could plausibly be found in the list zero, + one or more times. @since 1.0.0.0 -} -generateSearchTargetListAndSubjects :: HH.Gen ([Foo.FooName], [Foo.Foo]) +generateSearchTargetListAndSubjects :: HH.Gen ([Foo.FooName], [Foo.FooAge], [Foo.Foo]) generateSearchTargetListAndSubjects = do targetNames <- Gen.list (Range.linear 0 5) Foo.generateFooName + targetAges <- Gen.list (Range.linear 0 5) Foo.generateFooAge let generatePossibleTargetFoo = - Gen.choice (Foo.generate : fmap Foo.generateFooWithName targetNames) + Gen.choice (Foo.generate : fmap (uncurry Foo.generateFooWithNameAndAge) (zip targetNames targetAges)) foos <- Foo.generateListUsing (Range.linear 0 5) generatePossibleTargetFoo - pure (targetNames, foos) + pure (targetNames, targetAges, foos) -{- | - Uses Hedgehog's cover function to make sure common edge cases are covered - for tests that are conducting a search. The predicate given should indicate - whether the item would be expected to match the search being tested. The - list of items should be the list that will be searced against. +{- | Uses Hedgehog's cover function to make sure common edge cases are covered for tests that are + conducting a search. The predicate given should indicate whether the item would be expected to + match the search being tested. The list of items should be the list that will be searced against. @since 1.0.0.0 -} @@ -545,12 +775,10 @@ HH.cover 1 (String.fromString "subjects present with no matches") (not (null subjects) && not (any predicate subjects)) HH.cover 1 (String.fromString "at least 1 match") (length (filter predicate subjects) >= 1) -{- | - Asserts that the given result is one that could have been produced by apply - the predicate to the given list to find a single result. This assertion - doesn't care which particular item from the list was found, as long as it the - result matches the predicate and it is one from the list, or that nothing in - the list matches if the 'Nothing' was found. +{- | Asserts that the given result is one that could have been produced by apply the predicate to the + given list to find a single result. This assertion doesn't care which particular item from the + list was found, as long as it the result matches the predicate and it is one from the list, or + that nothing in the list matches if the 'Nothing' was found. @since 1.0.0.0 -} @@ -567,9 +795,8 @@ Just entity -> HH.assert (predicate entity && elem entity subjects) -{- | - Asserts that the found items are all of those from the list that match the - predicate, but without caring about order. +{- | Asserts that the found items are all of those from the list that match the predicate, but without + caring about order. @since 1.0.0.0 -} @@ -587,9 +814,8 @@ assertAllMatchesFound keyAttr foundEntities predicate allEntities = List.sortOn keyAttr foundEntities === List.sortOn keyAttr (filter predicate allEntities) -{- | - Applies the given assertion for every key in the list. If any of the key - is not found in the provided 'Many.Many' value, this assertion will fail. +{- | Applies the given assertion for every key in the list. If any of the key is not found in the + provided 'Many.Many' value, this assertion will fail. @since 1.0.0.0 -} diff --git a/test/Test/RawSql.hs b/test/Test/RawSql.hs --- a/test/Test/RawSql.hs +++ b/test/Test/RawSql.hs @@ -5,6 +5,7 @@ import qualified Data.ByteString.Char8 as B8 import Data.Functor.Identity (runIdentity) +import qualified Data.List.NonEmpty as NE import qualified Data.Text as T import Hedgehog ((===)) import qualified Hedgehog as HH @@ -58,24 +59,32 @@ <> RawSql.fromString "WHERE id = " <> RawSql.parameter (SqlValue.fromInt32 1) <> RawSql.fromString " AND " - <> RawSql.fromString "bar IN (" + <> RawSql.fromString "(bar, baz, id) IN (" <> RawSql.intercalate RawSql.comma bars <> RawSql.fromString ")" bars = map - RawSql.parameter - [ SqlValue.fromText (T.pack "pants") - , SqlValue.fromText (T.pack "cheese") + (RawSql.parameter . SqlValue.fromRow . NE.fromList) + [ [SqlValue.fromText (T.pack "pants"), SqlValue.fromText (T.pack "ants"), SqlValue.fromInt32 2] + , [SqlValue.fromText (T.pack "cheese"), SqlValue.fromText (T.pack "louise"), SqlValue.fromInt32 3] + , [SqlValue.fromText (T.pack "lasagna"), SqlValue.fromText (T.pack "banana"), SqlValue.fromInt32 4] ] expectedBytes = - B8.pack "SELECT * FROM foo WHERE id = $1 AND bar IN ($2,$3)" + B8.pack "SELECT * FROM foo WHERE id = $1 AND (bar, baz, id) IN (($2,$3,$4),($5,$6,$7),($8,$9,$10))" expectedParams = - [ Just . PgTextFormatValue.fromByteString . B8.pack $ "1" - , Just . PgTextFormatValue.fromByteString . B8.pack $ "pants" - , Just . PgTextFormatValue.fromByteString . B8.pack $ "cheese" + [ Just . PgTextFormatValue.fromByteString $ B8.pack "1" + , Just . PgTextFormatValue.fromByteString $ B8.pack "pants" + , Just . PgTextFormatValue.fromByteString $ B8.pack "ants" + , Just . PgTextFormatValue.fromByteString $ B8.pack "2" + , Just . PgTextFormatValue.fromByteString $ B8.pack "cheese" + , Just . PgTextFormatValue.fromByteString $ B8.pack "louise" + , Just . PgTextFormatValue.fromByteString $ B8.pack "3" + , Just . PgTextFormatValue.fromByteString $ B8.pack "lasagna" + , Just . PgTextFormatValue.fromByteString $ B8.pack "banana" + , Just . PgTextFormatValue.fromByteString $ B8.pack "4" ] (actualBytes, actualParams) = diff --git a/test/Test/SelectOptions.hs b/test/Test/SelectOptions.hs --- a/test/Test/SelectOptions.hs +++ b/test/Test/SelectOptions.hs @@ -13,6 +13,7 @@ import Orville.PostgreSQL ((.&&), (./=), (.<), (.<-), (.), (.>=), (.||)) import qualified Orville.PostgreSQL as O import qualified Orville.PostgreSQL.Expr as Expr +import qualified Orville.PostgreSQL.Marshall as Marshall import qualified Orville.PostgreSQL.Marshall.FieldDefinition as FieldDef import qualified Orville.PostgreSQL.Raw.RawSql as RawSql import qualified Test.Property as Property @@ -26,6 +27,8 @@ , prop_fieldEqualsOperator , prop_fieldNotEquals , prop_fieldNotEqualsOperator + , prop_fieldIsDistinctFrom + , prop_fieldIsNotDistinctFrom , prop_fieldLessThan , prop_fieldLessThanOperator , prop_fieldGreaterThan @@ -51,9 +54,11 @@ , prop_fieldNotInOperator , prop_distinct , prop_orderBy + , prop_orderByQualified , prop_orderByCombined , prop_groupBy , prop_groupByCombined + , prop_forRowLock ] prop_emptyWhereClause :: Property.NamedProperty @@ -84,6 +89,20 @@ (Just "WHERE (\"foo\") <> ($1)") (O.where_ $ O.fieldNotEquals fooField 0) +prop_fieldIsDistinctFrom :: Property.NamedProperty +prop_fieldIsDistinctFrom = + Property.singletonNamedProperty "fieldIsDistinctFrom generates expected sql" $ + assertWhereClauseEquals + (Just "WHERE (\"foo\") IS DISTINCT FROM ($1)") + (O.where_ $ O.fieldIsDistinctFrom fooField 0) + +prop_fieldIsNotDistinctFrom :: Property.NamedProperty +prop_fieldIsNotDistinctFrom = + Property.singletonNamedProperty "fieldIsNotDistinctFrom generates expected sql" $ + assertWhereClauseEquals + (Just "WHERE (\"foo\") IS NOT DISTINCT FROM ($1)") + (O.where_ $ O.fieldIsNotDistinctFrom fooField 0) + prop_fieldNotEqualsOperator :: Property.NamedProperty prop_fieldNotEqualsOperator = Property.singletonNamedProperty "./= generates expected sql" $ @@ -294,12 +313,23 @@ ) ) +prop_orderByQualified :: Property.NamedProperty +prop_orderByQualified = + Property.singletonNamedProperty "orderBy generates expected sql" $ + assertOrderByClauseEquals + (Just "ORDER BY \"f\".\"foo\" ASC, \"bar\" DESC") + ( O.orderBy + ( O.orderBySqlComparable (O.qualifyField (Marshall.stringToAliasName "f") fooField) Expr.ascendingOrder + <> O.orderByField barField Expr.descendingOrder + ) + ) + prop_orderByCombined :: Property.NamedProperty prop_orderByCombined = Property.singletonNamedProperty "orderBy generates expected sql with multiple selectOptions" $ assertOrderByClauseEquals (Just "ORDER BY \"foo\" ASC, \"bar\" DESC") - ( (O.orderBy $ O.orderByColumnName (Expr.columnName "foo") O.ascendingOrder) + ( (O.orderBy $ O.orderByColumnName (Expr.unqualified (Expr.columnName "foo")) O.ascendingOrder) <> (O.orderBy $ O.orderByField barField O.descendingOrder) ) @@ -309,7 +339,8 @@ assertGroupByClauseEquals (Just "GROUP BY \"foo\", \"bar\"") ( O.groupBy . Expr.groupByColumnsExpr $ - FieldDef.fieldColumnName fooField :| [FieldDef.fieldColumnName barField] + Expr.unqualified (FieldDef.fieldColumnName fooField) + :| [Expr.unqualified (FieldDef.fieldColumnName barField)] ) prop_groupByCombined :: Property.NamedProperty @@ -318,9 +349,16 @@ assertGroupByClauseEquals (Just "GROUP BY foo, \"bar\"") ( (O.groupBy . RawSql.unsafeSqlExpression $ "foo") - <> (O.groupBy . Expr.groupByColumnsExpr $ (FieldDef.fieldColumnName barField :| [])) + <> (O.groupBy . Expr.groupByColumnsExpr $ ((Expr.unqualified (FieldDef.fieldColumnName barField)) :| [])) ) +prop_forRowLock :: Property.NamedProperty +prop_forRowLock = + Property.singletonNamedProperty "forRowLock generates expected sql" $ + assertRowLockingClauseEquals + (Just "FOR UPDATE SKIP LOCKED") + (O.forRowLock $ Expr.rowLockingClause Expr.updateStrength Nothing (Just Expr.skipLockedRowLockingOption)) + assertDistinctEquals :: (HH.MonadTest m, HasCallStack) => String -> O.SelectOptions -> m () assertDistinctEquals mbDistinct selectOptions = withFrozenCallStack $ @@ -340,6 +378,11 @@ assertGroupByClauseEquals mbGroupByClause selectOptions = withFrozenCallStack $ fmap RawSql.toExampleBytes (O.selectGroupByClause selectOptions) HH.=== fmap B8.pack mbGroupByClause + +assertRowLockingClauseEquals :: (HH.MonadTest m, HasCallStack) => Maybe String -> O.SelectOptions -> m () +assertRowLockingClauseEquals mbRowLockingClause selectOptions = + withFrozenCallStack $ + fmap RawSql.toExampleBytes (O.selectRowLockingClause selectOptions) HH.=== fmap B8.pack mbRowLockingClause fooField :: FieldDef.FieldDefinition FieldDef.NotNull Int.Int32 fooField = diff --git a/test/Test/SqlCommenter.hs b/test/Test/SqlCommenter.hs --- a/test/Test/SqlCommenter.hs +++ b/test/Test/SqlCommenter.hs @@ -6,6 +6,7 @@ import qualified Control.Monad.IO.Class as MIO import qualified Data.ByteString.Char8 as B8 import Data.Functor.Identity (runIdentity) +import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map import qualified Data.Text as T import Hedgehog ((===)) @@ -62,7 +63,7 @@ prop_sqlCommenterInsertExpr = Property.singletonNamedDBProperty "sqlcommenter support does not impact ability of insertExpr inserting values" $ \pool -> do let - fooBars = [mkFooBar 1 "dog", mkFooBar 2 "cat"] + fooBars = NE.fromList [mkFooBar 1 "dog", mkFooBar 2 "cat"] rows <- MIO.liftIO $ @@ -70,7 +71,7 @@ dropAndRecreateTestTable connection let - insertExpr = Expr.insertExpr fooBarTable Nothing (insertFooBarSource fooBars) Nothing + insertExpr = Expr.insertExpr fooBarTable Nothing (insertFooBarSource fooBars) Nothing Nothing RawSql.executeVoid connection $ SqlCommenter.addSqlCommenterAttributes staticSqlCommenterAttributes insertExpr @@ -78,7 +79,7 @@ Execution.readRows result - assertEqualFooBarRows rows fooBars + assertEqualFooBarRows rows (NE.toList fooBars) prop_sqlCommenterOrvilleState :: Property.NamedDBProperty prop_sqlCommenterOrvilleState = diff --git a/test/Test/SqlMarshaller.hs b/test/Test/SqlMarshaller.hs --- a/test/Test/SqlMarshaller.hs +++ b/test/Test/SqlMarshaller.hs @@ -8,6 +8,7 @@ import qualified Data.ByteString.Char8 as B8 import qualified Data.Either as Either import qualified Data.Int as Int +import qualified Data.List.NonEmpty as NE import qualified Data.Set as Set import qualified Data.String as String import qualified Data.Text as T @@ -18,10 +19,13 @@ import qualified Orville.PostgreSQL.ErrorDetailLevel as ErrorDetailLevel import qualified Orville.PostgreSQL.Execution.ExecutionResult as Result +import qualified Orville.PostgreSQL.Expr as Expr import qualified Orville.PostgreSQL.Marshall as Marshall +import qualified Orville.PostgreSQL.Raw.RawSql as RawSql import qualified Orville.PostgreSQL.Raw.SqlValue as SqlValue import Test.Expr.TestSchema (assertEqualSqlRows) +import Test.Orphans () import qualified Test.PgGen as PgGen import qualified Test.Property as Property @@ -35,10 +39,13 @@ , prop_marshallField_missingColumn , prop_marshallField_decodeValueFailure , prop_marshallResultFromSql_Foo + , prop_marshallResultFromSql_FooWithQualifier , prop_marshallResultFromSql_Bar , prop_foldMarshallerFields , prop_passMaybeThrough , prop_partialMap + , prop_toComparableSqlValue + , prop_referenceValueExpression ] property_returnPureValue :: Property.NamedProperty @@ -161,6 +168,26 @@ result <- marshallTestRowFromSql fooMarshaller input Bifunctor.first show result === Right foos +prop_marshallResultFromSql_FooWithQualifier :: Property.NamedProperty +prop_marshallResultFromSql_FooWithQualifier = + Property.namedProperty "marshallResultFromSql decodes all rows in Foo result set, when given an alias for each field" $ do + foos <- HH.forAll $ Gen.list (Range.linear 0 10) generateFoo + + let + mkRowValues foo = + [ SqlValue.fromText (fooName foo) + , SqlValue.fromInt32 (fooSize foo) + , maybe SqlValue.sqlNull SqlValue.fromBool (fooOption foo) + ] + + input = + Result.mkFakeLibPQResult + [B8.pack "name", B8.pack "size", B8.pack "option"] + (map mkRowValues foos) + + result <- marshallTestRowFromSql fooMarshallerWithQualifierOnEachField input + Bifunctor.first show result === Right foos + prop_marshallResultFromSql_Bar :: Property.NamedProperty prop_marshallResultFromSql_Bar = Property.namedProperty "marshallResultFromSql decodes all rows in Bar result set" $ do @@ -189,9 +216,9 @@ let addField entry fields = case entry of - Marshall.Natural fieldDef (Just getValue) -> + Marshall.Natural _ fieldDef (Just getValue) -> (Marshall.fieldName fieldDef, Marshall.fieldValueToSqlValue fieldDef (getValue foo)) : fields - Marshall.Natural _ Nothing -> + Marshall.Natural _ _ Nothing -> fields Marshall.Synthetic _ -> fields @@ -271,6 +298,36 @@ result <- marshallTestRowFromSql marshaller input Bifunctor.first show result === expected +prop_toComparableSqlValue :: Property.NamedProperty +prop_toComparableSqlValue = + Property.namedProperty "toComparableSqlValue encodes the marshaller's write entity as a row value" $ do + foo <- HH.forAll generateFoo + + let + nameVal = SqlValue.fromText $ fooName foo + sizeVal = SqlValue.fromInt32 $ fooSize foo + optionVal = maybe SqlValue.sqlNull SqlValue.fromBool $ fooOption foo + expected = SqlValue.fromRow $ NE.fromList [nameVal, sizeVal, optionVal] + actual = Marshall.toComparableSqlValue fooMarshaller foo + + actual === expected + +prop_referenceValueExpression :: Property.NamedProperty +prop_referenceValueExpression = + Property.singletonNamedProperty "referenceValueExpression returns a row value containing references to the marshaller's write fields" $ do + let + alias = Marshall.stringToAliasName "f" + expected = + Expr.rowValueConstructor $ + NE.fromList + [ Expr.columnReference . Expr.untrackQualified . Marshall.qualifiedFieldColumnName $ Marshall.qualifyField alias nameField + , Expr.columnReference . Expr.untrackQualified . Marshall.qualifiedFieldColumnName $ Marshall.qualifyField alias sizeField + , Expr.columnReference . Expr.untrackQualified . Marshall.qualifiedFieldColumnName $ Marshall.qualifyField alias optionField + ] + actual = Marshall.referenceValueExpression (Marshall.marshallQualifyFields alias fooMarshaller) + + RawSql.toExampleBytes actual === RawSql.toExampleBytes expected + data Foo = Foo { fooName :: T.Text , fooSize :: Int.Int32 @@ -288,9 +345,29 @@ fooMarshaller :: Marshall.SqlMarshaller Foo Foo fooMarshaller = Foo - <$> Marshall.marshallField fooName (Marshall.unboundedTextField "name") - <*> Marshall.marshallField fooSize (Marshall.integerField "size") - <*> Marshall.marshallField fooOption (Marshall.nullableField $ Marshall.booleanField "option") + <$> Marshall.marshallField fooName nameField + <*> Marshall.marshallField fooSize sizeField + <*> Marshall.marshallField fooOption optionField + +fooMarshallerWithQualifierOnEachField :: Marshall.SqlMarshaller Foo Foo +fooMarshallerWithQualifierOnEachField = + Marshall.marshallQualifyFields (Marshall.stringToAliasName "f") $ + Foo + <$> Marshall.marshallQualifyFields (Marshall.stringToAliasName "f") (Marshall.marshallField fooName nameField) + <*> Marshall.marshallQualifyFields (Marshall.stringToAliasName "f") (Marshall.marshallField fooSize sizeField) + <*> Marshall.marshallQualifyFields (Marshall.stringToAliasName "f") (Marshall.marshallField fooOption optionField) + +nameField :: Marshall.FieldDefinition Marshall.NotNull T.Text +nameField = + Marshall.unboundedTextField "name" + +sizeField :: Marshall.FieldDefinition Marshall.NotNull Int.Int32 +sizeField = + Marshall.integerField "size" + +optionField :: Marshall.FieldDefinition Marshall.Nullable (Maybe Bool) +optionField = + Marshall.nullableField $ Marshall.booleanField "option" generateFoo :: HH.Gen Foo generateFoo = diff --git a/test/Test/SqlType.hs b/test/Test/SqlType.hs --- a/test/Test/SqlType.hs +++ b/test/Test/SqlType.hs @@ -370,6 +370,26 @@ , expectedValue = Time.fromGregorian 10000 12 21 } ) + , + ( String.fromString "Testing the decode of DATE with value 0001-12-21 BC" + , runDecodingTest pool $ + DecodingTest + { sqlTypeDDL = "DATE" + , rawSqlValue = Just $ B8.pack "'0001-12-21 BC'" + , sqlType = SqlType.date + , expectedValue = Time.fromGregorian 0 12 21 + } + ) + , + ( String.fromString "Testing the decode of DATE with value 0041-02-29 BC" + , runDecodingTest pool $ + DecodingTest + { sqlTypeDDL = "DATE" + , rawSqlValue = Just $ B8.pack "'0041-02-29 BC'" + , sqlType = SqlType.date + , expectedValue = Time.fromGregorian (-40) 2 29 + } + ) ] timestampTests :: Orville.ConnectionPool -> [(HH.PropertyName, HH.Property)] @@ -445,6 +465,26 @@ } ) , + ( String.fromString "Testing the decode of TIMESTAMP WITH TIME ZONE with value '0001-12-21 00:00:32.000+00 BC'" + , runDecodingTest pool $ + DecodingTest + { sqlTypeDDL = "TIMESTAMP WITH TIME ZONE" + , rawSqlValue = Just $ B8.pack "'0001-12-21 00:00:32.000+00 BC'" + , sqlType = SqlType.timestamp + , expectedValue = Time.UTCTime (Time.fromGregorian 0 12 21) (Time.secondsToDiffTime 32) + } + ) + , + ( String.fromString "Testing the decode of TIMESTAMP WITH TIME ZONE with value '0041-02-29 00:00:32.000+00 BC'" + , runDecodingTest pool $ + DecodingTest + { sqlTypeDDL = "TIMESTAMP WITH TIME ZONE" + , rawSqlValue = Just $ B8.pack "'0041-02-29 00:00:32.000+00 BC'" + , sqlType = SqlType.timestamp + , expectedValue = Time.UTCTime (Time.fromGregorian (-40) 2 29) (Time.secondsToDiffTime 32) + } + ) + , ( String.fromString "Testing the decode of TIMESTAMP WITHOUT TIME ZONE with value '2020-12-21 00:00:32'" , runDecodingTest pool $ DecodingTest @@ -514,6 +554,26 @@ , expectedValue = Time.LocalTime (Time.fromGregorian 1 12 21) (Time.timeToTimeOfDay $ Time.secondsToDiffTime 32) } ) + , + ( String.fromString "Testing the decode of TIMESTAMP WITHOUT TIME ZONE with value '0001-12-21 00:00:32 BC'" + , runDecodingTest pool $ + DecodingTest + { sqlTypeDDL = "TIMESTAMP WITHOUT TIME ZONE" + , rawSqlValue = Just $ B8.pack "'0001-12-21 00:00:32 BC'" + , sqlType = SqlType.timestampWithoutZone + , expectedValue = Time.LocalTime (Time.fromGregorian 0 12 21) (Time.timeToTimeOfDay $ Time.secondsToDiffTime 32) + } + ) + , + ( String.fromString "Testing the decode of TIMESTAMP WITHOUT TIME ZONE with value '0041-02-29 00:00:32 BC'" + , runDecodingTest pool $ + DecodingTest + { sqlTypeDDL = "TIMESTAMP WITHOUT TIME ZONE" + , rawSqlValue = Just $ B8.pack "'0041-02-29 00:00:32 BC'" + , sqlType = SqlType.timestampWithoutZone + , expectedValue = Time.LocalTime (Time.fromGregorian (-40) 2 29) (Time.timeToTimeOfDay $ Time.secondsToDiffTime 32) + } + ) ] data DecodingTest a = DecodingTest @@ -530,21 +590,30 @@ dropAndRecreateTable connection "decoding_test" (sqlTypeDDL test) let - tableName = Expr.qualifyTable Nothing (Expr.tableName "decoding_test") + tableName = Expr.unqualified $ Expr.tableName "decoding_test" + insertSource = + Expr.valuesExprInsertSource + . Expr.valuesExprFromValueExpressions + . pure + . pure + . Expr.valueExpression + . SqlValue.fromRawBytesNullable + $ rawSqlValue test RawSql.executeVoid connection $ Expr.insertExpr tableName Nothing - (Expr.insertSqlValues [[SqlValue.fromRawBytesNullable (rawSqlValue test)]]) + insertSource Nothing + Nothing result <- RawSql.execute connection $ Expr.queryExpr (Expr.selectClause $ Expr.selectExpr Nothing) Expr.selectStar - (Just $ Expr.tableExpr (Expr.referencesTable tableName) Nothing Nothing Nothing Nothing Nothing) + (Just $ Expr.tableExpr (Expr.singleTableReferenceList tableName) Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing) Execution.readRows result diff --git a/test/Test/TableDefinition.hs b/test/Test/TableDefinition.hs --- a/test/Test/TableDefinition.hs +++ b/test/Test/TableDefinition.hs @@ -7,6 +7,7 @@ import qualified Control.Monad.IO.Class as MIO import qualified Data.ByteString.Char8 as B8 import Data.List.NonEmpty (NonEmpty ((:|))) +import qualified Data.List.NonEmpty as NE import qualified Data.Set as Set import qualified Data.Text as T import Hedgehog ((===)) @@ -34,6 +35,7 @@ , prop_primaryKey pool , prop_uniqueConstraint pool , prop_fieldConstraints + , prop_insertDefaultValuesWithEmptyMarshaller pool ] prop_roundTrip :: Property.NamedDBProperty @@ -46,7 +48,8 @@ TableDefinition.mkInsertExpr ReturningOption.WithoutReturning Foo.table - (originalFoo :| []) + Nothing + (originalFoo NE.:| []) selectFoos = Select.selectTable Foo.table mempty @@ -67,7 +70,7 @@ let insertBar = - TableDefinition.mkInsertExpr ReturningOption.WithoutReturning Bar.table (originalBar :| []) + TableDefinition.mkInsertExpr ReturningOption.WithoutReturning Bar.table Nothing (originalBar :| []) selectBars = Select.selectTable Bar.table mempty @@ -94,6 +97,7 @@ TableDefinition.mkInsertExpr ReturningOption.WithoutReturning Foo.table + Nothing (originalFoo :| [conflictingFoo]) result <- MIO.liftIO . E.try . Conn.withPoolConnection pool $ \connection -> do @@ -125,6 +129,7 @@ TableDefinition.mkInsertExpr ReturningOption.WithoutReturning Foo.table + Nothing (originalFoo :| [conflictingFoo]) result <- MIO.liftIO . E.try . Conn.withPoolConnection pool $ \connection -> do @@ -182,3 +187,33 @@ ConstraintDefinition.tableConstraintKeys . Orville.tableConstraints tableConstraintKeys tableWithFieldConstraints === tableConstraintKeys tableWithTableConstraints + +prop_insertDefaultValuesWithEmptyMarshaller :: Property.NamedDBProperty +prop_insertDefaultValuesWithEmptyMarshaller = + Property.singletonNamedDBProperty "Inserts default values when table marshaller is empty" $ \pool -> do + let + table :: TableDefinition.TableDefinition (Orville.HasKey Bar.BarId) () () + table = + TableDefinition.mapTableMarshaller (const $ pure ()) Bar.table + entities = + NE.fromList [(), (), ()] + expectedResult = + [ Bar.Bar 1 $ T.pack "default" + , Bar.Bar 2 $ T.pack "default" + , Bar.Bar 3 $ T.pack "default" + ] + + insertExpr = + TableDefinition.mkInsertExpr + ReturningOption.WithoutReturning + table + Nothing + entities + + result <- MIO.liftIO . Orville.runOrville pool $ do + MIO.liftIO . Conn.withPoolConnection pool $ \connection -> do + TestTable.dropAndRecreateTableDef connection Bar.table + RawSql.executeVoid connection insertExpr + Select.executeSelect $ Select.selectTable Bar.table mempty + + result === expectedResult diff --git a/test/Test/TestTable.hs b/test/Test/TestTable.hs --- a/test/Test/TestTable.hs +++ b/test/Test/TestTable.hs @@ -36,10 +36,10 @@ String -> RawSql.RawSql dropTableNameSql = - dropTableNameExprSql . Expr.qualifyTable Nothing . Expr.tableName + dropTableNameExprSql . Expr.unqualified . Expr.tableName dropTableNameExprSql :: - Expr.Qualified Expr.TableName -> + Expr.QualifiedOrUnqualified Expr.TableName -> RawSql.RawSql dropTableNameExprSql name = RawSql.fromString "DROP TABLE IF EXISTS " <> RawSql.toRawSql name diff --git a/test/Test/Transaction.hs b/test/Test/Transaction.hs --- a/test/Test/Transaction.hs +++ b/test/Test/Transaction.hs @@ -1,17 +1,25 @@ +{-# LANGUAGE OverloadedStrings #-} + module Test.Transaction ( transactionTests ) where +import Control.Exception (SomeException (..), catch) import qualified Control.Monad as Monad +import qualified Control.Monad.Trans.Reader as Reader import qualified Data.ByteString as BS import qualified Data.IORef as IORef import qualified Data.Text as T +import qualified Database.PostgreSQL.LibPQ as LibPQ import Hedgehog ((===)) import qualified Hedgehog as HH import qualified Hedgehog.Gen as Gen +import qualified UnliftIO +import qualified UnliftIO.Concurrent as Concurrent import qualified Orville.PostgreSQL as Orville +import qualified Orville.PostgreSQL.Execution as Execution import qualified Orville.PostgreSQL.Expr as Expr import qualified Orville.PostgreSQL.OrvilleState as OrvilleState import qualified Orville.PostgreSQL.Raw.Connection as Conn @@ -25,11 +33,18 @@ transactionTests pool = Property.group "Transaction" $ [ prop_transactionsWithoutExceptionsCommit pool + , prop_transactionWithInstructionsToCommitCommit pool , prop_exceptionsLeadToTransactionRollback pool - , prop_savepointsRollbackInnerTransactions pool + , prop_savepointsRollbackInnerTransactionsOnException pool + , prop_savepointsAllowInnerTransactionsToRollback pool , prop_callbacksMadeForTransactionCommit pool - , prop_callbacksMadeForTransactionRollback pool + , prop_callbacksMadeForTransactionRollbackByException pool + , prop_callbacksMadeForTransactionRollbackByInstruction pool , prop_usesCustomBeginTransactionSql pool + , prop_inWithTransaction pool + , prop_rollbackCallbackInInvalidTransaction pool + , prop_transactionCleanupRunsAfterBeginTransactionFails pool + , prop_transactionCleanupCannotBeInterrupted pool ] prop_transactionsWithoutExceptionsCommit :: Property.NamedDBProperty @@ -49,6 +64,25 @@ length tracers === nestingLevel +prop_transactionWithInstructionsToCommitCommit :: Property.NamedDBProperty +prop_transactionWithInstructionsToCommitCommit = + Property.namedDBProperty "Transactions with instructions to commit, commit" $ \pool -> do + nestingLevel <- HH.forAll TransactionUtil.genNestingLevel + + tracers <- + HH.evalIO $ do + Conn.withPoolConnection pool $ \connection -> + TestTable.dropAndRecreateTableDef connection tracerTable + + Orville.runOrville pool $ do + TransactionUtil.runNestedTransactionWithInstructions nestingLevel $ \_ -> do + Monad.void $ Orville.insertEntity tracerTable Tracer + pure Orville.Commit + + Orville.findEntitiesBy tracerTable mempty + + length tracers === nestingLevel + prop_exceptionsLeadToTransactionRollback :: Property.NamedDBProperty prop_exceptionsLeadToTransactionRollback = Property.namedDBProperty "Exceptions within transaction blocks execute rollbock" $ \pool -> do @@ -69,9 +103,9 @@ length tracers === 0 -prop_savepointsRollbackInnerTransactions :: Property.NamedDBProperty -prop_savepointsRollbackInnerTransactions = - Property.namedDBProperty "Savepoints allow inner transactions to rollback while outer transactions commit" $ \pool -> do +prop_savepointsRollbackInnerTransactionsOnException :: Property.NamedDBProperty +prop_savepointsRollbackInnerTransactionsOnException = + Property.namedDBProperty "Savepoints allow inner transactions to throw and rollback while outer transactions commit" $ \pool -> do outerNestingLevel <- HH.forAll TransactionUtil.genNestingLevel innerNestingLevel <- HH.forAll TransactionUtil.genNestingLevel @@ -98,6 +132,39 @@ length tracers === outerNestingLevel +prop_savepointsAllowInnerTransactionsToRollback :: Property.NamedDBProperty +prop_savepointsAllowInnerTransactionsToRollback = + Property.namedDBProperty "Savepoints allow inner transactions to rollback while outer transactions commit" $ \pool -> do + outerNestingLevel <- HH.forAll TransactionUtil.genNestingLevel + innerNestingLevel <- HH.forAll TransactionUtil.genNestingLevel + + let + innerActions = + TransactionUtil.runNestedTransactionWithInstructions innerNestingLevel $ \level -> do + _ <- Orville.insertEntity tracerTable Tracer + -- Commit all the inner savepoints, but then rollback the first one so that + -- nothing from this transaction set gets committed + pure $ + if level > 1 + then Orville.Commit + else Orville.Rollback + + outerActions = + TransactionUtil.runNestedTransactions outerNestingLevel $ \level -> do + _ <- Orville.insertEntity tracerTable Tracer + Monad.when (level >= outerNestingLevel) innerActions + + tracers <- + HH.evalIO $ do + Conn.withPoolConnection pool $ \connection -> + TestTable.dropAndRecreateTableDef connection tracerTable + + Orville.runOrville pool $ do + outerActions + Orville.findEntitiesBy tracerTable mempty + + length tracers === outerNestingLevel + prop_callbacksMadeForTransactionCommit :: Property.NamedDBProperty prop_callbacksMadeForTransactionCommit = Property.namedDBProperty "Callbacks are delivered for a transaction that is commited" $ \pool -> do @@ -116,9 +183,9 @@ allEvents === expectedEvents -prop_callbacksMadeForTransactionRollback :: Property.NamedDBProperty -prop_callbacksMadeForTransactionRollback = - Property.namedDBProperty "Callbacks are delivered for a transaction this is rolled back" $ \pool -> do +prop_callbacksMadeForTransactionRollbackByException :: Property.NamedDBProperty +prop_callbacksMadeForTransactionRollbackByException = + Property.namedDBProperty "Callbacks are delivered for a transaction this is rolled back by an exception" $ \pool -> do nestingLevel <- HH.forAll TransactionUtil.genNestingLevel allEvents <- captureTransactionCallbackEvents pool $ @@ -134,6 +201,24 @@ allEvents === expectedEvents +prop_callbacksMadeForTransactionRollbackByInstruction :: Property.NamedDBProperty +prop_callbacksMadeForTransactionRollbackByInstruction = + Property.namedDBProperty "Callbacks are delivered for a transaction this is rolled back by an instruction" $ \pool -> do + nestingLevel <- HH.forAll TransactionUtil.genNestingLevel + + allEvents <- captureTransactionCallbackEvents pool $ + TransactionUtil.runNestedTransactionWithInstructions nestingLevel $ \_ -> + pure Orville.Rollback + + let + expectedEvents = + mkExpectedEventsForNestedActions nestingLevel $ \maybeSavepoint -> + case maybeSavepoint of + Nothing -> (Orville.BeginTransaction, Orville.RollbackTransaction) + Just savepoint -> (Orville.NewSavepoint savepoint, Orville.RollbackToSavepoint savepoint) + + allEvents === expectedEvents + prop_usesCustomBeginTransactionSql :: Property.NamedDBProperty prop_usesCustomBeginTransactionSql = Property.namedDBProperty "Uses custom begin transaction sql" $ \pool -> do @@ -161,6 +246,92 @@ === [ (Orville.OtherQuery, RawSql.toExampleBytes Expr.commit) , (Orville.OtherQuery, RawSql.toExampleBytes customExpr) ] + +prop_inWithTransaction :: Property.NamedDBProperty +prop_inWithTransaction = + Property.singletonNamedDBProperty "inWithTransaction returns InWithTransaction inside of withTransaction" $ \pool -> do + (inside, insideSavepoint, outsideBefore, outsideAfter) <- HH.evalIO . Orville.runOrville pool $ do + outsideBefore <- Orville.inWithTransaction + inside <- Orville.withTransaction Orville.inWithTransaction + insideSavepoint <- Orville.withTransaction $ Orville.withTransaction Orville.inWithTransaction + outsideAfter <- Orville.inWithTransaction + pure (inside, insideSavepoint, outsideBefore, outsideAfter) + inside === Just Orville.InOutermostTransaction + insideSavepoint === Just (Orville.InSavepointTransaction 1) + outsideBefore === Nothing + outsideAfter === Nothing + +prop_rollbackCallbackInInvalidTransaction :: Property.NamedDBProperty +prop_rollbackCallbackInInvalidTransaction = + Property.singletonNamedDBProperty "withTransaction triggers the rollback callback if the LibPQ transaction status is TransInError" $ \pool -> do + let + badQuery = RawSql.fromString "bad" + + allEvents <- captureTransactionCallbackEvents pool $ + Orville.withTransaction $ do + Orville.liftCatch + catch + (Execution.executeVoid Execution.OtherQuery badQuery) + (\(SomeException _) -> pure ()) + + allEvents === [Orville.BeginTransaction, Orville.RollbackTransaction] + +prop_transactionCleanupRunsAfterBeginTransactionFails :: Property.NamedDBProperty +prop_transactionCleanupRunsAfterBeginTransactionFails = + Property.singletonNamedDBProperty "withTransaction runs cleanup after failed begin callback" $ \pool -> do + block <- UnliftIO.newEmptyMVar + cancel <- UnliftIO.newEmptyMVar + let + run :: Reader.ReaderT Orville.OrvilleState IO a -> IO a + run = + flip Reader.runReaderT (Orville.newOrvilleState Orville.defaultErrorDetailLevel pool) + + callback = + Orville.addTransactionCallback $ \ev -> case ev of + Orville.BeginTransaction -> do + UnliftIO.putMVar cancel () + UnliftIO.takeMVar block + _ -> pure () + + action :: Reader.ReaderT Orville.OrvilleState IO (Maybe LibPQ.TransactionStatus) + action = Orville.withConnection $ \conn -> do + t <- UnliftIO.async . Orville.withTransaction $ pure () + UnliftIO.takeMVar cancel + UnliftIO.cancel t + UnliftIO.liftIO $ Conn.transactionStatus conn + + status <- HH.evalIO . run $ Orville.localOrvilleState callback action + + status === Just LibPQ.TransIdle + +prop_transactionCleanupCannotBeInterrupted :: Property.NamedDBProperty +prop_transactionCleanupCannotBeInterrupted = + Property.singletonNamedDBProperty "withTransaction - finishTransaction cannot be interrupted by an async exception" $ \pool -> do + cancel <- UnliftIO.newEmptyMVar + let + run :: Reader.ReaderT Orville.OrvilleState IO a -> IO a + run = + flip Reader.runReaderT (Orville.newOrvilleState Orville.defaultErrorDetailLevel pool) + + callback = + Orville.addSqlExecutionCallback $ \_ sql act -> + case RawSql.toExampleBytes sql of + "COMMIT" -> do + UnliftIO.putMVar cancel () + Concurrent.threadDelay 500000 + act + _ -> act + + action :: Reader.ReaderT Orville.OrvilleState IO (Maybe LibPQ.TransactionStatus) + action = Orville.withConnection $ \conn -> do + t <- UnliftIO.async . Orville.withTransaction $ pure () + UnliftIO.takeMVar cancel + UnliftIO.cancel t + UnliftIO.liftIO $ Conn.transactionStatus conn + + status <- HH.evalIO . run $ Orville.localOrvilleState callback action + + status === Just LibPQ.TransIdle captureTransactionCallbackEvents :: Orville.ConnectionPool -> diff --git a/test/Test/Transaction/Util.hs b/test/Test/Transaction/Util.hs --- a/test/Test/Transaction/Util.hs +++ b/test/Test/Transaction/Util.hs @@ -4,7 +4,7 @@ , silentlyHandleTestError , genNestingLevel , runNestedTransactions - , runNestedTransactionItems + , runNestedTransactionWithInstructions , transationNestingLevelRange ) where @@ -27,26 +27,37 @@ Int -> (Int -> m ()) -> m () -runNestedTransactions maxLevel = - runNestedTransactionItems [1 .. maxLevel] +runNestedTransactions maxLevel doLevel = + let + go is = + case is of + [] -> + pure () + (item : rest) -> + Orville.withTransaction $ do + doLevel item + go rest + in + go [1 .. maxLevel] -runNestedTransactionItems :: +runNestedTransactionWithInstructions :: Orville.MonadOrville m => - [a] -> - (a -> m ()) -> + Int -> + (Int -> m Orville.TransactionInstruction) -> m () -runNestedTransactionItems items doLevel = +runNestedTransactionWithInstructions maxLevel doLevel = let go is = case is of [] -> pure () (item : rest) -> - Orville.withTransaction $ do - doLevel item + Orville.withTransactionInstruction $ do + instruction <- doLevel item go rest + pure ((), instruction) in - go items + go [1 .. maxLevel] throwTestError :: ExSafe.MonadThrow m => m a throwTestError =