packages feed

orville-postgresql (empty) → 1.0.0.0

raw patch · 152 files changed

+30714/−0 lines, 152 filesdep +attoparsecdep +basedep +bytestring

Dependencies added: attoparsec, base, bytestring, containers, dlist, hedgehog, network-uri, orville-postgresql, postgresql-libpq, random, resource-pool, safe-exceptions, text, time, transformers, unliftio-core, uuid

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# ChangeLog++## v1.0.0.0++First official release.
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2023 Flipstone Technology Partners++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ orville-postgresql.cabal view
@@ -0,0 +1,231 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.35.2.+--+-- see: https://github.com/sol/hpack++name:           orville-postgresql+version:        1.0.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+author:         Flipstone Technology Partners+maintainer:     maintainers@flipstone.com+license:        MIT+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+extra-source-files:+    CHANGELOG.md++source-repository head+  type: git+  location: git@github.com:flipstone/orville.git++flag ci+  description: More strict ghc options used for development and ci, not intended for end-use.+  manual: True+  default: False++library+  exposed-modules:+      Orville.PostgreSQL+      Orville.PostgreSQL.AutoMigration+      Orville.PostgreSQL.Execution+      Orville.PostgreSQL.Execution.Cursor+      Orville.PostgreSQL.Execution.Delete+      Orville.PostgreSQL.Execution.EntityOperations+      Orville.PostgreSQL.Execution.Execute+      Orville.PostgreSQL.Execution.ExecutionResult+      Orville.PostgreSQL.Execution.Insert+      Orville.PostgreSQL.Execution.QueryType+      Orville.PostgreSQL.Execution.ReturningOption+      Orville.PostgreSQL.Execution.Select+      Orville.PostgreSQL.Execution.SelectOptions+      Orville.PostgreSQL.Execution.Sequence+      Orville.PostgreSQL.Execution.Transaction+      Orville.PostgreSQL.Execution.Update+      Orville.PostgreSQL.ErrorDetailLevel+      Orville.PostgreSQL.Expr+      Orville.PostgreSQL.Expr.BinaryOperator+      Orville.PostgreSQL.Expr.ColumnDefinition+      Orville.PostgreSQL.Expr.Count+      Orville.PostgreSQL.Expr.Cursor+      Orville.PostgreSQL.Expr.DataType+      Orville.PostgreSQL.Expr.Delete+      Orville.PostgreSQL.Expr.GroupBy+      Orville.PostgreSQL.Expr.IfExists+      Orville.PostgreSQL.Expr.Index+      Orville.PostgreSQL.Expr.Insert+      Orville.PostgreSQL.Expr.LimitExpr+      Orville.PostgreSQL.Expr.Math+      Orville.PostgreSQL.Expr.Name+      Orville.PostgreSQL.Expr.OffsetExpr+      Orville.PostgreSQL.Expr.OrderBy+      Orville.PostgreSQL.Expr.Query+      Orville.PostgreSQL.Expr.ReturningExpr+      Orville.PostgreSQL.Expr.Select+      Orville.PostgreSQL.Expr.SequenceDefinition+      Orville.PostgreSQL.Expr.TableConstraint+      Orville.PostgreSQL.Expr.TableDefinition+      Orville.PostgreSQL.Expr.TableReferenceList+      Orville.PostgreSQL.Expr.Time+      Orville.PostgreSQL.Expr.Transaction+      Orville.PostgreSQL.Expr.Update+      Orville.PostgreSQL.Expr.ValueExpression+      Orville.PostgreSQL.Expr.WhereClause+      Orville.PostgreSQL.Marshall+      Orville.PostgreSQL.Marshall.DefaultValue+      Orville.PostgreSQL.Marshall.FieldDefinition+      Orville.PostgreSQL.Marshall.MarshallError+      Orville.PostgreSQL.Marshall.SqlMarshaller+      Orville.PostgreSQL.Marshall.SqlType+      Orville.PostgreSQL.Marshall.SyntheticField+      Orville.PostgreSQL.Monad+      Orville.PostgreSQL.Monad.HasOrvilleState+      Orville.PostgreSQL.Monad.MonadOrville+      Orville.PostgreSQL.Monad.Orville+      Orville.PostgreSQL.OrvilleState+      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+      Orville.PostgreSQL.Raw.RawSql+      Orville.PostgreSQL.Raw.SqlCommenter+      Orville.PostgreSQL.Raw.SqlValue+      Orville.PostgreSQL.Schema+      Orville.PostgreSQL.Schema.ConstraintDefinition+      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.UnliftIO+  other-modules:+      Orville.PostgreSQL.Expr.Internal.Name.ColumnName+      Orville.PostgreSQL.Expr.Internal.Name.ConstraintName+      Orville.PostgreSQL.Expr.Internal.Name.CursorName+      Orville.PostgreSQL.Expr.Internal.Name.FunctionName+      Orville.PostgreSQL.Expr.Internal.Name.Identifier+      Orville.PostgreSQL.Expr.Internal.Name.IndexName+      Orville.PostgreSQL.Expr.Internal.Name.Qualified+      Orville.PostgreSQL.Expr.Internal.Name.SavepointName+      Orville.PostgreSQL.Expr.Internal.Name.SchemaName+      Orville.PostgreSQL.Expr.Internal.Name.SequenceName+      Orville.PostgreSQL.Expr.Internal.Name.TableName+      Orville.PostgreSQL.Internal.Bracket+      Orville.PostgreSQL.Internal.Extra.NonEmpty+      Orville.PostgreSQL.Internal.FieldName+      Orville.PostgreSQL.Internal.IndexDefinition+      Orville.PostgreSQL.Internal.MigrationLock+      Orville.PostgreSQL.Internal.MonadOrville+      Orville.PostgreSQL.Internal.OrvilleState+      Orville.PostgreSQL.Internal.RowCountExpectation+      Orville.PostgreSQL.PgCatalog.DatabaseDescription+      Orville.PostgreSQL.PgCatalog.OidField+      Orville.PostgreSQL.PgCatalog.PgAttribute+      Orville.PostgreSQL.PgCatalog.PgAttributeDefault+      Orville.PostgreSQL.PgCatalog.PgClass+      Orville.PostgreSQL.PgCatalog.PgConstraint+      Orville.PostgreSQL.PgCatalog.PgIndex+      Orville.PostgreSQL.PgCatalog.PgNamespace+      Orville.PostgreSQL.PgCatalog.PgSequence+      Paths_orville_postgresql+  hs-source-dirs:+      src+  build-depends:+      attoparsec >=0.10 && <0.15+    , base >=4.8 && <5+    , bytestring >=0.10 && <0.13+    , containers ==0.6.*+    , dlist >=0.8 && <1.1+    , network-uri ==2.6.*+    , postgresql-libpq >=0.9.4.2 && <0.11+    , random >=1.0 && <2+    , resource-pool <0.3 || >=0.4 && <0.5+    , safe-exceptions >=0.1.7 && <0.2+    , text >=1.2 && <1.3 || >=2.0 && <2.2+    , time >=1.9.1 && <1.13+    , 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++test-suite spec+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Test.AutoMigration+      Test.Connection+      Test.Cursor+      Test.Entities.Bar+      Test.Entities.CompositeKeyEntity+      Test.Entities.Foo+      Test.Entities.FooChild+      Test.Entities.User+      Test.EntityOperations+      Test.Execution+      Test.Expr.Count+      Test.Expr.Cursor+      Test.Expr.GroupBy+      Test.Expr.GroupByOrderBy+      Test.Expr.InsertUpdateDelete+      Test.Expr.Math+      Test.Expr.OrderBy+      Test.Expr.SequenceDefinition+      Test.Expr.TableDefinition+      Test.Expr.TestSchema+      Test.Expr.Time+      Test.Expr.Where+      Test.FieldDefinition+      Test.MarshallError+      Test.PgAssert+      Test.PgCatalog+      Test.PgGen+      Test.PgTime+      Test.Plan+      Test.PostgreSQLAxioms+      Test.Property+      Test.RawSql+      Test.ReservedWords+      Test.SelectOptions+      Test.Sequence+      Test.SqlCommenter+      Test.SqlMarshaller+      Test.SqlType+      Test.TableDefinition+      Test.TestTable+      Test.Transaction+      Test.Transaction.Util+      Paths_orville_postgresql+  hs-source-dirs:+      test+  build-depends:+      attoparsec >=0.10 && <0.15+    , base >=4.8 && <5+    , bytestring >=0.10 && <0.13+    , containers ==0.6.*+    , hedgehog >=1.0.5 && <1.5+    , orville-postgresql+    , postgresql-libpq >=0.9.4.2 && <0.11+    , resource-pool <0.3 || >=0.4 && <0.5+    , safe-exceptions >=0.1.7 && <0.2+    , text >=1.2 && <1.3 || >=2.0 && <2.2+    , time >=1.9.1 && <1.13+    , 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
+ src/Orville/PostgreSQL.hs view
@@ -0,0 +1,394 @@+{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++"Orville.PostgreSQL" is the module you will most often want to import for using+Orville. It re-exports most of the functions you need for everyday basic+operations on table entities. If you cannot find the function you need exported here,+you may be able to find it in one of the modules that re-exports more functions+for a specific area:++* "Orville.PostgreSQL.AutoMigration"+* "Orville.PostgreSQL.Execution"+* "Orville.PostgreSQL.Expr"+* "Orville.PostgreSQL.Marshall"+* "Orville.PostgreSQL.Monad"+* "Orville.PostgreSQL.OrvilleState"+* "Orville.PostgreSQL.Schema"++Of course, you can always use the table of contents for the package to see+all the exports Orville offers.++@since 1.0.0.0+-}+module Orville.PostgreSQL+  ( -- * Basic operations on entities in tables+    EntityOperations.insertEntity+  , EntityOperations.insertEntityAndReturnRowCount+  , EntityOperations.insertAndReturnEntity+  , EntityOperations.insertEntities+  , EntityOperations.insertEntitiesAndReturnRowCount+  , EntityOperations.insertAndReturnEntities+  , EntityOperations.updateEntity+  , EntityOperations.updateEntityAndReturnRowCount+  , EntityOperations.updateAndReturnEntity+  , EntityOperations.updateFields+  , EntityOperations.updateFieldsAndReturnEntities+  , EntityOperations.updateFieldsAndReturnRowCount+  , EntityOperations.deleteEntity+  , EntityOperations.deleteEntityAndReturnRowCount+  , EntityOperations.deleteAndReturnEntity+  , EntityOperations.deleteEntities+  , EntityOperations.deleteEntitiesAndReturnRowCount+  , EntityOperations.deleteAndReturnEntities+  , EntityOperations.findEntitiesBy+  , EntityOperations.findFirstEntityBy+  , EntityOperations.findEntity+  , EntityOperations.findEntities++    -- * A simple starter monad for running Orville operations+  , Orville.Orville+  , Orville.runOrville+  , Orville.runOrvilleWithState++    -- * Creating a connection pool+  , Connection.ConnectionOptions+    ( ConnectionOptions+    , connectionString+    , connectionNoticeReporting+    , connectionPoolStripes+    , connectionPoolLingerTime+    , connectionPoolMaxConnections+    )+  , Connection.createConnectionPool+  , Connection.NoticeReporting (EnableNoticeReporting, DisableNoticeReporting)+  , Connection.MaxConnections (MaxConnectionsTotal, MaxConnectionsPerStripe)+  , Connection.StripeOption (OneStripePerCapability, StripeCount)+  , Connection.Connection+  , Connection.ConnectionPool++    -- * Opening transactions and savepoints+  , Transaction.withTransaction++    -- * Types for incorporating Orville into other Monads+  , MonadOrville.MonadOrville+  , MonadOrville.withConnection_+  , MonadOrville.withConnection+  , MonadOrville.MonadOrvilleControl (liftWithConnection, liftCatch, liftMask)+  , HasOrvilleState.HasOrvilleState (askOrvilleState, localOrvilleState)+  , OrvilleState.OrvilleState+  , OrvilleState.newOrvilleState+  , OrvilleState.resetOrvilleState+  , OrvilleState.addTransactionCallback+  , OrvilleState.TransactionEvent (BeginTransaction, NewSavepoint, ReleaseSavepoint, RollbackToSavepoint, CommitTransaction, RollbackTransaction)+  , OrvilleState.Savepoint+  , OrvilleState.addSqlExecutionCallback+  , OrvilleState.setBeginTransactionExpr+  , OrvilleState.setSqlCommenterAttributes+  , OrvilleState.addSqlCommenterAttributes+  , ErrorDetailLevel.ErrorDetailLevel (ErrorDetailLevel, includeErrorMessage, includeSchemaNames, includeRowIdentifierValues, includeNonIdentifierValues)+  , ErrorDetailLevel.defaultErrorDetailLevel+  , ErrorDetailLevel.minimalErrorDetailLevel+  , ErrorDetailLevel.maximalErrorDetailLevel++    -- * Functions for defining a database schema+  , TableDefinition.TableDefinition+  , TableDefinition.mkTableDefinition+  , TableDefinition.mkTableDefinitionWithoutKey+  , TableDefinition.setTableSchema+  , TableDefinition.tableConstraints+  , TableDefinition.addTableConstraints+  , TableDefinition.tableIndexes+  , TableDefinition.addTableIndexes+  , TableDefinition.dropColumns+  , TableDefinition.columnsToDrop+  , TableDefinition.tableIdentifier+  , TableDefinition.tableName+  , TableDefinition.mkCreateTableExpr+  , TableDefinition.mkTableColumnDefinitions+  , TableDefinition.mkTablePrimaryKeyExpr+  , TableDefinition.tablePrimaryKey+  , TableDefinition.tableMarshaller+  , TableDefinition.HasKey+  , TableDefinition.NoKey+  , TableIdentifier.TableIdentifier+  , TableIdentifier.unqualifiedNameToTableId+  , TableIdentifier.tableIdUnqualifiedNameString+  , TableIdentifier.tableIdQualifiedName+  , TableIdentifier.setTableIdSchema+  , TableIdentifier.tableIdSchemaNameString+  , TableIdentifier.tableIdToString+  , ConstraintDefinition.ConstraintDefinition+  , ConstraintDefinition.uniqueConstraint+  , ConstraintDefinition.foreignKeyConstraint+  , ConstraintDefinition.foreignKeyConstraintWithOptions+  , ConstraintDefinition.ForeignKeyOptions+  , ConstraintDefinition.foreignKeyOptionsOnDelete+  , ConstraintDefinition.foreignKeyOptionsOnUpdate+  , ConstraintDefinition.defaultForeignKeyOptions+  , ConstraintDefinition.ForeignKeyAction (..)+  , ConstraintDefinition.ForeignReference (ForeignReference, localFieldName, foreignFieldName)+  , ConstraintDefinition.foreignReference+  , ConstraintDefinition.ConstraintMigrationKey (ConstraintMigrationKey, constraintKeyType, constraintKeyColumns, constraintKeyForeignTable, constraintKeyForeignColumns, constraintKeyForeignKeyOnUpdateAction, constraintKeyForeignKeyOnDeleteAction)+  , ConstraintDefinition.ConstraintKeyType (UniqueConstraint, ForeignKeyConstraint)+  , ConstraintDefinition.constraintMigrationKey+  , ConstraintDefinition.constraintSqlExpr+  , IndexDefinition.IndexDefinition+  , IndexDefinition.uniqueIndex+  , IndexDefinition.nonUniqueIndex+  , IndexDefinition.mkIndexDefinition+  , IndexDefinition.mkNamedIndexDefinition+  , IndexDefinition.IndexUniqueness (UniqueIndex, NonUniqueIndex)+  , IndexDefinition.indexCreateExpr+  , IndexDefinition.IndexCreationStrategy (Transactional, Concurrent)+  , IndexDefinition.setIndexCreationStrategy+  , IndexDefinition.indexCreationStrategy+  , PrimaryKey.PrimaryKey+  , PrimaryKey.primaryKey+  , PrimaryKey.compositePrimaryKey+  , PrimaryKey.primaryKeyPart+  , SqlMarshaller.SqlMarshaller+  , SqlMarshaller.AnnotatedSqlMarshaller+  , SqlMarshaller.annotateSqlMarshaller+  , SqlMarshaller.annotateSqlMarshallerEmptyAnnotation+  , SqlMarshaller.unannotatedSqlMarshaller+  , SqlMarshaller.mapSqlMarshaller+  , SqlMarshaller.marshallField+  , SqlMarshaller.marshallNested+  , SqlMarshaller.marshallSyntheticField+  , SqlMarshaller.marshallReadOnly+  , SqlMarshaller.marshallReadOnlyField+  , SqlMarshaller.marshallPartial+  , SqlMarshaller.marshallMaybe+  , SqlMarshaller.prefixMarshaller+  , SqlMarshaller.foldMarshallerFields+  , SqlMarshaller.collectFromField+  , SqlMarshaller.ReadOnlyColumnOption (IncludeReadOnlyColumns, ExcludeReadOnlyColumns)+  , SyntheticField.SyntheticField+  , SyntheticField.syntheticFieldExpression+  , SyntheticField.syntheticFieldAlias+  , SyntheticField.syntheticFieldValueFromSqlValue+  , SyntheticField.syntheticField+  , SyntheticField.nullableSyntheticField+  , SyntheticField.prefixSyntheticField+  , FieldDefinition.FieldDefinition+  , FieldDefinition.NotNull+  , FieldDefinition.Nullable+  , FieldDefinition.nullableField+  , FieldDefinition.asymmetricNullableField+  , FieldDefinition.convertField+  , FieldDefinition.coerceField+  , FieldDefinition.setDefaultValue+  , FieldDefinition.removeDefaultValue+  , FieldDefinition.prefixField+  , FieldDefinition.integerField+  , FieldDefinition.serialField+  , FieldDefinition.smallIntegerField+  , FieldDefinition.uuidField+  , FieldDefinition.bigIntegerField+  , FieldDefinition.bigSerialField+  , FieldDefinition.doubleField+  , FieldDefinition.booleanField+  , FieldDefinition.unboundedTextField+  , FieldDefinition.boundedTextField+  , FieldDefinition.fixedTextField+  , FieldDefinition.textSearchVectorField+  , FieldDefinition.dateField+  , FieldDefinition.utcTimestampField+  , FieldDefinition.localTimestampField+  , FieldDefinition.jsonbField+  , FieldDefinition.fieldOfType+  , FieldDefinition.fieldColumnName+  , FieldDefinition.fieldColumnReference+  , FieldDefinition.fieldName+  , FieldDefinition.setFieldName+  , FieldDefinition.fieldDescription+  , FieldDefinition.setFieldDescription+  , FieldDefinition.addUniqueConstraint+  , FieldDefinition.addForeignKeyConstraint+  , FieldDefinition.FieldName+  , FieldDefinition.stringToFieldName+  , FieldDefinition.fieldNameToString+  , FieldDefinition.fieldNameToColumnName+  , FieldDefinition.fieldNameToByteString+  , FieldDefinition.fieldType+  , FieldDefinition.fieldDefaultValue+  , FieldDefinition.fieldColumnDefinition+  , FieldDefinition.fieldIsNotNullable+  , FieldDefinition.fieldNullability+  , FieldDefinition.setField+  , (FieldDefinition..:=)+  , FieldDefinition.FieldNullability (NotNullField, NullableField)+  , DefaultValue.DefaultValue+  , DefaultValue.integerDefault+  , DefaultValue.smallIntegerDefault+  , DefaultValue.bigIntegerDefault+  , DefaultValue.integralDefault+  , DefaultValue.doubleDefault+  , DefaultValue.booleanDefault+  , DefaultValue.textDefault+  , DefaultValue.dateDefault+  , DefaultValue.currentDateDefault+  , DefaultValue.utcTimestampDefault+  , DefaultValue.currentUTCTimestampDefault+  , DefaultValue.localTimestampDefault+  , DefaultValue.currentLocalTimestampDefault+  , DefaultValue.coerceDefaultValue+  , DefaultValue.defaultValueExpression+  , DefaultValue.rawSqlDefault++    -- * Functions and operators for putting where clauses, order by clauses++  -- and limits on selects+  , SelectOptions.SelectOptions+  , SelectOptions.distinct+  , SelectOptions.groupBy+  , SelectOptions.limit+  , SelectOptions.offset+  , SelectOptions.orderBy+  , SelectOptions.where_+  , SelectOptions.emptySelectOptions+  , SelectOptions.appendSelectOptions+  , FieldDefinition.fieldEquals+  , (FieldDefinition..==)+  , FieldDefinition.fieldNotEquals+  , (FieldDefinition../=)+  , FieldDefinition.fieldGreaterThan+  , (FieldDefinition..>)+  , FieldDefinition.fieldLessThan+  , (FieldDefinition..<)+  , FieldDefinition.fieldGreaterThanOrEqualTo+  , (FieldDefinition..>=)+  , FieldDefinition.fieldLessThanOrEqualTo+  , (FieldDefinition..<=)+  , FieldDefinition.fieldLike+  , FieldDefinition.fieldLikeInsensitive+  , FieldDefinition.fieldIsNull+  , FieldDefinition.fieldIsNotNull+  , FieldDefinition.fieldIn+  , (FieldDefinition..<-)+  , FieldDefinition.fieldNotIn+  , (FieldDefinition..</-)+  , FieldDefinition.fieldTupleIn+  , FieldDefinition.fieldTupleNotIn+  , Expr.OrderByDirection+  , Expr.NullsOrder (..)+  , Expr.ascendingOrder+  , Expr.ascendingOrderWith+  , Expr.descendingOrder+  , Expr.descendingOrderWith+  , FieldDefinition.orderByField+  , Expr.orderByColumnName+  , Expr.andExpr+  , Expr.orExpr+  , (Expr..&&)+  , (Expr..||)+  , SelectOptions.selectGroupByClause+  , SelectOptions.selectOrderByClause+  , SelectOptions.selectWhereClause+  , SelectOptions.selectDistinct++    -- * Functions for defining and working with sequences+  , Sequence.sequenceNextValue+  , Sequence.sequenceCurrentValue+  , Sequence.sequenceSetValue+  , SequenceDefinition.SequenceDefinition+  , SequenceDefinition.mkSequenceDefinition+  , SequenceDefinition.setSequenceSchema+  , SequenceDefinition.sequenceIdentifier+  , SequenceDefinition.sequenceName+  , SequenceDefinition.sequenceIncrement+  , SequenceDefinition.setSequenceIncrement+  , SequenceDefinition.sequenceMinValue+  , SequenceDefinition.setSequenceMinValue+  , SequenceDefinition.sequenceMaxValue+  , SequenceDefinition.setSequenceMaxValue+  , SequenceDefinition.sequenceStart+  , SequenceDefinition.setSequenceStart+  , SequenceDefinition.sequenceCache+  , SequenceDefinition.setSequenceCache+  , SequenceDefinition.sequenceCycle+  , SequenceDefinition.setSequenceCycle+  , SequenceDefinition.mkCreateSequenceExpr+  , SequenceIdentifier.SequenceIdentifier+  , SequenceIdentifier.unqualifiedNameToSequenceId+  , SequenceIdentifier.sequenceIdUnqualifiedNameString+  , SequenceIdentifier.sequenceIdQualifiedName+  , SequenceIdentifier.setSequenceIdSchema+  , SequenceIdentifier.sequenceIdSchemaNameString+  , SequenceIdentifier.sequenceIdToString++    -- * Numeric types+  , SqlType.integer+  , SqlType.serial+  , SqlType.bigInteger+  , SqlType.bigSerial+  , SqlType.double++    -- * Textual-ish types+  , SqlType.boolean+  , SqlType.unboundedText+  , SqlType.fixedText+  , SqlType.boundedText+  , SqlType.textSearchVector+  , SqlType.uuid++    -- * Date types+  , SqlType.date+  , SqlType.timestamp++    -- * Json type+  , SqlType.jsonb++    -- * Type conversions+  , SqlType.foreignRefType+  , SqlType.convertSqlType+  , SqlType.tryConvertSqlType+  , SqlType.SqlType+    ( SqlType.SqlType+    , SqlType.sqlTypeExpr+    , SqlType.sqlTypeReferenceExpr+    , SqlType.sqlTypeOid+    , SqlType.sqlTypeMaximumLength+    , SqlType.sqlTypeToSql+    , SqlType.sqlTypeFromSql+    , SqlType.sqlTypeDontDropImplicitDefaultDuringMigrate+    )+  , Expr.QueryExpr+  , Execute.executeAndDecode+  , Execute.executeAndReturnAffectedRows+  , Execute.executeVoid+  , QueryType.QueryType (SelectQuery, InsertQuery, UpdateQuery, DeleteQuery, DDLQuery, OtherQuery)++    -- * [SqlCommenter](https://google.github.io/sqlcommenter/) support+  , SqlCommenter.SqlCommenterAttributes+  )+where++import qualified Orville.PostgreSQL.ErrorDetailLevel as ErrorDetailLevel+import qualified Orville.PostgreSQL.Execution.EntityOperations as EntityOperations+import qualified Orville.PostgreSQL.Execution.Execute as Execute+import qualified Orville.PostgreSQL.Execution.QueryType as QueryType+import qualified Orville.PostgreSQL.Execution.SelectOptions as SelectOptions+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.DefaultValue as DefaultValue+import qualified Orville.PostgreSQL.Marshall.FieldDefinition as FieldDefinition+import qualified Orville.PostgreSQL.Marshall.SqlMarshaller as SqlMarshaller+import qualified Orville.PostgreSQL.Marshall.SqlType as SqlType+import qualified Orville.PostgreSQL.Marshall.SyntheticField as SyntheticField+import qualified Orville.PostgreSQL.Monad.HasOrvilleState as HasOrvilleState+import qualified Orville.PostgreSQL.Monad.MonadOrville as MonadOrville+import qualified Orville.PostgreSQL.Monad.Orville as Orville+import qualified Orville.PostgreSQL.OrvilleState as OrvilleState+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.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
+ src/Orville/PostgreSQL/AutoMigration.hs view
@@ -0,0 +1,1215 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++Facilities for performing some database migrations automatically.+See 'autoMigrateSchema' as a primary, high-level entry point.++@since 1.0.0.0+-}+module Orville.PostgreSQL.AutoMigration+  ( MigrationOptions (runSchemaChanges, runConcurrentIndexCreations, migrationLockId)+  , defaultOptions+  , autoMigrateSchema+  , SchemaItem (..)+  , schemaItemSummary+  , MigrationPlan+  , generateMigrationPlan+  , migrationPlanSteps+  , executeMigrationPlan+  , MigrationStep+  , MigrationDataError+  , MigrationLock.MigrationLockId+  , MigrationLock.defaultLockId+  , MigrationLock.nextLockId+  , MigrationLock.withMigrationLock+  , MigrationLock.MigrationLockError+  )+where++import Control.Exception.Safe (Exception, throwIO)+import Control.Monad (guard, when)+import Control.Monad.IO.Class (liftIO)+import Data.Foldable (traverse_)+import qualified Data.List as List+import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty)+import qualified Data.Map.Strict as Map+import qualified Data.Maybe as Maybe+import qualified Data.Set as Set+import qualified Data.String as String+import qualified Data.Text.Encoding as Enc+import qualified Database.PostgreSQL.LibPQ as LibPQ++import qualified Orville.PostgreSQL as Orville+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.PgCatalog as PgCatalog+import qualified Orville.PostgreSQL.Raw.RawSql as RawSql+import qualified Orville.PostgreSQL.Schema as Schema++{- |+  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'.++@since 1.0.0.0+-}+data SchemaItem where+  -- |+  --    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+  --    found in the database.+  -- @since 1.0.0.0+  SchemaDropTable ::+    Orville.TableIdentifier ->+    SchemaItem+  -- |+  --    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.+  -- @since 1.0.0.0+  SchemaDropSequence ::+    Orville.SequenceIdentifier ->+    SchemaItem++{- |+  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 <table+  name>@.++@since 1.0.0.0+-}+schemaItemSummary :: SchemaItem -> String+schemaItemSummary item =+  case item of+    SchemaTable tableDef ->+      "Table " <> Orville.tableIdToString (Orville.tableIdentifier tableDef)+    SchemaDropTable tableId ->+      "Drop table " <> Orville.tableIdToString tableId+    SchemaSequence sequenceDef ->+      "Sequence " <> Orville.sequenceIdToString (Orville.sequenceIdentifier sequenceDef)+    SchemaDropSequence sequenceId ->+      "Drop sequence " <> Orville.sequenceIdToString sequenceId++{- |+A 'MigrationPlan' contains an ordered list of migration steps. Each one is a+single DDL statement to make a specific database change. The steps are ordered+such that dependencies from earlier steps will be in place before a later step+is executed (e.g. new columns are added before foreign keys referring to them).++While most steps are executed together in a single transaction this is not+possible for indexes being created concurrently. Any such steps are executed+last after the transaction for the rest of the schema changes has been+successfully committed.++@since 1.0.0.0+-}+data MigrationPlan = MigrationPlan+  { i_transactionalSteps :: [MigrationStep]+  , i_concurrentIndexSteps :: [MigrationStep]+  }++{- |+  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+  within a transaction while the concurrent index steps are done afterward+  outside of it.++@since 1.0.0.0+-}+migrationPlanSteps :: MigrationPlan -> [MigrationStep]+migrationPlanSteps plan =+  i_transactionalSteps plan <> i_concurrentIndexSteps plan++mkMigrationPlan :: [MigrationStepWithType] -> MigrationPlan+mkMigrationPlan steps =+  let+    (transactionalSteps, concurrentIndexSteps) =+      List.partition isMigrationStepTransactional+        . List.sortOn migrationStepType+        $ steps+  in+    MigrationPlan+      { i_transactionalSteps = map migrationStep transactionalSteps+      , i_concurrentIndexSteps = map migrationStep concurrentIndexSteps+      }++{- |+  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.++@since 1.0.0.0+-}+newtype MigrationStep+  = MigrationStep RawSql.RawSql+  deriving+    ( -- | @since 1.0.0.0+      RawSql.SqlExpression+    )++{- |+  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+-}+data MigrationStepWithType = MigrationStepWithType+  { migrationStepType :: StepType+  , migrationStep :: MigrationStep+  }++mkMigrationStepWithType ::+  RawSql.SqlExpression sql =>+  StepType ->+  sql ->+  MigrationStepWithType+mkMigrationStepWithType stepType sql =+  MigrationStepWithType+    { migrationStepType = stepType+    , migrationStep = MigrationStep (RawSql.toRawSql sql)+    }++isMigrationStepTransactional :: MigrationStepWithType -> Bool+isMigrationStepTransactional stepWithType =+  case migrationStepType stepWithType of+    DropForeignKeys -> True+    DropUniqueConstraints -> True+    DropIndexes -> True+    AddRemoveTablesAndColumns -> True+    AddIndexesTransactionally -> True+    AddUniqueConstraints -> True+    AddForeignKeys -> True+    AddIndexesConcurrently -> False++{- |+  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.++@since 1.0.0.0+-}+data StepType+  = DropForeignKeys+  | DropUniqueConstraints+  | DropIndexes+  | AddRemoveTablesAndColumns+  | AddIndexesTransactionally+  | AddUniqueConstraints+  | AddForeignKeys+  | AddIndexesConcurrently+  deriving+    ( -- | @since 1.0.0.0+      Eq+    , -- | @since 1.0.0.0+      Ord+    )++{- |+  A 'MigrationDataError' will be thrown from the migration functions if data+  necessary for migration cannot be found.++@since 1.0.0.0+-}+data MigrationDataError+  = UnableToDiscoverCurrentSchema String+  | PgCatalogInvariantViolated String+  deriving+    ( -- | @since 1.0.0.0+      Show+    )++-- | @since 1.0.0.0+instance Exception MigrationDataError++{- |+Options to control how 'autoMigrateSchema' and similar functions behave. You+should use 'defaultOptions' to construct a 'MigrationOptions' value+and then use the record accessors to change any values you want to customize.++@since 1.0.0.0+-}+data MigrationOptions = MigrationOptions+  { runSchemaChanges :: Bool+  -- ^+  --       Indicates whether the normal schema changes (other than concurrent index+  --       creations) should be run. The default value is 'True'. You may want to+  --       disable this if you wish to run concurrent index creations separately+  --       from the rest of the schema changes.+  --+  --       @since 1.0.0.0+  , runConcurrentIndexCreations :: Bool+  -- ^+  --       Indicates whether indexes with the 'Orville.Concurrent' creation strategy+  --       will be created. The default value is 'True'. You may want to disable+  --       this if you wish to run concurrent index creations separately from the+  --       rest of the schema changes.+  --+  --       @since 1.0.0.0+  , migrationLockId :: MigrationLock.MigrationLockId+  -- ^+  --       The 'MigrationLock.MigrationLockId' that will be use 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.+  --+  --       @since 1.0.0.0+  }++{- |+The default 'MigrationOptions', which is to run both the schema changes and+concurrent index creations together using the default Orville migration lock.++@since 1.0.0.0+-}+defaultOptions :: MigrationOptions+defaultOptions =+  MigrationOptions+    { runSchemaChanges = True+    , runConcurrentIndexCreations = True+    , migrationLockId = MigrationLock.defaultLockId+    }++{- |+  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+  to have more control over the process, but must then take care to ensure that+  the schema has not changed between the two calls. This function uses a+  PostgreSQL advisory lock to ensure that no other calls to 'autoMigrateSchema'+  (potentially on other processes) attempt to modify the schema at the same+  time.++@since 1.0.0.0+-}+autoMigrateSchema ::+  Orville.MonadOrville m =>+  MigrationOptions ->+  [SchemaItem] ->+  m ()+autoMigrateSchema options schemaItems =+  MigrationLock.withMigrationLock (migrationLockId options) $ do+    plan <- generateMigrationPlanWithoutLock schemaItems+    executeMigrationPlanWithoutLock options plan++{- |+  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.++  You can execute the 'MigrationPlan' yourself using the 'executeMigrationPlan'+  convenience function, though 'autoMigrateSchema' is usually a better option+  because it uses a database lock to ensure that no other processes are also+  using 'autoMigrateSchema' to apply migrations at the same time. If you use+  'generateMigrationPlan' and 'executeMigrationPlan' separately, you are+  responsible for ensuring that the schema has not changed between the time the+  plan is generated and executed yourself.++@since 1.0.0.0+-}+generateMigrationPlan ::+  Orville.MonadOrville m =>+  MigrationOptions ->+  [SchemaItem] ->+  m MigrationPlan+generateMigrationPlan options =+  MigrationLock.withMigrationLock (migrationLockId options)+    . generateMigrationPlanWithoutLock++generateMigrationPlanWithoutLock :: Orville.MonadOrville m => [SchemaItem] -> m MigrationPlan+generateMigrationPlanWithoutLock schemaItems =+  Orville.withTransaction $ do+    currentNamespace <- findCurrentNamespace++    let+      pgCatalogRelations = fmap (schemaItemPgCatalogRelation currentNamespace) schemaItems++    dbDesc <- PgCatalog.describeDatabaseRelations pgCatalogRelations++    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+  '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+  'Orville.Concurrent' creation strategy cannot be created this way, however,+  because PostgreSQL does not allow @CREATE INDEX CONCURRENTLY@ to be used from+  inside a transaction. If a 'MigrationPlan' includes any indexes whose+  creation strategy is set to 'Orville.Concurrent', Orville will create indexes+  after the rest of the migration steps have been committed successfully. This+  function will wait until all of the migration steps that it runs to finish+  before returning. If one of the concurrent indexes fails during creation, it+  will be left in an invalid state (as is the default PostgreSQL behavior). You+  should check on the status of indexes created this way manually to ensure+  they were created successfully. If they could not be, you can drop them and+  Orville will re-attempt creating them the next time migration is performed.++@since 1.0.0.0+-}+executeMigrationPlan ::+  Orville.MonadOrville m =>+  MigrationOptions ->+  MigrationPlan ->+  m ()+executeMigrationPlan options =+  MigrationLock.withMigrationLock (migrationLockId options)+    . executeMigrationPlanWithoutLock options++executeMigrationPlanWithoutLock ::+  Orville.MonadOrville m =>+  MigrationOptions ->+  MigrationPlan ->+  m ()+executeMigrationPlanWithoutLock options plan = do+  when (runSchemaChanges options)+    . Orville.withTransaction+    . executeMigrationStepsWithoutTransaction+    . i_transactionalSteps+    $ plan++  when (runConcurrentIndexCreations options)+    . executeMigrationStepsWithoutTransaction+    $ i_concurrentIndexSteps+    $ plan++executeMigrationStepsWithoutTransaction :: Orville.MonadOrville m => [MigrationStep] -> m ()+executeMigrationStepsWithoutTransaction =+  traverse_ (Orville.executeVoid Orville.DDLQuery)++calculateMigrationSteps ::+  PgCatalog.NamespaceName ->+  PgCatalog.DatabaseDescription ->+  SchemaItem ->+  Either MigrationDataError [MigrationStepWithType]+calculateMigrationSteps currentNamespace dbDesc schemaItem =+  case schemaItem of+    SchemaTable tableDef ->+      Right $+        let+          (schemaName, tableName) =+            tableIdToPgCatalogNames+              currentNamespace+              (Orville.tableIdentifier tableDef)+        in+          case PgCatalog.lookupRelationOfKind PgCatalog.OrdinaryTable (schemaName, tableName) dbDesc of+            Nothing ->+              mkCreateTableSteps currentNamespace tableDef+            Just relationDesc ->+              mkAlterTableSteps currentNamespace relationDesc tableDef+    SchemaDropTable tableId ->+      Right $+        let+          (schemaName, tableName) =+            tableIdToPgCatalogNames currentNamespace tableId+        in+          case PgCatalog.lookupRelation (schemaName, tableName) dbDesc of+            Nothing ->+              []+            Just _ ->+              let+                dropTableExpr =+                  Expr.dropTableExpr+                    Nothing+                    (Orville.tableIdQualifiedName tableId)+              in+                [mkMigrationStepWithType AddRemoveTablesAndColumns dropTableExpr]+    SchemaSequence sequenceDef ->+      let+        (schemaName, sequenceName) =+          sequenceIdToPgCatalogNames+            currentNamespace+            (Orville.sequenceIdentifier sequenceDef)+      in+        case PgCatalog.lookupRelationOfKind PgCatalog.Sequence (schemaName, sequenceName) dbDesc of+          Nothing ->+            Right+              [ mkMigrationStepWithType+                  AddRemoveTablesAndColumns+                  (Orville.mkCreateSequenceExpr sequenceDef)+              ]+          Just relationDesc ->+            case PgCatalog.relationSequence relationDesc of+              Nothing ->+                Left . PgCatalogInvariantViolated $+                  "Sequence "+                    <> PgCatalog.namespaceNameToString schemaName+                    <> "."+                    <> PgCatalog.relationNameToString sequenceName+                    <> " was found in the 'pg_class' table but no corresponding 'pg_sequence' row was found"+              Just pgSequence ->+                Right $+                  mkAlterSequenceSteps sequenceDef pgSequence+    SchemaDropSequence sequenceId ->+      Right $+        let+          (schemaName, sequenceName) =+            sequenceIdToPgCatalogNames currentNamespace sequenceId+        in+          case PgCatalog.lookupRelationOfKind PgCatalog.Sequence (schemaName, sequenceName) dbDesc of+            Nothing ->+              []+            Just _ ->+              [ mkMigrationStepWithType+                  AddRemoveTablesAndColumns+                  (Expr.dropSequenceExpr Nothing (Orville.sequenceIdQualifiedName sequenceId))+              ]++{- |+  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+  may not have been created yet.++@since 1.0.0.0+-}+mkCreateTableSteps ::+  PgCatalog.NamespaceName ->+  Orville.TableDefinition key writeEntity readEntity ->+  [MigrationStepWithType]+mkCreateTableSteps currentNamespace tableDef =+  let+    tableName =+      Orville.tableName tableDef++    -- constraints are not included in the create table expression because+    -- they are added in a separate migration step to avoid ordering problems+    -- when creating multiple tables with interrelated foreign keys.+    createTableExpr =+      Expr.createTableExpr+        tableName+        (Orville.mkTableColumnDefinitions tableDef)+        (Orville.mkTablePrimaryKeyExpr tableDef)+        []++    addConstraintActions =+      concatMap+        (mkAddConstraintActions currentNamespace Set.empty)+        (Schema.tableConstraintDefinitions $ Orville.tableConstraints tableDef)++    addIndexSteps =+      concatMap+        (mkAddIndexSteps Set.empty tableName)+        (Orville.tableIndexes tableDef)+  in+    mkMigrationStepWithType AddRemoveTablesAndColumns createTableExpr+      : mkConstraintSteps tableName addConstraintActions+        <> addIndexSteps++{- |+  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+  alterations need to be performed. If there is nothing to do, an empty list+  will be returned.++@since 1.0.0.0+-}+mkAlterTableSteps ::+  PgCatalog.NamespaceName ->+  PgCatalog.RelationDescription ->+  Orville.TableDefinition key writeEntity readEntity ->+  [MigrationStepWithType]+mkAlterTableSteps currentNamespace relationDesc tableDef =+  let+    addAlterColumnActions =+      concat $+        Orville.foldMarshallerFields+          (Orville.unannotatedSqlMarshaller $ Orville.tableMarshaller tableDef)+          []+          (Orville.collectFromField Orville.IncludeReadOnlyColumns (mkAddAlterColumnActions relationDesc))++    dropColumnActions =+      concatMap+        (mkDropColumnActions tableDef)+        (PgCatalog.relationAttributes relationDesc)++    existingConstraints =+      Set.fromList+        . Maybe.mapMaybe pgConstraintMigrationKey+        . PgCatalog.relationConstraints+        $ relationDesc++    constraintsToKeep =+      Set.map (setDefaultSchemaNameOnConstraintKey currentNamespace)+        . Schema.tableConstraintKeys+        . Orville.tableConstraints+        $ tableDef++    addConstraintActions =+      concatMap+        (mkAddConstraintActions currentNamespace existingConstraints)+        (Schema.tableConstraintDefinitions $ Orville.tableConstraints tableDef)++    dropConstraintActions =+      concatMap+        (mkDropConstraintActions constraintsToKeep)+        (PgCatalog.relationConstraints relationDesc)++    systemIndexOids =+      Set.fromList+        . Maybe.mapMaybe (pgConstraintImpliedIndexOid . PgCatalog.constraintRecord)+        . PgCatalog.relationConstraints+        $ relationDesc++    isSystemIndex indexDesc =+      Set.member+        (PgCatalog.pgIndexPgClassOid $ PgCatalog.indexRecord indexDesc)+        systemIndexOids++    existingIndexes =+      Set.fromList+        . concatMap pgIndexMigrationKeys+        . filter (not . isSystemIndex)+        . PgCatalog.relationIndexes+        $ relationDesc++    indexesToKeep =+      Map.keysSet+        . Orville.tableIndexes+        $ tableDef++    addIndexSteps =+      concatMap+        (mkAddIndexSteps existingIndexes tableName)+        (Orville.tableIndexes tableDef)++    dropIndexSteps =+      concatMap+        (mkDropIndexSteps indexesToKeep systemIndexOids)+        (PgCatalog.relationIndexes relationDesc)++    tableName =+      Orville.tableName tableDef+  in+    mkAlterColumnSteps tableName (addAlterColumnActions <> dropColumnActions)+      <> mkConstraintSteps tableName (addConstraintActions <> dropConstraintActions)+      <> addIndexSteps+      <> dropIndexSteps++{- |+  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.++@since 1.0.0.0+-}+mkConstraintSteps ::+  Expr.Qualified Expr.TableName ->+  [(StepType, Expr.AlterTableAction)] ->+  [MigrationStepWithType]+mkConstraintSteps tableName actions =+  let+    mkMapEntry ::+      (StepType, Expr.AlterTableAction) ->+      (StepType, NonEmpty Expr.AlterTableAction)+    mkMapEntry (keyType, action) =+      (keyType, (action :| []))++    addStep stepType actionExprs steps =+      mkMigrationStepWithType stepType (Expr.alterTableExpr tableName actionExprs) : steps+  in+    Map.foldrWithKey addStep []+      . Map.fromListWith (<>)+      . map mkMapEntry+      $ actions++{- |+  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.AlterTableAction] ->+  [MigrationStepWithType]+mkAlterColumnSteps tableName actionExprs =+  case nonEmpty actionExprs of+    Nothing ->+      []+    Just nonEmptyActionExprs ->+      [mkMigrationStepWithType AddRemoveTablesAndColumns (Expr.alterTableExpr tableName nonEmptyActionExprs)]++{- |+  Builds 'Expr.AlterTableAction' expressions to bring the database schema in+  line with the given 'Orville.FieldDefinition', or none if no change is+  required.++@since 1.0.0.0+-}+mkAddAlterColumnActions ::+  PgCatalog.RelationDescription ->+  Orville.FieldDefinition nullability a ->+  [Expr.AlterTableAction]+mkAddAlterColumnActions relationDesc fieldDef =+  let+    pgAttributeName =+      String.fromString (Orville.fieldNameToString $ Orville.fieldName fieldDef)+  in+    case PgCatalog.lookupAttribute pgAttributeName relationDesc of+      Just attr+        | PgCatalog.isOrdinaryColumn attr ->+            let+              sqlType =+                Orville.fieldType fieldDef++              typeIsChanged =+                (Orville.sqlTypeOid sqlType /= PgCatalog.pgAttributeTypeOid attr)+                  || (Orville.sqlTypeMaximumLength sqlType /= PgCatalog.pgAttributeMaxLength attr)++              columnName =+                Orville.fieldColumnName fieldDef++              dataType =+                Orville.sqlTypeExpr sqlType++              alterType = do+                guard typeIsChanged+                [Expr.alterColumnType columnName dataType (Just $ Expr.usingCast columnName dataType)]++              nullabilityIsChanged =+                Orville.fieldIsNotNullable fieldDef /= PgCatalog.pgAttributeIsNotNull attr++              nullabilityAction =+                if Orville.fieldIsNotNullable fieldDef+                  then Expr.setNotNull+                  else Expr.dropNotNull++              alterNullability = do+                guard nullabilityIsChanged+                [Expr.alterColumnNullability (Orville.fieldColumnName fieldDef) nullabilityAction]++              maybeExistingDefault =+                PgCatalog.lookupAttributeDefault attr relationDesc++              maybeDefaultExpr =+                Orville.defaultValueExpression+                  <$> Orville.fieldDefaultValue fieldDef++              (dropDefault, setDefault) =+                case (maybeExistingDefault, maybeDefaultExpr) of+                  (Nothing, Nothing) ->+                    (Nothing, Nothing)+                  (Just _, Nothing) ->+                    if Orville.sqlTypeDontDropImplicitDefaultDuringMigrate sqlType+                      then (Nothing, Nothing)+                      else+                        ( Just (Expr.alterColumnDropDefault columnName)+                        , Nothing+                        )+                  (Nothing, Just newDefault) ->+                    ( Nothing+                    , Just (Expr.alterColumnSetDefault columnName newDefault)+                    )+                  (Just oldDefault, Just newDefault) ->+                    let+                      oldDefaultExprBytes =+                        Enc.encodeUtf8+                          . PgCatalog.pgAttributeDefaultExpression+                          $ oldDefault++                      newDefaultExprBytes =+                        RawSql.toExampleBytes newDefault+                    in+                      if oldDefaultExprBytes == newDefaultExprBytes+                        then (Nothing, Nothing)+                        else+                          ( Just (Expr.alterColumnDropDefault columnName)+                          , Just (Expr.alterColumnSetDefault columnName newDefault)+                          )+            in+              Maybe.maybeToList dropDefault <> alterType <> Maybe.maybeToList setDefault <> alterNullability+      _ ->+        -- 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+        -- in an error that will be reported to the user. We could explicitly+        -- return an error from this function, but that would make the error+        -- reporting inconsistent with the handling in create table, where we+        -- must rely on the database to raise the error because the table+        -- does not yet exist for us to discover a conflict with system+        -- attributes.+        [Expr.addColumn (Orville.fieldColumnDefinition fieldDef)]++{- |+  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+  cases.++@since 1.0.0.0+-}+mkDropColumnActions ::+  Orville.TableDefinition key readEntity writeEntity ->+  PgCatalog.PgAttribute ->+  [Expr.AlterTableAction]+mkDropColumnActions tableDef attr = do+  let+    attrName =+      PgCatalog.attributeNameToString $ PgCatalog.pgAttributeName attr++  guard $ Set.member attrName (Orville.columnsToDrop tableDef)++  [Expr.dropColumn $ Expr.columnName attrName]++{- |+  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+  always have schema names included with them.++@since 1.0.0.0+-}+setDefaultSchemaNameOnConstraintKey ::+  PgCatalog.NamespaceName ->+  Orville.ConstraintMigrationKey ->+  Orville.ConstraintMigrationKey+setDefaultSchemaNameOnConstraintKey currentNamespace constraintKey =+  case Orville.constraintKeyForeignTable constraintKey of+    Nothing ->+      constraintKey+    Just foreignTable ->+      case Orville.tableIdSchemaNameString foreignTable of+        Nothing ->+          constraintKey+            { Orville.constraintKeyForeignTable =+                Just $+                  Orville.setTableIdSchema+                    (PgCatalog.namespaceNameToString currentNamespace)+                    foreignTable+            }+        Just _ ->+          constraintKey++{- |+  Builds 'Expr.AlterTableAction' expressions to create the given table+  constraint if it does not exist.++@since 1.0.0.0+-}+mkAddConstraintActions ::+  PgCatalog.NamespaceName ->+  Set.Set Orville.ConstraintMigrationKey ->+  Orville.ConstraintDefinition ->+  [(StepType, Expr.AlterTableAction)]+mkAddConstraintActions currentNamespace existingConstraints constraintDef =+  let+    constraintKey =+      setDefaultSchemaNameOnConstraintKey currentNamespace $+        Orville.constraintMigrationKey constraintDef++    stepType =+      case Orville.constraintKeyType constraintKey of+        Orville.UniqueConstraint -> AddUniqueConstraints+        Orville.ForeignKeyConstraint -> AddForeignKeys+  in+    if Set.member constraintKey existingConstraints+      then []+      else [(stepType, Expr.addConstraint (Orville.constraintSqlExpr constraintDef))]++{- |+  Builds 'Expr.AlterTableAction' expressions to drop the given table+  constraint if it should not exist.++@since 1.0.0.0+-}+mkDropConstraintActions ::+  Set.Set Orville.ConstraintMigrationKey ->+  PgCatalog.ConstraintDescription ->+  [(StepType, Expr.AlterTableAction)]+mkDropConstraintActions constraintsToKeep constraint =+  case pgConstraintMigrationKey constraint of+    Nothing ->+      []+    Just constraintKey ->+      if Set.member constraintKey constraintsToKeep+        then []+        else+          let+            constraintName =+              Expr.constraintName+                . PgCatalog.constraintNameToString+                . PgCatalog.pgConstraintName+                . PgCatalog.constraintRecord+                $ constraint++            stepType =+              case Orville.constraintKeyType constraintKey of+                Orville.UniqueConstraint -> DropUniqueConstraints+                Orville.ForeignKeyConstraint -> DropForeignKeys+          in+            [(stepType, Expr.dropConstraint constraintName)]++{- |+  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+  definition before comparing them. See 'setDefaultSchemaNameOnConstraintKey'.++  If the description is for a kind of constraint that Orville does not support,+  'Nothing' is returned.++@since 1.0.0.0+-}+pgConstraintMigrationKey ::+  PgCatalog.ConstraintDescription ->+  Maybe Orville.ConstraintMigrationKey+pgConstraintMigrationKey constraintDesc =+  let+    toOrvilleConstraintKeyType pgConType =+      case pgConType of+        PgCatalog.UniqueConstraint -> Just Orville.UniqueConstraint+        PgCatalog.ForeignKeyConstraint -> Just Orville.ForeignKeyConstraint+        _ -> Nothing++    constraint =+      PgCatalog.constraintRecord constraintDesc++    pgAttributeNamesToFieldNames =+      map (Orville.stringToFieldName . PgCatalog.attributeNameToString . PgCatalog.pgAttributeName)++    foreignRelationTableId :: PgCatalog.ForeignRelationDescription -> Orville.TableIdentifier+    foreignRelationTableId foreignRelationDesc =+      let+        relationName =+          PgCatalog.relationNameToString+            . PgCatalog.pgClassRelationName+            . PgCatalog.foreignRelationClass+            $ foreignRelationDesc++        namespaceName =+          PgCatalog.namespaceNameToString+            . PgCatalog.pgNamespaceName+            . PgCatalog.foreignRelationNamespace+            $ foreignRelationDesc+      in+        Orville.setTableIdSchema namespaceName $+          Orville.unqualifiedNameToTableId relationName+  in+    do+      keyType <- toOrvilleConstraintKeyType (PgCatalog.pgConstraintType constraint)+      pure $+        Orville.ConstraintMigrationKey+          { Orville.constraintKeyType = keyType+          , Orville.constraintKeyColumns =+              fmap+                pgAttributeNamesToFieldNames+                (PgCatalog.constraintKey constraintDesc)+          , Orville.constraintKeyForeignTable =+              fmap foreignRelationTableId (PgCatalog.constraintForeignRelation constraintDesc)+          , Orville.constraintKeyForeignColumns =+              fmap+                pgAttributeNamesToFieldNames+                (PgCatalog.constraintForeignKey constraintDesc)+          , Orville.constraintKeyForeignKeyOnUpdateAction =+              PgCatalog.pgConstraintForeignKeyOnUpdateType $ PgCatalog.constraintRecord constraintDesc+          , Orville.constraintKeyForeignKeyOnDeleteAction =+              PgCatalog.pgConstraintForeignKeyOnDeleteType $ PgCatalog.constraintRecord constraintDesc+          }++{- |+  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 ->+  Orville.IndexDefinition ->+  [MigrationStepWithType]+mkAddIndexSteps existingIndexes tableName indexDef =+  let+    indexKey =+      IndexDefinition.indexMigrationKey indexDef++    indexStep =+      case Orville.indexCreationStrategy indexDef of+        Orville.Transactional -> AddIndexesTransactionally+        Orville.Concurrent -> AddIndexesConcurrently+  in+    if Set.member indexKey existingIndexes+      then []+      else [mkMigrationStepWithType indexStep (Orville.indexCreateExpr indexDef tableName)]++{- |+  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 ->+  PgCatalog.IndexDescription ->+  [MigrationStepWithType]+mkDropIndexSteps indexesToKeep systemIndexOids indexDesc =+  case pgIndexMigrationKeys indexDesc of+    [] ->+      []+    indexKeys ->+      let+        pgClass =+          PgCatalog.indexPgClass indexDesc++        indexName =+          Expr.indexName+            . PgCatalog.relationNameToString+            . PgCatalog.pgClassRelationName+            $ pgClass++        indexOid =+          PgCatalog.pgClassOid pgClass+      in+        if any (flip Set.member indexesToKeep) indexKeys+          || Set.member indexOid systemIndexOids+          then []+          else [mkMigrationStepWithType DropIndexes (Expr.dropIndexExpr indexName)]++{- |+  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.++  Foreign key constraints also have a supporting index OID in @pg_catalog@, but+  this index is not automatically created due to the constraint, so we don't+  return the index's OID for that case.++@since 1.0.0.0+-}+pgConstraintImpliedIndexOid :: PgCatalog.PgConstraint -> Maybe LibPQ.Oid+pgConstraintImpliedIndexOid pgConstraint =+  case PgCatalog.pgConstraintType pgConstraint of+    PgCatalog.PrimaryKeyConstraint ->+      Just $ PgCatalog.pgConstraintIndexOid pgConstraint+    PgCatalog.UniqueConstraint ->+      Just $ PgCatalog.pgConstraintIndexOid pgConstraint+    PgCatalog.ExclusionConstraint ->+      Just $ PgCatalog.pgConstraintIndexOid pgConstraint+    PgCatalog.CheckConstraint ->+      Nothing+    PgCatalog.ForeignKeyConstraint ->+      Nothing+    PgCatalog.ConstraintTrigger ->+      Nothing++{- |+  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+  simple attributes, 'Nothing' is returned.++@since 1.0.0.0+-}+pgIndexMigrationKeys ::+  PgCatalog.IndexDescription ->+  [IndexDefinition.IndexMigrationKey]+pgIndexMigrationKeys indexDesc =+  let+    mkNamedIndexKey =+      IndexDefinition.NamedIndexKey+        . PgCatalog.relationNameToString+        . PgCatalog.pgClassRelationName+        . PgCatalog.indexPgClass+        $ indexDesc+    mkAttributeBasedIndexKey =+      case pgAttributeBasedIndexMigrationKey indexDesc of+        Just standardKey ->+          [IndexDefinition.AttributeBasedIndexKey standardKey]+        Nothing ->+          []+  in+    [mkNamedIndexKey] ++ mkAttributeBasedIndexKey++pgAttributeBasedIndexMigrationKey ::+  PgCatalog.IndexDescription ->+  Maybe IndexDefinition.AttributeBasedIndexMigrationKey+pgAttributeBasedIndexMigrationKey indexDesc = do+  let+    indexMemberToFieldName member =+      case member of+        PgCatalog.IndexAttribute attr ->+          Just (Orville.stringToFieldName . PgCatalog.attributeNameToString . PgCatalog.pgAttributeName $ attr)+        PgCatalog.IndexExpression ->+          Nothing++    uniqueness =+      if PgCatalog.pgIndexIsUnique (PgCatalog.indexRecord indexDesc)+        then Orville.UniqueIndex+        else Orville.NonUniqueIndex++  fieldNames <- traverse indexMemberToFieldName (PgCatalog.indexMembers indexDesc)+  pure $+    IndexDefinition.AttributeBasedIndexMigrationKey+      { IndexDefinition.indexKeyUniqueness = uniqueness+      , IndexDefinition.indexKeyColumns = fieldNames+      }++schemaItemPgCatalogRelation ::+  PgCatalog.NamespaceName ->+  SchemaItem ->+  (PgCatalog.NamespaceName, PgCatalog.RelationName)+schemaItemPgCatalogRelation currentNamespace item =+  case item of+    SchemaTable tableDef ->+      tableIdToPgCatalogNames currentNamespace (Orville.tableIdentifier tableDef)+    SchemaDropTable tableId ->+      tableIdToPgCatalogNames currentNamespace tableId+    SchemaSequence sequenceDef ->+      sequenceIdToPgCatalogNames currentNamespace (Orville.sequenceIdentifier sequenceDef)+    SchemaDropSequence sequenceId ->+      sequenceIdToPgCatalogNames currentNamespace sequenceId++tableIdToPgCatalogNames ::+  PgCatalog.NamespaceName ->+  Orville.TableIdentifier ->+  (PgCatalog.NamespaceName, PgCatalog.RelationName)+tableIdToPgCatalogNames currentNamespace tableId =+  let+    actualNamespace =+      maybe currentNamespace String.fromString+        . Orville.tableIdSchemaNameString+        $ tableId++    relationName =+      String.fromString+        . Orville.tableIdUnqualifiedNameString+        $ tableId+  in+    (actualNamespace, relationName)++mkAlterSequenceSteps ::+  Orville.SequenceDefinition ->+  PgCatalog.PgSequence ->+  [MigrationStepWithType]+mkAlterSequenceSteps sequenceDef pgSequence =+  let+    ifChanged ::+      Eq a =>+      (a -> expr) ->+      (PgCatalog.PgSequence -> a) ->+      (Orville.SequenceDefinition -> a) ->+      Maybe expr+    ifChanged mkChange getOld getNew =+      if getOld pgSequence == getNew sequenceDef+        then Nothing+        else Just . mkChange . getNew $ sequenceDef++    mbIncrementByExpr =+      ifChanged Expr.incrementBy PgCatalog.pgSequenceIncrement Orville.sequenceIncrement++    mbMinValueExpr =+      ifChanged Expr.minValue PgCatalog.pgSequenceMin Orville.sequenceMinValue++    mbMaxValueExpr =+      ifChanged Expr.maxValue PgCatalog.pgSequenceMax Orville.sequenceMaxValue++    mbStartWithExpr =+      ifChanged Expr.startWith PgCatalog.pgSequenceStart Orville.sequenceStart++    mbCacheExpr =+      ifChanged Expr.cache PgCatalog.pgSequenceCache Orville.sequenceCache++    mbCycleExpr =+      ifChanged Expr.cycleIfTrue PgCatalog.pgSequenceCycle Orville.sequenceCycle++    applyChange :: (Bool, Maybe a -> b) -> Maybe a -> (Bool, b)+    applyChange (changed, exprF) mbArg =+      (changed || Maybe.isJust mbArg, exprF mbArg)++    (anyChanges, migrateSequenceExpr) =+      (False, Expr.alterSequenceExpr (Orville.sequenceName sequenceDef))+        `applyChange` mbIncrementByExpr+        `applyChange` mbMinValueExpr+        `applyChange` mbMaxValueExpr+        `applyChange` mbStartWithExpr+        `applyChange` mbCacheExpr+        `applyChange` mbCycleExpr+  in+    if anyChanges+      then [mkMigrationStepWithType AddRemoveTablesAndColumns migrateSequenceExpr]+      else []++sequenceIdToPgCatalogNames ::+  PgCatalog.NamespaceName ->+  Orville.SequenceIdentifier ->+  (PgCatalog.NamespaceName, PgCatalog.RelationName)+sequenceIdToPgCatalogNames currentNamespace sequenceId =+  let+    actualNamespace =+      maybe currentNamespace String.fromString+        . Orville.sequenceIdSchemaNameString+        $ sequenceId++    relationName =+      String.fromString+        . Orville.sequenceIdUnqualifiedNameString+        $ sequenceId+  in+    (actualNamespace, relationName)++currentNamespaceQuery :: Expr.QueryExpr+currentNamespaceQuery =+  Expr.queryExpr+    (Expr.selectClause (Expr.selectExpr Nothing))+    ( Expr.selectDerivedColumns+        [ Expr.deriveColumnAs+            -- current_schema is a special reserved word in postgresql. If you+            -- 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)+        ]+    )+    Nothing++findCurrentNamespace :: Orville.MonadOrville m => m PgCatalog.NamespaceName+findCurrentNamespace = do+  results <-+    Orville.executeAndDecode+      Orville.SelectQuery+      currentNamespaceQuery+      (Orville.annotateSqlMarshallerEmptyAnnotation $ Orville.marshallField id PgCatalog.namespaceNameField)++  liftIO $+    case results of+      [schemaAndCatalog] ->+        pure schemaAndCatalog+      [] ->+        throwIO $ UnableToDiscoverCurrentSchema "No results returned by current_schema query"+      _ ->+        throwIO $ UnableToDiscoverCurrentSchema "Multiple results returned by current_schema query"
+ src/Orville/PostgreSQL/ErrorDetailLevel.hs view
@@ -0,0 +1,142 @@+{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.ErrorDetailLevel+  ( ErrorDetailLevel (ErrorDetailLevel, includeErrorMessage, includeSchemaNames, includeRowIdentifierValues, includeNonIdentifierValues)+  , defaultErrorDetailLevel+  , minimalErrorDetailLevel+  , maximalErrorDetailLevel+  , redactErrorMessage+  , redactSchemaName+  , redactIdentifierValue+  , redactNonIdentifierValue+  )+where++{- |+  '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+  desired detail level in the @OrvilleState@ as a default.++  Information will be redacted from error messages for any of the fields+  that are set to @False@.++@since 1.0.0.0+-}+data ErrorDetailLevel = ErrorDetailLevel+  { includeErrorMessage :: Bool+  , includeSchemaNames :: Bool+  , includeRowIdentifierValues :: Bool+  , includeNonIdentifierValues :: Bool+  }+  deriving+    ( -- | @since 1.0.0.0+      Show+    )++{- |+  A minimal 'ErrorDetailLevel' where all information (including any+  situationally-specific error messages!) is redacted from error messages.++@since 1.0.0.0+-}+minimalErrorDetailLevel :: ErrorDetailLevel+minimalErrorDetailLevel =+  ErrorDetailLevel+    { includeErrorMessage = False+    , includeSchemaNames = False+    , includeRowIdentifierValues = False+    , includeNonIdentifierValues = False+    }++{- |+  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.++@since 1.0.0.0+-}+defaultErrorDetailLevel :: ErrorDetailLevel+defaultErrorDetailLevel =+  ErrorDetailLevel+    { includeErrorMessage = True+    , includeSchemaNames = True+    , includeRowIdentifierValues = True+    , includeNonIdentifierValues = False+    }++{- |+  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.++@since 1.0.0.0+-}+maximalErrorDetailLevel :: ErrorDetailLevel+maximalErrorDetailLevel =+  ErrorDetailLevel+    { includeErrorMessage = True+    , includeSchemaNames = True+    , includeRowIdentifierValues = True+    , includeNonIdentifierValues = True+    }++{- |+  Redacts given the error message string if the 'ErrorDetailLevel' indicates+  that error messages should be redacted.++@since 1.0.0.0+-}+redactErrorMessage :: ErrorDetailLevel -> String -> String+redactErrorMessage detailLevel message =+  if includeErrorMessage detailLevel+    then message+    else redactedValue++{- |+  Redacts given the schema name string if the 'ErrorDetailLevel' indicates+  that schema names should be redacted.++@since 1.0.0.0+-}+redactSchemaName :: ErrorDetailLevel -> String -> String+redactSchemaName detailLevel schemaName =+  if includeSchemaNames detailLevel+    then schemaName+    else redactedValue++{- |+  Redacts given the identifier value string if the 'ErrorDetailLevel' indicates+  that identifier values should be redacted.++@since 1.0.0.0+-}+redactIdentifierValue :: ErrorDetailLevel -> String -> String+redactIdentifierValue detailLevel idValue =+  if includeRowIdentifierValues detailLevel+    then idValue+    else redactedValue++{- |+  Redacts given the non-identifier value string if the 'ErrorDetailLevel' indicates+  that non-identifier values should be redacted.++@since 1.0.0.0+-}+redactNonIdentifierValue :: ErrorDetailLevel -> String -> String+redactNonIdentifierValue detailLevel nonIdValue =+  if includeNonIdentifierValues detailLevel+    then nonIdValue+    else redactedValue++redactedValue :: String+redactedValue =+  "[REDACTED]"
+ src/Orville/PostgreSQL/Execution.hs view
@@ -0,0 +1,53 @@+{-# OPTIONS_GHC -Wno-missing-import-lists #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++You can import "Orville.PostgreSQL.Execution" to get access to all the+execution-related functions and types exported by the modules below. This+includes a number of lower-level items not exported by "Orville.PostgreSQL"+that give you more control (and therefore responsibility) over how the SQL is+executed.++@since 1.0.0.0+-}+module Orville.PostgreSQL.Execution+  ( -- * High-level modules for most common tasks+      module Orville.PostgreSQL.Execution.EntityOperations+  , module Orville.PostgreSQL.Execution.SelectOptions+  , module Orville.PostgreSQL.Execution.Sequence+  , module Orville.PostgreSQL.Execution.Transaction++    -- * Mid-level modules with more flexibility for handling less common queries+  , module Orville.PostgreSQL.Execution.Select+  , module Orville.PostgreSQL.Execution.Insert+  , module Orville.PostgreSQL.Execution.Update+  , module Orville.PostgreSQL.Execution.Delete+  , module Orville.PostgreSQL.Execution.Cursor+  , module Orville.PostgreSQL.Execution.ReturningOption++    -- * Low-level modules for executing and decoding SQL expressions yourself+  , module Orville.PostgreSQL.Execution.Execute+  , module Orville.PostgreSQL.Execution.ExecutionResult+  , module Orville.PostgreSQL.Execution.QueryType+  )+where++-- Note: we list the re-exports explicity above to control the order that they+-- appear in the generated haddock documentation.++import Orville.PostgreSQL.Execution.Cursor+import Orville.PostgreSQL.Execution.Delete+import Orville.PostgreSQL.Execution.EntityOperations+import Orville.PostgreSQL.Execution.Execute+import Orville.PostgreSQL.Execution.ExecutionResult+import Orville.PostgreSQL.Execution.Insert+import Orville.PostgreSQL.Execution.QueryType+import Orville.PostgreSQL.Execution.ReturningOption+import Orville.PostgreSQL.Execution.Select+import Orville.PostgreSQL.Execution.SelectOptions+import Orville.PostgreSQL.Execution.Sequence+import Orville.PostgreSQL.Execution.Transaction+import Orville.PostgreSQL.Execution.Update
+ src/Orville/PostgreSQL/Execution/Cursor.hs view
@@ -0,0 +1,203 @@+{-# LANGUAGE GADTs #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++Functions and types for working with PostgreSQL cursors. You can use cursors to+execute a query and consume rows from the result set incrementally. Rows that+you do not consume will never be sent from the database to the client.++@since 1.0.0.0+-}+module Orville.PostgreSQL.Execution.Cursor+  ( Cursor+  , withCursor+  , declareCursor+  , closeCursor+  , fetch+  , move+  , Expr.CursorDirection+  , Expr.next+  , Expr.prior+  , Expr.first+  , Expr.last+  , Expr.absolute+  , Expr.relative+  , Expr.count+  , Expr.fetchAll+  , Expr.forward+  , Expr.forwardCount+  , Expr.forwardAll+  , Expr.backward+  , Expr.backwardCount+  , Expr.backwardAll+  )+where++import Control.Monad.IO.Class (MonadIO (liftIO))+import qualified Data.Time as Time+import qualified Data.Time.Clock.POSIX as POSIXTime+import qualified Data.Word as Word+import qualified System.Random as Random+import qualified Text.Printf as Printf++import qualified Orville.PostgreSQL.Execution.Execute as Execute+import qualified Orville.PostgreSQL.Execution.QueryType as QueryType+import Orville.PostgreSQL.Execution.Select (Select, useSelect)+import qualified Orville.PostgreSQL.Expr as Expr+import qualified Orville.PostgreSQL.Internal.Bracket as Bracket+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 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.++  See 'withCursor', 'fetch' and 'move' for details on creating and using+  'Cursor' values.++@since 1.0.0.0+-}+data Cursor readEntity where+  Cursor ::+    AnnotatedSqlMarshaller writeEntity readEntity ->+    Expr.CursorName ->+    Cursor readEntity++{- |+  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).++  See @https://www.postgresql.org/docs/current/sql-declare.html@ for details+  about the 'Expr.ScrollExpr' and 'Expr.HoldExpr' parameters and how cursors+  behave in general.++  We recommend you use this instead of 'declareCursor' and 'closeCursor'+  unless you need to control the cursor resource acquisition and release+  yourself and can do so safely.++@since 1.0.0.0+-}+withCursor ::+  Monad.MonadOrville m =>+  Maybe Expr.ScrollExpr ->+  Maybe Expr.HoldExpr ->+  Select readEntity ->+  (Cursor readEntity -> m a) ->+  m a+withCursor scrollExpr holdExpr select useCursor =+  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+  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.++  See @https://www.postgresql.org/docs/current/sql-declare.html@ for details+  about the 'Expr.ScrollExpr' and 'Expr.HoldExpr' parameters and how cursors+  behave in general.++@since 1.0.0.0+-}+declareCursor ::+  Monad.MonadOrville m =>+  Maybe Expr.ScrollExpr ->+  Maybe Expr.HoldExpr ->+  Select readEntity ->+  m (Cursor readEntity)+declareCursor scrollExpr holdExpr =+  useSelect $ \queryExpr marshaller -> do+    cursorName <- newCursorName++    let+      declareExpr =+        Expr.declare cursorName scrollExpr holdExpr queryExpr++    _ <- Execute.executeVoid QueryType.CursorQuery declareExpr+    pure (Cursor marshaller cursorName)++{- |+  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.++@since 1.0.0.0+-}+closeCursor ::+  Monad.MonadOrville m =>+  Cursor readEntity ->+  m ()+closeCursor (Cursor _ cursorName) =+  Execute.executeVoid QueryType.CursorQuery+    . Expr.close+    . Right+    $ cursorName++{- |+  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.++@since 1.0.0.0+-}+fetch ::+  Monad.MonadOrville m =>+  Maybe Expr.CursorDirection ->+  Cursor readEntity ->+  m [readEntity]+fetch direction (Cursor marshaller cursorName) =+  Execute.executeAndDecode+    QueryType.CursorQuery+    (Expr.fetch direction cursorName)+    marshaller++{- |+  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.++@since 1.0.0.0+-}+move ::+  Monad.MonadOrville m =>+  Maybe Expr.CursorDirection ->+  Cursor readEntity ->+  m ()+move direction (Cursor _ cursorName) =+  Execute.executeVoid+    QueryType.CursorQuery+    (Expr.move direction cursorName)++{- |+  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.++@since 1.0.0.0+-}+newCursorName :: MonadIO m => m Expr.CursorName+newCursorName =+  liftIO $ do+    now <- POSIXTime.getPOSIXTime+    randomWord <- Random.randomIO++    let+      nowAsInteger =+        fromEnum . Time.nominalDiffTimeToSeconds $ now++    pure . Expr.cursorName $+      Printf.printf+        "orville_cursor_%x_%08x"+        nowAsInteger+        (randomWord :: Word.Word32)
+ src/Orville/PostgreSQL/Execution/Delete.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE GADTs #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++Functions for working with executable @DELETE@ statements. The 'Delete' type is+a value that can be passed around and executed later. The 'Delete' is directly+associated with the presence of a returning clause and how to decode any rows+returned by that clause. This means it can be safely executed via+'executeDelete' or 'executeDeleteReturnEntities' as appropriate. It is a lower-level+API than the entity delete functions in+"Orville.PostgreSQL.Execution.EntityOperations", but not as primitive as+"Orville.PostgreSQL.Expr.Delete".++@since 1.0.0.0+-}+module Orville.PostgreSQL.Execution.Delete+  ( Delete+  , deleteFromDeleteExpr+  , executeDelete+  , executeDeleteReturnEntities+  , deleteFromTableReturning+  , deleteFromTable+  , rawDeleteExpr+  )+where++import qualified Orville.PostgreSQL.Execution.Execute as Execute+import qualified Orville.PostgreSQL.Execution.QueryType as QueryType+import Orville.PostgreSQL.Execution.ReturningOption (NoReturningClause, ReturningClause, ReturningOption (WithReturning, WithoutReturning))+import qualified Orville.PostgreSQL.Expr as Expr+import Orville.PostgreSQL.Marshall.SqlMarshaller (AnnotatedSqlMarshaller)+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+'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.++@since 1.0.0.0+-}+data Delete readEntity returningClause where+  Delete ::+    Expr.DeleteExpr ->+    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+  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.++@since 1.0.0.0+-}+deleteFromDeleteExpr :: Delete readEntity returningClause -> Expr.DeleteExpr+deleteFromDeleteExpr (Delete expr) = expr+deleteFromDeleteExpr (DeleteReturning _ expr) = expr++{- |+  Executes the database query for the 'Delete' and returns the number of+  rows affected by the query.++@since 1.0.0.0+-}+executeDelete ::+  Monad.MonadOrville m =>+  Delete readEntity NoReturningClause ->+  m Int+executeDelete (Delete expr) =+  Execute.executeAndReturnAffectedRows QueryType.DeleteQuery expr++{- |+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.++@since 1.0.0.0+-}+executeDeleteReturnEntities ::+  Monad.MonadOrville m =>+  Delete readEntity ReturningClause ->+  m [readEntity]+executeDeleteReturnEntities (DeleteReturning marshaller expr) =+  Execute.executeAndDecode QueryType.DeleteQuery expr marshaller++{- |+  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+-}+deleteFromTable ::+  TableDefinition key writeEntity readEntity ->+  Maybe Expr.BooleanExpr ->+  Delete readEntity NoReturningClause+deleteFromTable =+  deleteTable WithoutReturning++{- |+  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.++@since 1.0.0.0+-}+deleteFromTableReturning ::+  TableDefinition key writeEntity readEntity ->+  Maybe Expr.BooleanExpr ->+  Delete readEntity ReturningClause+deleteFromTableReturning =+  deleteTable WithReturning++-- an internal helper function for creating a delete with a given `ReturningOption`+deleteTable ::+  ReturningOption returningClause ->+  TableDefinition key writeEntity readEntity ->+  Maybe Expr.BooleanExpr ->+  Delete readEntity returningClause+deleteTable returningOption tableDef whereCondition =+  let+    deleteExpr =+      Expr.deleteExpr+        (tableName tableDef)+        (fmap Expr.whereClause whereCondition)+        (mkTableReturningClause returningOption tableDef)+  in+    rawDeleteExpr returningOption (tableMarshaller tableDef) deleteExpr++{- |+  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.++  This is the lowest level of escape hatch available for 'Delete'. The caller can build any query+  that Orville supports using the expression-building functions, or use @RawSql.fromRawSql@ to build+  a raw 'Expr.DeleteExpr'. It is expected that the 'ReturningOption' given matches the+  'Expr.DeleteExpr'. This level of interface does not provide an automatic enforcement of the+  expectation, however failure is likely if that is not met.++@since 1.0.0.0+-}+rawDeleteExpr :: ReturningOption returningClause -> AnnotatedSqlMarshaller writeEntity readEntity -> Expr.DeleteExpr -> Delete readEntity returningClause+rawDeleteExpr WithReturning marshaller = DeleteReturning marshaller+rawDeleteExpr WithoutReturning _ = Delete
+ src/Orville/PostgreSQL/Execution/EntityOperations.hs view
@@ -0,0 +1,444 @@+{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++Entry-level functions for executing based CRUD operations on entity tables.+These are the functions that you will use most often for interacting with+tables.++@since 1.0.0.0+-}+module Orville.PostgreSQL.Execution.EntityOperations+  ( insertEntity+  , insertEntityAndReturnRowCount+  , insertAndReturnEntity+  , insertEntities+  , insertAndReturnEntities+  , insertEntitiesAndReturnRowCount+  , updateEntity+  , updateEntityAndReturnRowCount+  , updateAndReturnEntity+  , updateFields+  , updateFieldsAndReturnEntities+  , updateFieldsAndReturnRowCount+  , deleteEntity+  , deleteEntityAndReturnRowCount+  , deleteAndReturnEntity+  , deleteEntities+  , deleteEntitiesAndReturnRowCount+  , deleteAndReturnEntities+  , findEntitiesBy+  , findFirstEntityBy+  , findEntity+  , findEntities+  )+where++import Control.Exception (Exception, throwIO)+import qualified Control.Monad as Monad+import Control.Monad.IO.Class (MonadIO (liftIO))+import Data.List.NonEmpty (NonEmpty ((:|)))+import Data.Maybe (listToMaybe)++import qualified Orville.PostgreSQL.Execution.Delete as Delete+import qualified Orville.PostgreSQL.Execution.Insert as Insert+import qualified Orville.PostgreSQL.Execution.Select as Select+import qualified Orville.PostgreSQL.Execution.SelectOptions as SelectOptions+import qualified Orville.PostgreSQL.Execution.Update as Update+import qualified Orville.PostgreSQL.Expr as Expr+import qualified Orville.PostgreSQL.Internal.RowCountExpectation as RowCountExpectation+import qualified Orville.PostgreSQL.Monad as Monad+import qualified Orville.PostgreSQL.Schema as Schema++{- |+  Inserts an entity into the specified table.++@since 1.0.0.0+-}+insertEntity ::+  Monad.MonadOrville m =>+  Schema.TableDefinition key writeEntity readEntity ->+  writeEntity ->+  m ()+insertEntity entityTable =+  Monad.void . insertEntityAndReturnRowCount entityTable++{- |+  Inserts an entity into the specified table. Returns the number of rows+  affected by the query.++@since 1.0.0.0+-}+insertEntityAndReturnRowCount ::+  Monad.MonadOrville m =>+  Schema.TableDefinition key writeEntity readEntity ->+  writeEntity ->+  m Int+insertEntityAndReturnRowCount entityTable entity =+  insertEntitiesAndReturnRowCount entityTable (entity :| [])++{- |+  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+  database, such as auto-incrementing ids.++@since 1.0.0.0+-}+insertAndReturnEntity ::+  Monad.MonadOrville m =>+  Schema.TableDefinition key writeEntity readEntity ->+  writeEntity ->+  m readEntity+insertAndReturnEntity entityTable entity = do+  returnedEntities <- insertAndReturnEntities entityTable (entity :| [])++  RowCountExpectation.expectExactlyOneRow+    "insertAndReturnEntity RETURNING clause"+    returnedEntities++{- |+  Inserts a non-empty list of entities into the specified table.++@since 1.0.0.0+-}+insertEntities ::+  Monad.MonadOrville m =>+  Schema.TableDefinition key writeEntity readEntity ->+  NonEmpty writeEntity ->+  m ()+insertEntities tableDef =+  Monad.void . insertEntitiesAndReturnRowCount tableDef++{- |+  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+-}+insertEntitiesAndReturnRowCount ::+  Monad.MonadOrville m =>+  Schema.TableDefinition key writeEntity readEntity ->+  NonEmpty writeEntity ->+  m Int+insertEntitiesAndReturnRowCount tableDef =+  Insert.executeInsert . Insert.insertToTable tableDef++{- |+  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+  database, such as auto-incrementing ids.++@since 1.0.0.0+-}+insertAndReturnEntities ::+  Monad.MonadOrville m =>+  Schema.TableDefinition key writeEntity readEntity ->+  NonEmpty writeEntity ->+  m [readEntity]+insertAndReturnEntities tableDef =+  Insert.executeInsertReturnEntities . Insert.insertToTableReturning tableDef++{- |+  Updates the row with the given key with the data given by @writeEntity@.++@since 1.0.0.0+-}+updateEntity ::+  Monad.MonadOrville m =>+  Schema.TableDefinition (Schema.HasKey key) writeEntity readEntity ->+  key ->+  writeEntity ->+  m ()+updateEntity tableDef key =+  Monad.void . updateEntityAndReturnRowCount tableDef key++{- |+  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+-}+updateEntityAndReturnRowCount ::+  Monad.MonadOrville m =>+  Schema.TableDefinition (Schema.HasKey key) writeEntity readEntity ->+  key ->+  writeEntity ->+  m Int+updateEntityAndReturnRowCount tableDef key writeEntity =+  case Update.updateToTable tableDef key writeEntity of+    Nothing ->+      liftIO . throwIO . EmptyUpdateError . Schema.tableIdentifier $ tableDef+    Just update ->+      Update.executeUpdate update++{- |+  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.++  You can use this function to obtain any column values computed by the database+  during the update, including columns with triggers attached to them.++@since 1.0.0.0+-}+updateAndReturnEntity ::+  Monad.MonadOrville m =>+  Schema.TableDefinition (Schema.HasKey key) writeEntity readEntity ->+  key ->+  writeEntity ->+  m (Maybe readEntity)+updateAndReturnEntity tableDef key writeEntity =+  case Update.updateToTableReturning tableDef key writeEntity of+    Nothing ->+      liftIO . throwIO . EmptyUpdateError . Schema.tableIdentifier $ tableDef+    Just update -> do+      returnedEntities <- Update.executeUpdateReturnEntities update+      RowCountExpectation.expectAtMostOneRow+        "updateAndReturnEntity RETURNING clause"+        returnedEntities++{- |+  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 @.:=@).++@since 1.0.0.0+-}+updateFields ::+  Monad.MonadOrville m =>+  Schema.TableDefinition (Schema.HasKey key) writeEntity readEntity ->+  NonEmpty Expr.SetClause ->+  Maybe Expr.BooleanExpr ->+  m ()+updateFields tableDef setClauses =+  Monad.void . updateFieldsAndReturnRowCount tableDef setClauses++{- |+  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.++@since 1.0.0.0+-}+updateFieldsAndReturnRowCount ::+  Monad.MonadOrville m =>+  Schema.TableDefinition (Schema.HasKey key) writeEntity readEntity ->+  NonEmpty Expr.SetClause ->+  Maybe Expr.BooleanExpr ->+  m Int+updateFieldsAndReturnRowCount tableDef setClauses mbWhereCondition =+  Update.executeUpdate $+    Update.updateToTableFields tableDef setClauses mbWhereCondition++{- |+  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+-}+updateFieldsAndReturnEntities ::+  Monad.MonadOrville m =>+  Schema.TableDefinition (Schema.HasKey key) writeEntity readEntity ->+  NonEmpty Expr.SetClause ->+  Maybe Expr.BooleanExpr ->+  m [readEntity]+updateFieldsAndReturnEntities tableDef setClauses mbWhereCondition =+  Update.executeUpdateReturnEntities $+    Update.updateToTableFieldsReturning tableDef setClauses mbWhereCondition++{- |+  Deletes the row with the given key.++@since 1.0.0.0+-}+deleteEntity ::+  Monad.MonadOrville m =>+  Schema.TableDefinition (Schema.HasKey key) writeEntity readEntity ->+  key ->+  m ()+deleteEntity entityTable =+  Monad.void . deleteEntityAndReturnRowCount entityTable++{- |+  Deletes the row with the given key. Returns the number of rows affected+  by the query.++@since 1.0.0.0+-}+deleteEntityAndReturnRowCount ::+  Monad.MonadOrville m =>+  Schema.TableDefinition (Schema.HasKey key) writeEntity readEntity ->+  key ->+  m Int+deleteEntityAndReturnRowCount entityTable key =+  let+    primaryKeyCondition =+      Schema.primaryKeyEquals+        (Schema.tablePrimaryKey entityTable)+        key+  in+    Delete.executeDelete $+      Delete.deleteFromTable entityTable (Just primaryKeyCondition)++{- |+  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+-}+deleteAndReturnEntity ::+  Monad.MonadOrville m =>+  Schema.TableDefinition (Schema.HasKey key) writeEntity readEntity ->+  key ->+  m (Maybe readEntity)+deleteAndReturnEntity entityTable key = do+  let+    primaryKeyCondition =+      Schema.primaryKeyEquals+        (Schema.tablePrimaryKey entityTable)+        key++  returnedEntities <- deleteAndReturnEntities entityTable (Just primaryKeyCondition)++  RowCountExpectation.expectAtMostOneRow+    "deleteAndReturnEntity RETURNING clause"+    returnedEntities++{- |+  Deletes all rows in the given table that match the where condition.++@since 1.0.0.0+-}+deleteEntities ::+  Monad.MonadOrville m =>+  Schema.TableDefinition key writeEntity readEntity ->+  Maybe Expr.BooleanExpr ->+  m ()+deleteEntities entityTable =+  Monad.void . deleteEntitiesAndReturnRowCount entityTable++{- |+  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+-}+deleteEntitiesAndReturnRowCount ::+  Monad.MonadOrville m =>+  Schema.TableDefinition key writeEntity readEntity ->+  Maybe Expr.BooleanExpr ->+  m Int+deleteEntitiesAndReturnRowCount entityTable whereCondition =+  Delete.executeDelete $+    Delete.deleteFromTable entityTable whereCondition++{- |+  Deletes all rows in the given table that match the where condition, returning+  the rows that were deleted.++@since 1.0.0.0+-}+deleteAndReturnEntities ::+  Monad.MonadOrville m =>+  Schema.TableDefinition key writeEntity readEntity ->+  Maybe Expr.BooleanExpr ->+  m [readEntity]+deleteAndReturnEntities entityTable whereCondition =+  Delete.executeDeleteReturnEntities $+    Delete.deleteFromTableReturning entityTable whereCondition++{- |+  Finds all the entities in the given table according to the specified+  'SelectOptions.SelectOptions', which may include where conditions to+  match, ordering specifications, etc.++@since 1.0.0.0+-}+findEntitiesBy ::+  Monad.MonadOrville m =>+  Schema.TableDefinition key writeEntity readEntity ->+  SelectOptions.SelectOptions ->+  m [readEntity]+findEntitiesBy entityTable selectOptions =+  Select.executeSelect $+    Select.selectTable entityTable selectOptions++{- |+  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.++@since 1.0.0.0+-}+findFirstEntityBy ::+  Monad.MonadOrville m =>+  Schema.TableDefinition key writeEntity readEntity ->+  SelectOptions.SelectOptions ->+  m (Maybe readEntity)+findFirstEntityBy entityTable selectOptions =+  listToMaybe+    <$> findEntitiesBy entityTable (SelectOptions.limit 1 <> selectOptions)++{- |+  Finds a single entity by the table's primary key value.++@since 1.0.0.0+-}+findEntity ::+  Monad.MonadOrville m =>+  Schema.TableDefinition (Schema.HasKey key) writeEntity readEntity ->+  key ->+  m (Maybe readEntity)+findEntity entityTable key =+  let+    primaryKeyCondition =+      Schema.primaryKeyEquals+        (Schema.tablePrimaryKey entityTable)+        key+  in+    findFirstEntityBy entityTable (SelectOptions.where_ primaryKeyCondition)++{- |+  Finds multiple entities by the table's primary key.++@since 1.0.0.0+-}+findEntities ::+  Monad.MonadOrville m =>+  Schema.TableDefinition (Schema.HasKey key) writeEntity readEntity ->+  NonEmpty key ->+  m [readEntity]+findEntities entityTable keys =+  let+    primaryKeyCondition =+      Schema.primaryKeyIn+        (Schema.tablePrimaryKey entityTable)+        keys+  in+    findEntitiesBy entityTable (SelectOptions.where_ primaryKeyCondition)++{- |+  Thrown by 'updateFields' and 'updateFieldsAndReturnEntities' if the+  'Schema.TableDefinition' they are given has no columns to update.++@since 1.0.0.0+-}+newtype EmptyUpdateError+  = EmptyUpdateError Schema.TableIdentifier++-- | @since 1.0.0.0+instance Show EmptyUpdateError where+  show (EmptyUpdateError tableId) =+    "EmptyUdateError: "+      <> Schema.tableIdToString tableId+      <> " has no columns to update."++-- | @since 1.0.0.0+instance Exception EmptyUpdateError
+ src/Orville/PostgreSQL/Execution/Execute.hs view
@@ -0,0 +1,224 @@+{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++Low-level functions for executing 'RawSql.SqlExpression' values directly.++@since 1.0.0.0+-}+module Orville.PostgreSQL.Execution.Execute+  ( executeAndDecode+  , executeAndReturnAffectedRows+  , executeVoid+  , executeAndDecodeIO+  , executeAndReturnAffectedRowsIO+  , executeVoidIO+  , AffectedRowsDecodingError+  )+where++import Control.Exception (Exception, throwIO)+import Control.Monad (void)+import Control.Monad.IO.Class (liftIO)+import qualified Database.PostgreSQL.LibPQ as LibPQ++import Orville.PostgreSQL.Execution.QueryType (QueryType)+import qualified Orville.PostgreSQL.Marshall.SqlMarshaller as SqlMarshaller+import Orville.PostgreSQL.Monad (MonadOrville, askOrvilleState, withConnection)+import Orville.PostgreSQL.OrvilleState (OrvilleState, orvilleErrorDetailLevel, orvilleSqlCommenterAttributes, orvilleSqlExecutionCallback)+import Orville.PostgreSQL.Raw.Connection (Connection)+import qualified Orville.PostgreSQL.Raw.RawSql as RawSql+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+  marshaller. Any SQL Execution callbacks that have been added to the+  'OrvilleState' will be called.++  If the query fails or if any row is unable to be decoded by the marshaller,+  an exception will be raised.++@since 1.0.0.0+-}+executeAndDecode ::+  (MonadOrville m, RawSql.SqlExpression sql) =>+  QueryType ->+  sql ->+  SqlMarshaller.AnnotatedSqlMarshaller writeEntity readEntity ->+  m [readEntity]+executeAndDecode queryType sql marshaller = do+  orvilleState <- askOrvilleState+  withConnection (liftIO . executeAndDecodeIO queryType sql marshaller orvilleState)++{- |+  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.++  This function can only be used for the execution of a SELECT, CREATE+  TABLE AS, INSERT, UPDATE, DELETE, MOVE, FETCH, or COPY statement, or an+  EXECUTE of a prepared query that contains an INSERT, UPDATE, or DELETE+  statement. If the query is anything else, an 'AffectedRowsDecodingError'+  wil be raised after the query is executed when the result is read.++  If the query fails, an exception will be raised.++@since 1.0.0.0+-}+executeAndReturnAffectedRows ::+  (MonadOrville m, RawSql.SqlExpression sql) =>+  QueryType ->+  sql ->+  m Int+executeAndReturnAffectedRows queryType sql = do+  orvilleState <- askOrvilleState+  withConnection (liftIO . executeAndReturnAffectedRowsIO queryType sql orvilleState)++{- |+  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.++@since 1.0.0.0+-}+executeVoid ::+  (MonadOrville m, RawSql.SqlExpression sql) =>+  QueryType ->+  sql ->+  m ()+executeVoid queryType sql = do+  orvilleState <- askOrvilleState+  withConnection (liftIO . executeVoidIO queryType sql orvilleState)++{- |+  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.++  If the query fails or if any row is unable to be decoded by the marshaller,+  an exception will be raised.++@since 1.0.0.0+-}+executeAndDecodeIO ::+  RawSql.SqlExpression sql =>+  QueryType ->+  sql ->+  SqlMarshaller.AnnotatedSqlMarshaller writeEntity readEntity ->+  OrvilleState ->+  Connection ->+  IO [readEntity]+executeAndDecodeIO queryType sql marshaller orvilleState conn = do+  libPqResult <- executeWithCallbacksIO queryType sql orvilleState conn++  let+    errorDetailLevel = orvilleErrorDetailLevel orvilleState++  decodingResult <-+    SqlMarshaller.marshallResultFromSql+      errorDetailLevel+      marshaller+      libPqResult++  case decodingResult of+    Left err ->+      throwIO err+    Right entities ->+      pure entities++{- |+  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.++  This function can only be used for the execution of a SELECT, CREATE+  TABLE AS, INSERT, UPDATE, DELETE, MOVE, FETCH, or COPY statement, or an+  EXECUTE of a prepared query that contains an INSERT, UPDATE, or DELETE+  statement. If the query is anything else, an 'AffectedRowsDecodingError'+  wil be raised after the query is executed when the result is read.++  If the query fails, an exception will be raised.++@since 1.0.0.0+-}+executeAndReturnAffectedRowsIO ::+  RawSql.SqlExpression sql =>+  QueryType ->+  sql ->+  OrvilleState ->+  Connection ->+  IO Int+executeAndReturnAffectedRowsIO queryType sql orvilleState conn = do+  libPqResult <- executeWithCallbacksIO queryType sql orvilleState conn+  mbTupleCount <- LibPQ.cmdTuples libPqResult+  case mbTupleCount of+    Nothing ->+      throwIO+        . AffectedRowsDecodingError+        $ "No affected row count was produced by the query"+    Just bs ->+      case SqlValue.toInt (SqlValue.fromRawBytes bs) of+        Left err ->+          throwIO . AffectedRowsDecodingError $ err+        Right n ->+          pure n++{- |+  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.++@since 1.0.0.0+-}+executeVoidIO ::+  RawSql.SqlExpression sql =>+  QueryType ->+  sql ->+  OrvilleState ->+  Connection ->+  IO ()+executeVoidIO queryType sql orvilleState =+  void . executeWithCallbacksIO queryType sql orvilleState++executeWithCallbacksIO ::+  RawSql.SqlExpression sql =>+  QueryType ->+  sql ->+  OrvilleState ->+  Connection ->+  IO LibPQ.Result+executeWithCallbacksIO queryType sql orvilleState conn =+  let+    rawSql =+      case orvilleSqlCommenterAttributes orvilleState of+        Nothing ->+          RawSql.toRawSql sql+        Just sqlCommenterAttributes ->+          SqlCommenter.addSqlCommenterAttributes sqlCommenterAttributes $ RawSql.toRawSql sql+  in+    orvilleSqlExecutionCallback+      orvilleState+      queryType+      rawSql+      (RawSql.execute conn rawSql)++{- |+  Thrown by 'executeAndReturnAffectedRows' and 'executeAndReturnAffectedRowsIO'+  if the number of affected rows cannot be successfully read from the LibPQ+  command result.++@since 1.0.0.0+-}+newtype AffectedRowsDecodingError+  = AffectedRowsDecodingError String+  deriving+    ( -- | @since 1.0.0.0+      Show+    )++-- | @since 1.0.0.0+instance Exception AffectedRowsDecodingError
+ src/Orville/PostgreSQL/Execution/ExecutionResult.hs view
@@ -0,0 +1,220 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Execution.ExecutionResult+  ( ExecutionResult (..)+  , Column (..)+  , Row (..)+  , readRows+  , FakeLibPQResult+  , mkFakeLibPQResult+  )+where++import qualified Data.ByteString as BS+import qualified Data.Map.Strict as Map+import qualified Data.Maybe as Maybe+import qualified Database.PostgreSQL.LibPQ as LibPQ++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.++@since 1.0.0.0+-}+newtype Column+  = Column Int+  deriving+    ( -- | @since 1.0.0.0+      Eq+    , -- | @since 1.0.0.0+      Ord+    , -- | @since 1.0.0.0+      Enum+    , -- | @since 1.0.0.0+      Num+    )++{- |+  A trivial wrapper for `Int` to help keep track of column vs row number.++@since 1.0.0.0+-}+newtype Row+  = Row Int+  deriving+    ( -- | @since 1.0.0.0+      Eq+    , -- | @since 1.0.0.0+      Ord+    , -- | @since 1.0.0.0+      Enum+    , -- | @since 1.0.0.0+      Num+    )++{- |+  '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+  want to test aspects of the decoding that don't require a real database.++@since 1.0.0.0+-}+class ExecutionResult result where+  maxRowNumber :: result -> IO (Maybe Row)+  maxColumnNumber :: result -> IO (Maybe Column)+  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'+  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+  the 'ExecutionResult' API to read each row of each column directly.++@since 1.0.0.0+-}+readRows ::+  ExecutionResult result =>+  result ->+  IO [[(Maybe BS.ByteString, SqlValue)]]+readRows res = do+  mbMaxRow <- maxRowNumber res+  mbMaxColumn <- maxColumnNumber res++  let+    rowIndices =+      case mbMaxRow of+        Nothing -> []+        Just maxRow -> [0 .. maxRow]++    columnIndices =+      case mbMaxColumn of+        Nothing -> []+        Just maxColumn -> [0 .. maxColumn]++    readValue rowIndex columnIndex = do+      name <- columnName res columnIndex+      value <- getValue res rowIndex columnIndex+      pure $ (name, value)++    readRow rowIndex =+      traverse (readValue rowIndex) columnIndices++  traverse readRow rowIndices++-- | @since 1.0.0.0+instance ExecutionResult LibPQ.Result where+  maxRowNumber result = do+    rowCount <- fmap fromEnum (LibPQ.ntuples result)+    pure $+      if rowCount > 0+        then Just $ Row (rowCount - 1)+        else Nothing++  maxColumnNumber result = do+    columnCount <- fmap fromEnum (LibPQ.nfields result)+    pure $+      if columnCount > 0+        then Just $ Column (columnCount - 1)+        else Nothing++  columnName result =+    LibPQ.fname result . LibPQ.toColumn . fromEnum++  getValue result (Row row) (Column column) =+    -- N.B. the usage of `getvalue'` here is important as this version returns a+    -- _copy_ of the data in the 'Result' rather than a _reference_.+    -- This allows the 'Result' to be garbage collected instead of being held onto indefinitely.+    SqlValue.fromRawBytesNullable+      <$> LibPQ.getvalue' result (LibPQ.toRow row) (LibPQ.toColumn column)++{- |+  `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.++@since 1.0.0.0+-}+data FakeLibPQResult = FakeLibPQResult+  { fakeLibPQColumns :: Map.Map Column BS.ByteString+  , fakeLibPQRows :: Map.Map Row (Map.Map Column SqlValue)+  }++-- | @since 1.0.0.0+instance ExecutionResult FakeLibPQResult where+  maxRowNumber = pure . fakeLibPQMaxRow+  maxColumnNumber = pure . fakeLibPQMaxColumn+  columnName result = pure . fakeLibPQColumnName result+  getValue result column = pure . fakeLibPQGetValue result column++{- |+  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.++@since 1.0.0.0+-}+mkFakeLibPQResult ::+  -- | The column names for the result set+  [BS.ByteString] ->+  -- | The row data for the result set+  [[SqlValue]] ->+  FakeLibPQResult+mkFakeLibPQResult columnList valuesList =+  let+    indexedRows = do+      (rowNumber, row) <- zip [Row 0 ..] valuesList++      let+        indexedColumns = zip [Column 0 ..] row++      pure (rowNumber, Map.fromList indexedColumns)+  in+    FakeLibPQResult+      { fakeLibPQColumns = Map.fromList (zip [Column 0 ..] columnList)+      , fakeLibPQRows = Map.fromList indexedRows+      }++fakeLibPQMaxRow :: FakeLibPQResult -> Maybe Row+fakeLibPQMaxRow =+  fmap fst . Map.lookupMax . fakeLibPQRows++fakeLibPQMaxColumn :: FakeLibPQResult -> Maybe Column+fakeLibPQMaxColumn result =+  let+    maxColumnsByRow =+      map fst+        . Maybe.mapMaybe Map.lookupMax+        . Map.elems+        . fakeLibPQRows+        $ result+  in+    case maxColumnsByRow of+      [] ->+        Nothing+      _ ->+        Just (maximum maxColumnsByRow)++fakeLibPQColumnName :: FakeLibPQResult -> Column -> (Maybe BS.ByteString)+fakeLibPQColumnName result column =+  Map.lookup column (fakeLibPQColumns result)++fakeLibPQGetValue :: FakeLibPQResult -> Row -> Column -> SqlValue+fakeLibPQGetValue result rowNumber columnNumber =+  Maybe.fromMaybe SqlValue.sqlNull $ do+    row <- Map.lookup rowNumber (fakeLibPQRows result)+    Map.lookup columnNumber row
+ src/Orville/PostgreSQL/Execution/Insert.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE GADTs #-}++{- |++Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++Functions for working with executable @INSERT@ statements. The 'Insert' type is+a value that can be passed around and executed later. The 'Insert' is directly+associated with the presence of a returning clause and how to decode any rows+returned by that clause. This means it can be safely executed via+'executeInsert' or 'executeInsertReturnEntities' as appropriate. It is a+lower-level API than the entity insert functions in+"Orville.PostgreSQL.Execution.EntityOperations", but not as primitive as+"Orville.PostgreSQL.Expr.Insert".++@since 1.0.0.0+-}+module Orville.PostgreSQL.Execution.Insert+  ( Insert+  , insertToInsertExpr+  , executeInsert+  , executeInsertReturnEntities+  , insertToTableReturning+  , insertToTable+  , rawInsertExpr+  )+where++import Data.List.NonEmpty (NonEmpty)++import qualified Orville.PostgreSQL.Execution.Execute as Execute+import qualified Orville.PostgreSQL.Execution.QueryType as QueryType+import Orville.PostgreSQL.Execution.ReturningOption (NoReturningClause, ReturningClause, ReturningOption (WithReturning, WithoutReturning))+import qualified Orville.PostgreSQL.Expr as Expr+import Orville.PostgreSQL.Marshall.SqlMarshaller (AnnotatedSqlMarshaller)+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+'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.++@since 1.0.0.0+-}+data Insert readEntity returningClause where+  Insert ::+    AnnotatedSqlMarshaller writeEntity readEntity ->+    Expr.InsertExpr ->+    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+  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.++@since 1.0.0.0+-}+insertToInsertExpr :: Insert readEntity returningClause -> Expr.InsertExpr+insertToInsertExpr (Insert _ expr) = expr+insertToInsertExpr (InsertReturning _ expr) = expr++{- |+  Executes the database query for the 'Insert' and returns the number of rows+  affected by the query.++@since 1.0.0.0+-}+executeInsert ::+  Monad.MonadOrville m =>+  Insert readEntity NoReturningClause ->+  m Int+executeInsert (Insert _ expr) =+  Execute.executeAndReturnAffectedRows QueryType.InsertQuery expr++{- |+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.++@since 1.0.0.0+-}+executeInsertReturnEntities ::+  Monad.MonadOrville m =>+  Insert readEntity ReturningClause ->+  m [readEntity]+executeInsertReturnEntities (InsertReturning marshaller expr) =+  Execute.executeAndDecode QueryType.InsertQuery expr marshaller++{- |+  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+-}+insertToTable ::+  TableDefinition key writeEntity readEntity ->+  NonEmpty writeEntity ->+  Insert readEntity NoReturningClause+insertToTable =+  insertTable WithoutReturning++{- |+  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.++@since 1.0.0.0+-}+insertToTableReturning ::+  TableDefinition key writeEntity readEntity ->+  NonEmpty writeEntity ->+  Insert readEntity ReturningClause+insertToTableReturning =+  insertTable WithReturning++-- an internal helper function for creating an insert with a given `ReturningOption`+insertTable ::+  ReturningOption returningClause ->+  TableDefinition key writeEntity readEntity ->+  NonEmpty writeEntity ->+  Insert readEntity returningClause+insertTable returningOption tableDef entities =+  rawInsertExpr returningOption (tableMarshaller tableDef) (mkInsertExpr returningOption tableDef entities)++{- |+  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+  'Orville.PostgreSQL.SqlMarshaller' can decode.++  This is the lowest level of escape hatch available for 'Insert'. The caller can build any query+  that Orville supports using the expression-building functions, or use @RawSql.fromRawSql@ to build+  a raw 'Expr.InsertExpr'. It is expected that the 'ReturningOption' given matches the+  'Expr.InsertExpr'. This level of interface does not provide an automatic enforcement of the+  expectation, however failure is likely if that is not met.++@since 1.0.0.0+-}+rawInsertExpr :: ReturningOption returningClause -> AnnotatedSqlMarshaller writeEntity readEntity -> Expr.InsertExpr -> Insert readEntity returningClause+rawInsertExpr WithReturning = InsertReturning+rawInsertExpr WithoutReturning = Insert
+ src/Orville/PostgreSQL/Execution/QueryType.hs view
@@ -0,0 +1,42 @@+{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Execution.QueryType+  ( QueryType (SelectQuery, InsertQuery, UpdateQuery, DeleteQuery, DDLQuery, CursorQuery, OtherQuery)+  )+where++{- |+  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'++@since 1.0.0.0+-}+data QueryType+  = SelectQuery+  | InsertQuery+  | UpdateQuery+  | DeleteQuery+  | DDLQuery+  | CursorQuery+  | OtherQuery+  deriving+    ( -- | @since 1.0.0.0+      Ord+    , -- | @since 1.0.0.0+      Eq+    , -- | @since 1.0.0.0+      Enum+    , -- | @since 1.0.0.0+      Bounded+    , -- | @since 1.0.0.0+      Show+    , -- | @since 1.0.0.0+      Read+    )
+ src/Orville/PostgreSQL/Execution/ReturningOption.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE GADTs #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Execution.ReturningOption+  ( ReturningOption (..)+  , ReturningClause+  , NoReturningClause+  )+where++{- | A tag, used with 'ReturningOption' to indicate a SQL Returning clause.++@since 1.0.0.0+-}+data ReturningClause++{- | A tag, used with 'ReturningOption' to indicate no SQL Returning clause.++@since 1.0.0.0+-}+data NoReturningClause++{- |+  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+  WithReturning :: ReturningOption ReturningClause+  WithoutReturning :: ReturningOption NoReturningClause
+ src/Orville/PostgreSQL/Execution/Select.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++Functions for working with executable @SELECT@ statements. The 'Select' type is+a value that can be passed around and executed later. The 'Select' is directly+associated with how to decode the rows returned by the query. This means it+can be safely executed via 'executeSelect' and used to decode the rows. It is a+lower-level API than the entity select functions in+"Orville.PostgreSQL.Execution.EntityOperations", but not as primitive as+"Orville.PostgreSQL.Expr.Query".++@since 1.0.0.0+-}+module Orville.PostgreSQL.Execution.Select+  ( Select+  , executeSelect+  , useSelect+  , selectToQueryExpr+  , selectTable+  , selectMarshalledColumns+  , rawSelectQueryExpr+  )+where++import qualified Orville.PostgreSQL.Execution.Execute as Execute+import qualified Orville.PostgreSQL.Execution.QueryType as QueryType+import qualified Orville.PostgreSQL.Execution.SelectOptions as SelectOptions+import qualified Orville.PostgreSQL.Expr as Expr+import Orville.PostgreSQL.Marshall.SqlMarshaller (AnnotatedSqlMarshaller, marshallerDerivedColumns, unannotatedSqlMarshaller)+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+  'Select' has a 'Orville.PostgreSQL.SqlMarshaller' bound to it that will be+  used to decode the database result set when it is executed.++@since 1.0.0.0+-}+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+  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.++@since 1.0.0.0+-}+selectToQueryExpr :: Select readEntity -> Expr.QueryExpr+selectToQueryExpr (Select _ query) = query++{- |+  Executes the database query for the 'Select' and uses its+  'Orville.PostgreSQL.SqlMarshaller' to decode the result set.++@since 1.0.0.0+-}+executeSelect :: Monad.MonadOrville m => Select row -> m [row]+executeSelect =+  useSelect (Execute.executeAndDecode QueryType.SelectQuery)++{- |+  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.++@since 1.0.0.0+-}+useSelect ::+  ( forall writeEntity.+    Expr.QueryExpr ->+    AnnotatedSqlMarshaller writeEntity readEntity ->+    a+  ) ->+  Select readEntity ->+  a+useSelect f (Select marshaller query) =+  f query marshaller++{- |+  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+  database.++@since 1.0.0.0+-}+selectTable ::+  TableDefinition key writeEntity readEntity ->+  SelectOptions.SelectOptions ->+  Select readEntity+selectTable tableDef =+  selectMarshalledColumns (tableMarshaller tableDef) (tableName tableDef)++{- |+  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.++  This function is useful for querying a subset of table columns using a custom+  marshaller.++@since 1.0.0.0+-}+selectMarshalledColumns ::+  AnnotatedSqlMarshaller writeEntity readEntity ->+  Expr.Qualified Expr.TableName ->+  SelectOptions.SelectOptions ->+  Select readEntity+selectMarshalledColumns marshaller qualifiedTableName selectOptions =+  rawSelectQueryExpr marshaller $+    SelectOptions.selectOptionsQueryExpr+      (Expr.selectDerivedColumns (marshallerDerivedColumns . unannotatedSqlMarshaller $ marshaller))+      (Expr.referencesTable qualifiedTableName)+      selectOptions++{- |+  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.++  This is the lowest level of escape hatch available for 'Select'. The caller+  can build any query that Orville supports using the expression-building+  functions, or use @RawSql.fromRawSql@ to build a raw 'Expr.QueryExpr'.++@since 1.0.0.0+-}+rawSelectQueryExpr ::+  AnnotatedSqlMarshaller writeEntity readEntity ->+  Expr.QueryExpr ->+  Select readEntity+rawSelectQueryExpr = Select
+ src/Orville/PostgreSQL/Execution/SelectOptions.hs view
@@ -0,0 +1,263 @@+{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Execution.SelectOptions+  ( SelectOptions+  , emptySelectOptions+  , appendSelectOptions+  , selectDistinct+  , selectWhereClause+  , selectOrderByClause+  , selectGroupByClause+  , selectLimitExpr+  , selectOffsetExpr+  , distinct+  , where_+  , orderBy+  , limit+  , offset+  , groupBy+  , selectOptionsQueryExpr+  )+where++import Data.Monoid (First (First, getFirst))++import qualified Orville.PostgreSQL.Expr as Expr++{- |+   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').++@since 1.0.0.0+-}+data SelectOptions = SelectOptions+  { i_distinct :: First Bool+  , i_whereCondition :: Maybe Expr.BooleanExpr+  , i_orderBy :: Maybe Expr.OrderByExpr+  , i_limitExpr :: First Expr.LimitExpr+  , i_offsetExpr :: First Expr.OffsetExpr+  , i_groupByExpr :: Maybe Expr.GroupByExpr+  }++-- | @since 1.0.0.0+instance Semigroup SelectOptions where+  (<>) = appendSelectOptions++-- | @since 1.0.0.0+instance Monoid SelectOptions where+  mempty = emptySelectOptions++{- |+  A set of empty 'SelectOptions' that will not change how a query is run.++@since 1.0.0.0+-}+emptySelectOptions :: SelectOptions+emptySelectOptions =+  SelectOptions+    { i_distinct = mempty+    , i_whereCondition = Nothing+    , i_orderBy = mempty+    , i_limitExpr = mempty+    , i_offsetExpr = mempty+    , i_groupByExpr = mempty+    }++{- |+  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.++@since 1.0.0.0+-}+appendSelectOptions :: SelectOptions -> SelectOptions -> SelectOptions+appendSelectOptions left right =+  SelectOptions+    (i_distinct left <> i_distinct right)+    (unionMaybeWith Expr.andExpr (i_whereCondition left) (i_whereCondition right))+    (i_orderBy left <> i_orderBy right)+    (i_limitExpr left <> i_limitExpr right)+    (i_offsetExpr left <> i_offsetExpr right)+    (i_groupByExpr left <> i_groupByExpr right)++unionMaybeWith :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a+unionMaybeWith f mbLeft mbRight =+  case (mbLeft, mbRight) of+    (Nothing, Nothing) -> Nothing+    (Just left, Nothing) -> Just left+    (Nothing, Just right) -> Just right+    (Just left, Just right) -> Just (f left right)++{- |+  Builds the 'Expr.SelectClause' that should be used to include the+  'distinct's from the 'SelectOptions' on a query.++@since 1.0.0.0+-}+selectDistinct :: SelectOptions -> Expr.SelectClause+selectDistinct selectOptions =+  case i_distinct selectOptions of+    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+  'Expr.BooleanExpr's from the 'SelectOptions' on a query. This will be 'Nothing'+  when no 'Expr.BooleanExpr's have been specified.++@since 1.0.0.0+-}+selectWhereClause :: SelectOptions -> Maybe Expr.WhereClause+selectWhereClause =+  fmap Expr.whereClause . i_whereCondition++{- |+  Constructs a 'SelectOptions' with just 'distinct' set to 'True'.++@since 1.0.0.0+-}+distinct :: SelectOptions+distinct =+  emptySelectOptions+    { i_distinct = First $ Just True+    }++{- |+  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.++@since 1.0.0.0+-}+selectOrderByClause :: SelectOptions -> Maybe Expr.OrderByClause+selectOrderByClause =+  fmap Expr.orderByClause . i_orderBy++{- |+  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.++@since 1.0.0.0+-}+selectGroupByClause :: SelectOptions -> Maybe Expr.GroupByClause+selectGroupByClause =+  fmap Expr.groupByClause . i_groupByExpr++{- |+  Builds a 'Expr.LimitExpr' that will limit the query results to the+  number specified in the 'SelectOptions' (if any).++@since 1.0.0.0+-}+selectLimitExpr :: SelectOptions -> Maybe Expr.LimitExpr+selectLimitExpr =+  getFirst . i_limitExpr++{- |+  Builds an 'Expr.OffsetExpr' that will limit the query results to the+  number specified in the 'SelectOptions' (if any).++@since 1.0.0.0+-}+selectOffsetExpr :: SelectOptions -> Maybe Expr.OffsetExpr+selectOffsetExpr =+  getFirst . i_offsetExpr++{- |+  Constructs a 'SelectOptions' with just the given 'Expr.BooleanExpr'.++@since 1.0.0.0+-}+where_ :: Expr.BooleanExpr -> SelectOptions+where_ condition =+  emptySelectOptions+    { i_whereCondition = Just condition+    }++{- |+  Constructs a 'SelectOptions' with just the given 'Expr.OrderByExpr'.++@since 1.0.0.0+-}+orderBy :: Expr.OrderByExpr -> SelectOptions+orderBy order =+  emptySelectOptions+    { i_orderBy = Just order+    }++{- |+  Constructs a 'SelectOptions' that will apply the given limit.++@since 1.0.0.0+-}+limit :: Int -> SelectOptions+limit limitValue =+  emptySelectOptions+    { i_limitExpr = First . Just . Expr.limitExpr $ limitValue+    }++{- |+  Constructs a 'SelectOptions' that will apply the given offset.++@since 1.0.0.0+-}+offset :: Int -> SelectOptions+offset offsetValue =+  emptySelectOptions+    { i_offsetExpr = First . Just . Expr.offsetExpr $ offsetValue+    }++{- |+  Constructs a 'SelectOptions' with just the given 'Expr.GroupByClause'.++@since 1.0.0.0+-}+groupBy :: Expr.GroupByExpr -> SelectOptions+groupBy groupByExpr =+  emptySelectOptions+    { i_groupByExpr = Just groupByExpr+    }++{- |+  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+  expected by the 'Orville.PostgreSQL.SqlMarshaller' that is ultimately used to+  decode it.++  This function is useful for building more advanced queries that need to+  select things other than simple columns from the table, such as using+  aggregate functions. The 'Expr.SelectList' can be built however the caller+  desires. If Orville does not support building the 'Expr.SelectList' you need+  using any of the expression-building functions, you can resort to+  @RawSql.fromRawSql@ as an escape hatch to build the 'Expr.SelectList' here.++@since 1.0.0.0+-}+selectOptionsQueryExpr ::+  Expr.SelectList ->+  Expr.TableReferenceList ->+  SelectOptions ->+  Expr.QueryExpr+selectOptionsQueryExpr selectList tableReferenceList selectOptions =+  Expr.queryExpr+    (selectDistinct selectOptions)+    selectList+    ( Just $+        Expr.tableExpr+          tableReferenceList+          (selectWhereClause selectOptions)+          (selectGroupByClause selectOptions)+          (selectOrderByClause selectOptions)+          (selectLimitExpr selectOptions)+          (selectOffsetExpr selectOptions)+    )
+ src/Orville/PostgreSQL/Execution/Sequence.hs view
@@ -0,0 +1,78 @@+{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++Interactions to work with database sequence values on the Haskell side,+including inspection of the current and next values in the sequence as well as+updating a sequence to a given value.++@since 1.0.0.0+-}+module Orville.PostgreSQL.Execution.Sequence+  ( sequenceNextValue+  , sequenceCurrentValue+  , sequenceSetValue+  )+where++import Data.Int (Int64)++import qualified Orville.PostgreSQL.Execution.Execute as Execute+import qualified Orville.PostgreSQL.Execution.QueryType as QueryType+import qualified Orville.PostgreSQL.Expr as Expr+import qualified Orville.PostgreSQL.Internal.RowCountExpectation as RowCountExpectation+import qualified Orville.PostgreSQL.Marshall as Marshall+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.++@since 1.0.0.0+-}+sequenceNextValue :: Monad.MonadOrville m => SequenceDefinition -> m Int64+sequenceNextValue sequenceDef =+  selectInt64Value+    "sequenceNextValue"+    (Expr.nextVal (sequenceName sequenceDef))++{- |+  Fetches the current value from a sequence via the PostgreSQL @currval@ function.++@since 1.0.0.0+-}+sequenceCurrentValue :: Monad.MonadOrville m => SequenceDefinition -> m Int64+sequenceCurrentValue sequenceDef =+  selectInt64Value+    "sequenceCurrentValue"+    (Expr.currVal (sequenceName sequenceDef))++{- |+  Sets the current value from a sequence via the PostgreSQL @setval@ function.++@since 1.0.0.0+-}+sequenceSetValue :: Monad.MonadOrville m => SequenceDefinition -> Int64 -> m Int64+sequenceSetValue sequenceDef newValue =+  selectInt64Value+    "sequenceSetValue"+    (Expr.setVal (sequenceName sequenceDef) newValue)++selectInt64Value :: Monad.MonadOrville m => String -> Expr.ValueExpression -> m Int64+selectInt64Value caller valueExpression = do+  let+    queryExpr =+      Expr.queryExpr+        (Expr.selectClause (Expr.selectExpr Nothing))+        ( Expr.selectDerivedColumns+            [Expr.deriveColumnAs valueExpression (Expr.columnName "result")]+        )+        Nothing++    marshaller =+      Marshall.annotateSqlMarshallerEmptyAnnotation+        . Marshall.marshallField id+        $ Marshall.bigIntegerField "result"+  values <- Execute.executeAndDecode QueryType.SelectQuery queryExpr marshaller+  RowCountExpectation.expectExactlyOneRow caller values
+ src/Orville/PostgreSQL/Execution/Transaction.hs view
@@ -0,0 +1,129 @@+{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++This module provides the functionality to work with SQL transactions - notably+to ensure some Haskell action occurs within a database transaction.++@since 1.0.0.0+-}+module Orville.PostgreSQL.Execution.Transaction+  ( withTransaction+  )+where++import Control.Monad.IO.Class (MonadIO, liftIO)++import qualified Orville.PostgreSQL.Execution.Execute as Execute+import qualified Orville.PostgreSQL.Execution.QueryType as QueryType+import qualified Orville.PostgreSQL.Expr as Expr+import qualified Orville.PostgreSQL.Internal.Bracket as Bracket+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.RawSql as RawSql++{- |+  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.++  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.++  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 =+  MonadOrville.withConnectedState $ \connectedState -> do+    let+      conn = OrvilleState.connectedConnection connectedState+      transaction = OrvilleState.newTransaction (OrvilleState.connectedTransaction connectedState)++      innerConnectedState =+        connectedState+          { OrvilleState.connectedTransaction = Just transaction+          }++    state <- Monad.askOrvilleState++    let+      executeTransactionSql :: RawSql.RawSql -> IO ()+      executeTransactionSql sql =+        Execute.executeVoidIO QueryType.OtherQuery sql state conn++      callback =+        OrvilleState.orvilleTransactionCallback state++      beginTransaction = do+        liftIO $ do+          let+            openEvent = OrvilleState.openTransactionEvent transaction+          executeTransactionSql (transactionEventSql state openEvent)+          callback openEvent++      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++    Bracket.bracketWithResult beginTransaction finishTransaction doAction++transactionEventSql ::+  OrvilleState.OrvilleState ->+  OrvilleState.TransactionEvent ->+  RawSql.RawSql+transactionEventSql state event =+  case event of+    OrvilleState.BeginTransaction ->+      RawSql.toRawSql $ OrvilleState.orvilleBeginTransactionExpr state+    OrvilleState.NewSavepoint savepoint ->+      RawSql.toRawSql $ Expr.savepoint (savepointName savepoint)+    OrvilleState.RollbackTransaction ->+      RawSql.toRawSql $ Expr.rollback+    OrvilleState.RollbackToSavepoint savepoint ->+      RawSql.toRawSql $ Expr.rollbackTo (savepointName savepoint)+    OrvilleState.CommitTransaction ->+      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+  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,+  however. Re-using this same name in other databases would overwrite the+  savepoint rather than shadow it. This function constructs savepoint names+  that will work on any database that implements savepoints accordings to the+  SQL standard even though Orville only supports PostgreSQL currently.++@since 1.0.0.0+-}+savepointName :: OrvilleState.Savepoint -> Expr.SavepointName+savepointName savepoint =+  let+    n = OrvilleState.savepointNestingLevel savepoint+  in+    Expr.savepointName ("orville_savepoint_level_" <> show n)
+ src/Orville/PostgreSQL/Execution/Update.hs view
@@ -0,0 +1,213 @@+{-# LANGUAGE GADTs #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++Functions for working with executable @UPDATE@ statements. The 'Update' type is+a value that can be passed around and executed later. The 'Update' is directly+associated with the presence of a returning clause and how to decode any rows+returned by that clause. This means it can be safely executed via+'executeUpdate' or 'executeUpdateReturnEntities' as appropriate. It is a+lower-level API than the entity update functions in+"Orville.PostgreSQL.Execution.EntityOperations", but not as primitive as+"Orville.PostgreSQL.Expr.Update".++@since 1.0.0.0+-}+module Orville.PostgreSQL.Execution.Update+  ( Update+  , updateToUpdateExpr+  , executeUpdate+  , executeUpdateReturnEntities+  , updateToTableReturning+  , updateToTable+  , updateToTableFieldsReturning+  , updateToTableFields+  , rawUpdateExpr+  )+where++import Data.List.NonEmpty (NonEmpty, nonEmpty)++import qualified Orville.PostgreSQL.Execution.Execute as Execute+import qualified Orville.PostgreSQL.Execution.QueryType as QueryType+import Orville.PostgreSQL.Execution.ReturningOption (NoReturningClause, ReturningClause, ReturningOption (WithReturning, WithoutReturning))+import qualified Orville.PostgreSQL.Expr as Expr+import Orville.PostgreSQL.Marshall (AnnotatedSqlMarshaller, marshallEntityToSetClauses, unannotatedSqlMarshaller)+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+  '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.++@since 1.0.0.0+-}+data Update readEntity returningClause where+  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+  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.++@since 1.0.0.0+-}+updateToUpdateExpr :: Update readEntity returningClause -> Expr.UpdateExpr+updateToUpdateExpr (UpdateNoReturning expr) = expr+updateToUpdateExpr (UpdateReturning _ expr) = expr++{- |+  Executes the database query for the 'Update' and returns the number of+  affected rows.++@since 1.0.0.0+-}+executeUpdate :: Monad.MonadOrville m => Update readEntity returningClause -> m Int+executeUpdate =+  Execute.executeAndReturnAffectedRows QueryType.UpdateQuery . updateToUpdateExpr++{- |+  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.++@since 1.0.0.0+-}+executeUpdateReturnEntities :: Monad.MonadOrville m => Update readEntity ReturningClause -> m [readEntity]+executeUpdateReturnEntities (UpdateReturning marshaller expr) =+  Execute.executeAndDecode QueryType.UpdateQuery expr marshaller++{- |+  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,+  which would otherwise generate and 'Update' with invalid SQL syntax.++@since 1.0.0.0+-}+updateToTable ::+  TableDefinition (HasKey key) writeEntity readEntity ->+  key ->+  writeEntity ->+  Maybe (Update readEntity NoReturningClause)+updateToTable =+  updateTable WithoutReturning++{- |+  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.++  This function returns 'Nothing' if the 'TableDefinition' has no columns,+  which would otherwise generate an 'Update' with invalid SQL syntax.++@since 1.0.0.0+-}+updateToTableReturning ::+  TableDefinition (HasKey key) writeEntity readEntity ->+  key ->+  writeEntity ->+  Maybe (Update readEntity ReturningClause)+updateToTableReturning =+  updateTable WithReturning++{- |+  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+-}+updateToTableFields ::+  TableDefinition key writeEntity readEntity ->+  NonEmpty Expr.SetClause ->+  Maybe Expr.BooleanExpr ->+  Update readEntity NoReturningClause+updateToTableFields =+  updateFields WithoutReturning++{- |+  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.++@since 1.0.0.0+-}+updateToTableFieldsReturning ::+  TableDefinition key writeEntity readEntity ->+  NonEmpty Expr.SetClause ->+  Maybe Expr.BooleanExpr ->+  Update readEntity ReturningClause+updateToTableFieldsReturning =+  updateFields WithReturning++{- |+  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.++  This is the lowest level of escape hatch available for 'Update'. The caller can build any query+  that Orville supports using the expression-building functions, or use @RawSql.fromRawSql@ to build+  a raw 'Expr.UpdateExpr'.++@since 1.0.0.0+-}+rawUpdateExpr :: ReturningOption returningClause -> AnnotatedSqlMarshaller writeEntity readEntity -> Expr.UpdateExpr -> Update readEntity returningClause+rawUpdateExpr WithReturning marshaller = UpdateReturning marshaller+rawUpdateExpr WithoutReturning _ = UpdateNoReturning++-- an internal helper function for creating an update with a given+-- `ReturningOption` to a single entity in a table, setting all the+-- columns found in the table's SQL marshaller.+updateTable ::+  ReturningOption returningClause ->+  TableDefinition (HasKey key) writeEntity readEntity ->+  key ->+  writeEntity ->+  Maybe (Update readEntity returningClause)+updateTable returningOption tableDef key writeEntity = do+  setClauses <-+    nonEmpty $+      marshallEntityToSetClauses+        (unannotatedSqlMarshaller $ tableMarshaller tableDef)+        writeEntity++  let+    isEntityKey =+      primaryKeyEquals+        (tablePrimaryKey tableDef)+        key+  pure $+    updateFields+      returningOption+      tableDef+      setClauses+      (Just isEntityKey)++-- an internal helper function for creating an update with a given+-- `ReturningOption` to update the specified columns.+updateFields ::+  ReturningOption returningClause ->+  TableDefinition key writeEntity readEntity ->+  NonEmpty Expr.SetClause ->+  Maybe Expr.BooleanExpr ->+  Update readEntity returningClause+updateFields returingOption tableDef setClauses mbWhereCondition =+  let+    whereClause =+      fmap Expr.whereClause mbWhereCondition+  in+    rawUpdateExpr returingOption (tableMarshaller tableDef) $+      Expr.updateExpr+        (tableName tableDef)+        (Expr.setClauseList setClauses)+        whereClause+        (mkTableReturningClause returingOption tableDef)
+ src/Orville/PostgreSQL/Expr.hs view
@@ -0,0 +1,97 @@+{-# OPTIONS_GHC -Wno-missing-import-lists #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++This module provides access to functions and types intended to help build SQL+statements directly in a relatively safe manner while also always providing a+way to write exactly the SQL you need. The SQL construction functions all+require specific types as their arguments to communicate what particular+fragment of SQL they expect to take as an argument. These types generally+provide a 'Orville.PostgreSQL.Raw.RawSql.SqlExpression' instance, however,+meaning that if Orville does not support constructing the exact SQL fragment+you want to pass for that argument directly you can always use+'Orville.PostgreSQL.Raw.RawSql.unsafeSqlExpression' to construct a value of the+required type. This means you can use as many of the "safe" construction+functions provided here as possible while substituting in hand-written SQL at+only the exact points you need.++For instance, the following code snippet shows how you could construct a @BEGIN+TRANSACTION ISOLATION LEVEL SOME NEW ISOLATION LEVEL@ statement if PostgreSQL+added @SOME NEW ISOLATION LEVEL@ and Orville did not yet support it.++@+  import qualified Orville.PostgreSQL.Expr as Expr+  import qualified Orville.PostgreSQL.Raw.RawSql as RawSql++  customerBeginTransaction :: Expr.BeginTransactionExpr+  customerBeginTransaction =+    Expr.beginTransaction+      (Just (Expr.isolationLevel (RawSql.unsafeSqlExpression "SOME NEW ISOLATION LEVEL")))+@++@since 1.0.0.0+-}+module Orville.PostgreSQL.Expr+  ( module Orville.PostgreSQL.Expr.BinaryOperator+  , module Orville.PostgreSQL.Expr.ColumnDefinition+  , 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.IfExists+  , module Orville.PostgreSQL.Expr.Index+  , module Orville.PostgreSQL.Expr.Insert+  , module Orville.PostgreSQL.Expr.LimitExpr+  , module Orville.PostgreSQL.Expr.Math+  , module Orville.PostgreSQL.Expr.Name+  , module Orville.PostgreSQL.Expr.OffsetExpr+  , module Orville.PostgreSQL.Expr.OrderBy+  , module Orville.PostgreSQL.Expr.Query+  , module Orville.PostgreSQL.Expr.ReturningExpr+  , module Orville.PostgreSQL.Expr.Select+  , 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+  )+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.BinaryOperator+import Orville.PostgreSQL.Expr.ColumnDefinition+import Orville.PostgreSQL.Expr.Count+import Orville.PostgreSQL.Expr.Cursor+import Orville.PostgreSQL.Expr.DataType+import Orville.PostgreSQL.Expr.Delete+import Orville.PostgreSQL.Expr.GroupBy+import Orville.PostgreSQL.Expr.IfExists+import Orville.PostgreSQL.Expr.Index+import Orville.PostgreSQL.Expr.Insert+import Orville.PostgreSQL.Expr.LimitExpr+import Orville.PostgreSQL.Expr.Math+import Orville.PostgreSQL.Expr.Name+import Orville.PostgreSQL.Expr.OffsetExpr+import Orville.PostgreSQL.Expr.OrderBy+import Orville.PostgreSQL.Expr.Query+import Orville.PostgreSQL.Expr.ReturningExpr+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.Time+import Orville.PostgreSQL.Expr.Transaction+import Orville.PostgreSQL.Expr.Update+import Orville.PostgreSQL.Expr.ValueExpression+import Orville.PostgreSQL.Expr.WhereClause
+ src/Orville/PostgreSQL/Expr/BinaryOperator.hs view
@@ -0,0 +1,272 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++Provides a type representing SQL operators with exactly two arguments, as well+as values of that type for many common operators.++@since 1.0.0.0+-}+module Orville.PostgreSQL.Expr.BinaryOperator+  ( BinaryOperator+  , binaryOperator+  , binaryOpExpression+  , equalsOp+  , notEqualsOp+  , greaterThanOp+  , lessThanOp+  , greaterThanOrEqualsOp+  , lessThanOrEqualsOp+  , likeOp+  , iLikeOp+  , orOp+  , andOp+  , plusOp+  , minusOp+  , multiplicationOp+  , divisionOp+  , moduloOp+  , exponentiationOp+  , bitwiseAndOp+  , bitwiseOrOp+  , bitwiseXorOp+  , bitwiseShiftLeftOp+  , bitwiseShiftRightOp+  )+where++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.++> AND++'BinaryOperator' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype BinaryOperator+  = BinaryOperator RawSql.RawSql+  deriving+    ( -- | @since 1.0.0.0+      RawSql.SqlExpression+    )++{- | Construct a binary operator. Note that this does not include any check to determine if the+operator is valid, either by being a native SQL operator, or a custom-defined operator in the+database.++@since 1.0.0.0+-}+binaryOperator :: String -> BinaryOperator+binaryOperator =+  BinaryOperator . RawSql.fromString++{- | The SQL equal binary operator.++@since 1.0.0.0+-}+equalsOp :: BinaryOperator+equalsOp =+  binaryOperator "="++{- | The SQL not equal binary operator.++@since 1.0.0.0+-}+notEqualsOp :: BinaryOperator+notEqualsOp =+  binaryOperator "<>"++{- | The SQL strictly greater than binary operator.++@since 1.0.0.0+-}+greaterThanOp :: BinaryOperator+greaterThanOp =+  binaryOperator ">"++{- | The SQL strictly less than binary operator.++@since 1.0.0.0+-}+lessThanOp :: BinaryOperator+lessThanOp =+  binaryOperator "<"++{- | The SQL greater than or equal binary operator.++@since 1.0.0.0+-}+greaterThanOrEqualsOp :: BinaryOperator+greaterThanOrEqualsOp =+  binaryOperator ">="++{- | The SQL less than or equal binary operator.++@since 1.0.0.0+-}+lessThanOrEqualsOp :: BinaryOperator+lessThanOrEqualsOp =+  binaryOperator "<="++{- | The SQL LIKE binary operator.++@since 1.0.0.0+-}+likeOp :: BinaryOperator+likeOp =+  binaryOperator "LIKE"++{- | The SQL ILIKE binary operator.++@since 1.0.0.0+-}+iLikeOp :: BinaryOperator+iLikeOp =+  binaryOperator "ILIKE"++{- | The SQL logical or binary operator.++@since 1.0.0.0+-}+orOp :: BinaryOperator+orOp =+  binaryOperator "OR"++{- | The SQL logical and binary operator.++@since 1.0.0.0+-}+andOp :: BinaryOperator+andOp =+  binaryOperator "AND"++{- | The SQL + binary operator.++@since 1.0.0.0+-}+plusOp :: BinaryOperator+plusOp =+  binaryOperator "+"++{- | The SQL - binary operator.++@since 1.0.0.0+-}+minusOp :: BinaryOperator+minusOp =+  binaryOperator "-"++{- | The SQL * binary operator.++@since 1.0.0.0+-}+multiplicationOp :: BinaryOperator+multiplicationOp =+  binaryOperator "*"++{- | The SQL / binary operator.++@since 1.0.0.0+-}+divisionOp :: BinaryOperator+divisionOp =+  binaryOperator "/"++{- | The SQL % binary operator.++@since 1.0.0.0+-}+moduloOp :: BinaryOperator+moduloOp =+  binaryOperator "%"++{- | The SQL ^ binary operator.++@since 1.0.0.0+-}+exponentiationOp :: BinaryOperator+exponentiationOp =+  binaryOperator "^"++{- | The SQL bitwise and (a.k.a &) binary operator.++@since 1.0.0.0+-}+bitwiseAndOp :: BinaryOperator+bitwiseAndOp =+  binaryOperator "&"++{- | The SQL bitwise or (a.k.a |) binary operator.++@since 1.0.0.0+-}+bitwiseOrOp :: BinaryOperator+bitwiseOrOp =+  binaryOperator "|"++{- | The SQL bitwise exclusive or (a.k.a #) binary operator.++@since 1.0.0.0+-}+bitwiseXorOp :: BinaryOperator+bitwiseXorOp =+  binaryOperator "#"++{- | The SQL bitwise left shift (a.k.a <<) binary operator.++@since 1.0.0.0+-}+bitwiseShiftLeftOp :: BinaryOperator+bitwiseShiftLeftOp =+  binaryOperator "<<"++{- | The SQL bitwise right shift (a.k.a >>) binary operator.++@since 1.0.0.0+-}+bitwiseShiftRightOp :: BinaryOperator+bitwiseShiftRightOp =+  binaryOperator ">>"++{- | Apply a binary operator to two 'ValueExpression's resulting in some+ 'RawSql.SqlExpression'. Note that this does *NOT* extend typechecking to the 'ValueExpression's+ being used with the 'BinaryOperator'. It is left to the caller to ensure that the operator makes+ sense with the arguments being passed.++@since 1.0.0.0+-}+binaryOpExpression ::+  RawSql.SqlExpression sql =>+  BinaryOperator ->+  ValueExpression ->+  ValueExpression ->+  sql+binaryOpExpression op left right =+  binaryOpExpressionUnparenthenizedArguments+    op+    (RawSql.unsafeFromRawSql (RawSql.leftParen <> RawSql.toRawSql left <> RawSql.rightParen))+    (RawSql.unsafeFromRawSql (RawSql.leftParen <> RawSql.toRawSql right <> RawSql.rightParen))++-- internal helper function+binaryOpExpressionUnparenthenizedArguments ::+  RawSql.SqlExpression sql =>+  BinaryOperator ->+  ValueExpression ->+  ValueExpression ->+  sql+binaryOpExpressionUnparenthenizedArguments op left right =+  RawSql.unsafeFromRawSql $+    RawSql.toRawSql left+      <> RawSql.space+      <> RawSql.toRawSql op+      <> RawSql.space+      <> RawSql.toRawSql right
+ src/Orville/PostgreSQL/Expr/ColumnDefinition.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Expr.ColumnDefinition+  ( ColumnDefinition+  , columnDefinition+  , ColumnConstraint+  , notNullConstraint+  , nullConstraint+  , ColumnDefault+  , columnDefault+  )+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.++> foo INTEGER++'ColumnDefinition' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype ColumnDefinition+  = ColumnDefinition RawSql.RawSql+  deriving+    ( -- | @since 1.0.0.0+      RawSql.SqlExpression+    )++{- | Smart constructor for ensuring a 'ColumnDefinition' is set up correctly.++@since 1.0.0.0+-}+columnDefinition ::+  -- | The name the resulting column should have.+  ColumnName ->+  -- | The SQL type of the column.+  DataType ->+  -- | The constraint on the column, if any.+  Maybe 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+      ]++{- |+Represent constraints, such as nullability, on a column. E.G.++> NOT NULL++'ColumnConstraint' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype ColumnConstraint+  = ColumnConstraint RawSql.RawSql+  deriving+    ( -- | @since 1.0.0.0+      RawSql.SqlExpression+    )++{- | Express that a column may not contain NULL.++@since 1.0.0.0+-}+notNullConstraint :: ColumnConstraint+notNullConstraint =+  ColumnConstraint (RawSql.fromString "NOT NULL")++{- | Express that a column may contain NULL.++@since 1.0.0.0+-}+nullConstraint :: ColumnConstraint+nullConstraint =+  ColumnConstraint (RawSql.fromString "NULL")++{- |+Represents the default value of a column. E.G.++> now()++'ColumnDefault' provides' a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype ColumnDefault+  = ColumnDefault RawSql.RawSql+  deriving+    ( -- | @since 1.0.0.0+      RawSql.SqlExpression+    )++{- | Given a 'ValueExpression', use that as a 'ColumnDefault'. This is the preferred path to creating a+   column default. Note that it is up to the caller to ensure the 'ValueExpression' makes sense for+   the resulting 'ColumnDefinition' this will be a part of.++@since 1.0.0.0+-}+columnDefault ::+  ValueExpression ->+  ColumnDefault+columnDefault defaultValue =+  ColumnDefault (RawSql.fromString "DEFAULT " <> RawSql.toRawSql defaultValue)
+ src/Orville/PostgreSQL/Expr/Count.hs view
@@ -0,0 +1,49 @@+{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Expr.Count+  ( count+  , countFunction+  , count1+  , countColumn+  )+where++import Orville.PostgreSQL.Expr.Name (ColumnName, FunctionName, functionName)+import Orville.PostgreSQL.Expr.ValueExpression (ValueExpression, columnReference, functionCall)+import qualified Orville.PostgreSQL.Raw.RawSql as RawSql++{- | The SQL @count@ function.++@since 1.0.0.0+-}+countFunction :: FunctionName+countFunction = functionName "count"++{- | Given a 'ValueExpression', use it as the argument to the SQL @count@.++@since 1.0.0.0+-}+count :: ValueExpression -> ValueExpression+count value =+  functionCall countFunction [value]++{- | The SQL @count(1)@.++@since 1.0.0.0+-}+count1 :: ValueExpression+count1 =+  count . RawSql.unsafeFromRawSql . RawSql.intDecLiteral $ 1++{- | Use a given column as the argument to the SQL @count@.++@since 1.0.0.0+-}+countColumn :: ColumnName -> ValueExpression+countColumn =+  count . columnReference
+ src/Orville/PostgreSQL/Expr/Cursor.hs view
@@ -0,0 +1,524 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Expr.Cursor+  ( DeclareExpr+  , declare+  , ScrollExpr+  , scroll+  , noScroll+  , HoldExpr+  , withHold+  , withoutHold+  , CloseExpr+  , close+  , AllCursors+  , allCursors+  , FetchExpr+  , fetch+  , MoveExpr+  , move+  , CursorDirection+  , next+  , prior+  , first+  , last+  , absolute+  , relative+  , rowCount+  , fetchAll+  , forward+  , forwardCount+  , forwardAll+  , backward+  , backwardCount+  , backwardAll+  )+where++import Data.Maybe (catMaybes)+import Prelude (Either, Int, Maybe (Just), either, fmap, ($), (.), (<>))++import Orville.PostgreSQL.Expr.Name (CursorName)+import Orville.PostgreSQL.Expr.Query (QueryExpr)+import qualified Orville.PostgreSQL.Raw.RawSql as RawSql++{- |+'DeclareExpr' corresponds to the SQL DECLARE statement, for declaring and+opening cursors. E.G.++> DECLARE FOO CURSOR FOR SELECT * FROM BAR++See PostgreSQL [cursor declare+documentation](https://www.postgresql.org/docs/current/sql-declare.html) for+more information.++'DeclareExpr' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype DeclareExpr+  = DeclareExpr RawSql.RawSql+  deriving+    ( -- | @since 1.0.0.0+      RawSql.SqlExpression+    )++{- | A smart constructor for setting up a 'DeclareExpr'. This, along with other functions provided,+   allows users to more safely declare a cursor.++@since 1.0.0.0+-}+declare ::+  CursorName ->+  Maybe ScrollExpr ->+  Maybe HoldExpr ->+  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+        ]++{- |+'ScrollExpr' is used to determine if a cursor should be able to fetch+nonsequentially. E.G.++> NO SCROLL++Note that the default in at least PostgreSQL versions 11-15 is to allow+nonsequential fetches under some, but not all, circumstances.++See PostgreSQL [cursor declare+documentation](https://www.postgresql.org/docs/current/sql-declare.html) for more information.++'ScrollExpr' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype ScrollExpr+  = ScrollExpr RawSql.RawSql+  deriving+    ( -- | @since 1.0.0.0+      RawSql.SqlExpression+    )++{- | Allow a cursor to be used to fetch rows nonsequentially.++@since 1.0.0.0+-}+scroll :: ScrollExpr+scroll =+  ScrollExpr . RawSql.fromString $ "SCROLL"++{- | Only allow a cursor to be used to fetch rows sequentially.++@since 1.0.0.0+-}+noScroll :: ScrollExpr+noScroll =+  ScrollExpr . RawSql.fromString $ "NO SCROLL"++{- |+'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++See PostgreSQL [cursor documentation](https://www.postgresql.org/docs/current/sql-declare.html) for+more information.++'HoldExpr' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype HoldExpr+  = HoldExpr RawSql.RawSql+  deriving+    ( -- | @since 1.0.0.0+      RawSql.SqlExpression+    )++{- | Allow a cursor to be used after the transaction creating it is committed.++@since 1.0.0.0+-}+withHold :: HoldExpr+withHold =+  HoldExpr . RawSql.fromString $ "WITH HOLD"++{- | Do not allow a cursor to be used after the transaction creating it is committed.++@since 1.0.0.0+-}+withoutHold :: HoldExpr+withoutHold =+  HoldExpr . RawSql.fromString $ "WITHOUT HOLD"++{- |+'CloseExpr' corresponds to the SQL CLOSE statement. E.G.++> CLOSE ALL++See PostgreSQL [close documentation](https://www.postgresql.org/docs/current/sql-close.html) for+more information.++'HoldExpr' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype CloseExpr+  = CloseExpr RawSql.RawSql+  deriving+    ( -- | @since 1.0.0.0+      RawSql.SqlExpression+    )++{- | A smart constructor for setting up a 'CloseExpr', either closing all cursors or the given named+   cursor.++@since 1.0.0.0+-}+close :: Either AllCursors CursorName -> CloseExpr+close allOrCursorName =+  CloseExpr $+    RawSql.fromString "CLOSE "+      <> either RawSql.toRawSql RawSql.toRawSql allOrCursorName++{- |+'AllCursors' corresponds to the ALL keyword in a CLOSE statement. E.G.++> ALL++'AllCursors' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype AllCursors+  = AllCursors RawSql.RawSql+  deriving+    ( -- | @since 1.0.0.0+      RawSql.SqlExpression+    )++{- | Specify closing all open cursors, for use with a 'CloseExpr'.++@since 1.0.0.0+-}+allCursors :: AllCursors+allCursors =+  AllCursors . RawSql.fromString $ "ALL"++{- |+'FetchExpr' corresponds to the SQL FETCH statement, for retrieving rows from a+previously-created cursor. E.G.++> FETCH NEXT FOO++See PostgreSQL [fetch+documentation](https://www.postgresql.org/docs/current/sql-fetch.html) for more+information.++'FetchExpr' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype FetchExpr+  = FetchExpr RawSql.RawSql+  deriving+    ( -- | @since 1.0.0.0+      RawSql.SqlExpression+    )++{- | Construct a 'FetchExpr', for a given cursor and optionally a direction to fetch.++@since 1.0.0.0+-}+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+        ]++{- |+'MoveExpr' corresponds to the SQL MOVE statement, for positioning a previously+created cursor, /without/ retrieving any rows. E.G.++> MOVE NEXT FOO++'MoveExpr' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype MoveExpr+  = MoveExpr RawSql.RawSql+  deriving+    ( -- | @since 1.0.0.0+      RawSql.SqlExpression+    )++{- | Construct a 'MoveExpr', for a given cursor and optionally a direction to move.++@since 1.0.0.0+-}+move :: Maybe CursorDirection -> CursorName -> MoveExpr+move maybeDirection cursorName =+  MoveExpr+    . RawSql.intercalate RawSql.space+    $ catMaybes+      [ Just $ RawSql.fromString "MOVE"+      , fmap RawSql.toRawSql maybeDirection+      , Just $ RawSql.toRawSql cursorName+      ]++{- |+'CursorDirection' corresponds to the direction argument to the SQL FETCH and+MOVE statements. E.G.++> BACKWARD++See PostgreSQL [fetch documentation](https://www.postgresql.org/docs/current/sql-fetch.html) for+more information.++'CursorDirection' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype CursorDirection+  = CursorDirection RawSql.RawSql+  deriving+    ( -- | @since 1.0.0.0+      RawSql.SqlExpression+    )++{- | Specify the direction of the next single row. Primarily for use with+    'fetch' or 'move'.++See PostgreSQL [fetch documentation](https://www.postgresql.org/docs/current/sql-fetch.html) for+more information.++@since 1.0.0.0+-}+next :: CursorDirection+next =+  CursorDirection . RawSql.fromString $ "NEXT"++{- | Specify the direction of the prior single row. Primarily for use with+    'fetch' or 'move'.++See PostgreSQL [fetch documentation](https://www.postgresql.org/docs/current/sql-fetch.html) for+more information.++@since 1.0.0.0+-}+prior :: CursorDirection+prior =+  CursorDirection . RawSql.fromString $ "PRIOR"++{- | Specify the direction of the first single row. Primarily for use with+    'fetch' or 'move'.++See PostgreSQL [fetch documentation](https://www.postgresql.org/docs/current/sql-fetch.html) for+more information.++@since 1.0.0.0+-}+first :: CursorDirection+first =+  CursorDirection . RawSql.fromString $ "FIRST"++{- | Specify the direction of the last single row. Primarily for use with+    'fetch' or 'move'.++See PostgreSQL [fetch documentation](https://www.postgresql.org/docs/current/sql-fetch.html) for+more information.++@since 1.0.0.0+-}+last :: CursorDirection+last =+  CursorDirection . RawSql.fromString $ "LAST"++{- | Specify the direction of the single row at an absolute position within the+    cursor. Primarily for use with 'fetch' or 'move'.++See PostgreSQL [fetch documentation](https://www.postgresql.org/docs/current/sql-fetch.html) for+more information.++@since 1.0.0.0+-}+absolute :: Int -> CursorDirection+absolute countParam =+  -- postgresql won't let us pass the count as a parameter.+  -- when we try we get an error like such error:+  --  ERROR:  syntax error at or near "$1"+  --  LINE 1: FETCH ABSOLUTE $1 \"testcursor\"+  CursorDirection $+    RawSql.fromString "ABSOLUTE "+      <> RawSql.intDecLiteral countParam++{- | Specify the direction of the single row relative to the cursor's current+    position. Primarily for use with 'fetch' or 'move'.++See PostgreSQL [fetch documentation](https://www.postgresql.org/docs/current/sql-fetch.html) for+more information.++@since 1.0.0.0+-}+relative :: Int -> CursorDirection+relative countParam =+  CursorDirection $+    RawSql.fromString "RELATIVE "+      <>+      -- postgresql won't let us pass the count as a parameter.+      -- when we try we get an error like such error:+      --  ERROR:  syntax error at or near "$1"+      --  LINE 1: FETCH RELATIVE $1 \"testcursor\"+      RawSql.intDecLiteral countParam++{- | Specify the direction of the next n rows. Primarily for use with 'fetch'+    or 'move'.++See PostgreSQL [fetch documentation](https://www.postgresql.org/docs/current/sql-fetch.html) for+more information.++@since 1.0.0.0+-}+rowCount :: Int -> CursorDirection+rowCount countParam =+  -- postgresql won't let us pass the count as a parameter.+  -- when we try we get an error like such error:+  --  ERROR:  syntax error at or near "$1"+  --  LINE 1: FETCH $1 \"testcursor\"+  CursorDirection $+    RawSql.intDecLiteral countParam++{- | Specify the direction of all the next rows. Primarily for use with 'fetch'+    or 'move'.++See PostgreSQL [fetch documentation](https://www.postgresql.org/docs/current/sql-fetch.html) for+more information.++@since 1.0.0.0+-}+fetchAll :: CursorDirection+fetchAll =+  CursorDirection . RawSql.fromString $ "ALL"++{- | Specify the direction of the next single row. Primarily for use with+    'fetch' or 'move'.++See PostgreSQL [fetch documentation](https://www.postgresql.org/docs/current/sql-fetch.html) for+more information.++@since 1.0.0.0+-}+forward :: CursorDirection+forward =+  CursorDirection . RawSql.fromString $ "FORWARD"++{- | Specify the direction of the next n rows. Primarily for use with 'fetch'+    or 'move'.++See PostgreSQL [fetch documentation](https://www.postgresql.org/docs/current/sql-fetch.html) for+more information.++@since 1.0.0.0+-}+forwardCount :: Int -> CursorDirection+forwardCount countParam =+  -- postgresql won't let us pass the count as a parameter.+  -- when we try we get an error like such error:+  --  ERROR:  syntax error at or near "$1"+  --  LINE 1: FETCH FORWARD $1 \"testcursor\"+  CursorDirection $+    RawSql.fromString "FORWARD "+      <> RawSql.intDecLiteral countParam++{- | Specify the direction of all the next rows. Primarily for use with 'fetch'+    or 'move'.++See PostgreSQL [fetch documentation](https://www.postgresql.org/docs/current/sql-fetch.html) for+more information.++@since 1.0.0.0+-}+forwardAll :: CursorDirection+forwardAll =+  CursorDirection . RawSql.fromString $ "FORWARD ALL"++{- | Specify the direction of the prior single row. Primarily for use with+    'fetch' or 'move'.++See PostgreSQL [fetch documentation](https://www.postgresql.org/docs/current/sql-fetch.html) for+more information.++@since 1.0.0.0+-}+backward :: CursorDirection+backward =+  CursorDirection . RawSql.fromString $ "BACKWARD"++{- | Specify the direction of the prior n rows. Primarily for use with 'fetch'+    or 'move'.++See PostgreSQL [fetch documentation](https://www.postgresql.org/docs/current/sql-fetch.html) for+more information.++@since 1.0.0.0+-}+backwardCount :: Int -> CursorDirection+backwardCount countParam =+  -- postgresql won't let us pass the count as a parameter.+  -- when we try we get an error like such error:+  --  ERROR:  syntax error at or near "$1"+  --  LINE 1: FETCH BACKWARD $1 \"testcursor\"+  CursorDirection $+    RawSql.fromString "BACKWARD "+      <> RawSql.intDecLiteral countParam++{- | Specify the direction of all the prior rows. Primarily for use with+    'fetch' or 'move'.++See PostgreSQL [fetch documentation](https://www.postgresql.org/docs/current/sql-fetch.html) for+more information.++@since 1.0.0.0+-}+backwardAll :: CursorDirection+backwardAll =+  CursorDirection . RawSql.fromString $ "BACKWARD ALL"
+ src/Orville/PostgreSQL/Expr/DataType.hs view
@@ -0,0 +1,262 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Expr.DataType+  ( DataType+  , timestampWithZone+  , timestampWithoutZone+  , date+  , tsvector+  , varchar+  , char+  , text+  , uuid+  , boolean+  , doublePrecision+  , bigSerial+  , bigInt+  , serial+  , int+  , smallint+  , jsonb+  , oid+  )+where++import Data.Int (Int32)++import qualified Orville.PostgreSQL.Raw.RawSql as RawSql++{- |+Type to represent any SQL data type expression. E.G.++  > INTEGER++'DataType' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype DataType+  = DataType RawSql.RawSql+  deriving+    ( -- | @since 1.0.0.0+      RawSql.SqlExpression+    )++{- | A 'DataType' that represents the PostgreSQL "TIMESTAMP with time zone" data type.++See [postgresql documentation](https://www.postgresql.org/docs/current/datatype-datetime.html) for+more information.++@since 1.0.0.0+-}+timestampWithZone :: DataType+timestampWithZone =+  DataType (RawSql.fromString "TIMESTAMP with time zone")++{- | A 'DataType' that represents the PostgreSQL "TIMESTAMP without time zone" data type.++See [postgresql documentation](https://www.postgresql.org/docs/current/datatype-datetime.html) for+more information.++@since 1.0.0.0+-}+timestampWithoutZone :: DataType+timestampWithoutZone =+  DataType (RawSql.fromString "TIMESTAMP without time zone")++{- | A 'DataType' that represents the PostgreSQL "DATE" data type.++See [postgresql documentation](https://www.postgresql.org/docs/current/datatype-datetime.html) for+more information.++@since 1.0.0.0+-}+date :: DataType+date =+  DataType (RawSql.fromString "DATE")++{- | A 'DataType' that represents the PostgreSQL "TSVECTOR" data type.++See [postgresql+documentation](https://www.postgresql.org/docs/current/datatype-textsearch.html#DATATYPE-TSVECTOR)+for more information.++@since 1.0.0.0+-}+tsvector :: DataType+tsvector =+  DataType (RawSql.fromString "TSVECTOR")++{- | A 'DataType' that represents the PostgreSQL "VARCHAR(n)" data type.++See [postgresql documentation](https://www.postgresql.org/docs/current/datatype-character.html) for+more information.++@since 1.0.0.0+-}+varchar :: Int32 -> DataType+varchar len =+  -- postgresql won't let us pass the field length as a parameter.+  -- when we try we get an error like such error:+  --  ERROR:  syntax error at or near "$1" at character 48+  --  STATEMENT:  CREATE TABLE field_definition_test(foo VARCHAR($1))+  DataType $+    RawSql.fromString "VARCHAR("+      <> RawSql.int32DecLiteral len+      <> RawSql.fromString ")"++{- | A 'DataType' that represents the PostgreSQL "CHAR(n)" data type.++See [postgresql documentation](https://www.postgresql.org/docs/current/datatype-character.html) for+more information.++@since 1.0.0.0+-}+char :: Int32 -> DataType+char len =+  -- postgresql won't let us pass the field length as a parameter.+  -- when we try, we get an error like such:+  --  ERROR:  syntax error at or near "$1" at character 48+  --  STATEMENT:  CREATE TABLE field_definition_test(foo CHAR($1))+  DataType $+    RawSql.fromString "CHAR("+      <> RawSql.int32DecLiteral len+      <> RawSql.fromString ")"++{- | A 'DataType' that represents the PostgreSQL "TEXT" data type.++See [postgresql documentation](https://www.postgresql.org/docs/current/datatype-character.html) for+more information.++@since 1.0.0.0+-}+text :: DataType+text =+  DataType (RawSql.fromString "TEXT")++{- | A 'DataType' that represents the PostgreSQL "UUID" data type.++See [postgresql documentation](https://www.postgresql.org/docs/current/datatype-uuid.html) for more+information.++@since 1.0.0.0+-}+uuid :: DataType+uuid =+  DataType (RawSql.fromString "UUID")++{- | A 'DataType' that represents the PostgreSQL "BOOLEAN" data type.++See [postgresql documentation](https://www.postgresql.org/docs/current/datatype-boolean.html) for+more information.++@since 1.0.0.0+-}+boolean :: DataType+boolean =+  DataType (RawSql.fromString "BOOLEAN")++{- | A 'DataType' that represents the PostgreSQL "DOUBLE PRECISION" data type.++See [postgresql+documentation](https://www.postgresql.org/docs/current/datatype-numeric.html#DATATYPE-FLOAT) for+more information.++@since 1.0.0.0+-}+doublePrecision :: DataType+doublePrecision =+  DataType (RawSql.fromString "DOUBLE PRECISION")++{- | A 'DataType' that represents the PostgreSQL "BIGSERIAL" data type.++See [postgresql+documentation](https://www.postgresql.org/docs/current/datatype-numeric.html#DATATYPE-SERIAL) for+more information.++@since 1.0.0.0+-}+bigSerial :: DataType+bigSerial =+  DataType (RawSql.fromString "BIGSERIAL")++{- | A 'DataType' that represents the PostgreSQL "BIGINT" data type.++See [postgresql+documentation](https://www.postgresql.org/docs/current/datatype-numeric.html#DATATYPE-INT) for+more information.++@since 1.0.0.0+-}+bigInt :: DataType+bigInt =+  DataType (RawSql.fromString "BIGINT")++{- | A 'DataType' that represents the PostgreSQL "SERIAL" data type.++See [postgresql+documentation](https://www.postgresql.org/docs/current/datatype-numeric.html#DATATYPE-SERIAL) for+more information.++@since 1.0.0.0+-}+serial :: DataType+serial =+  DataType (RawSql.fromString "SERIAL")++{- | A 'DataType' that represents the PostgreSQL "INT" data type.++See [postgresql+documentation](https://www.postgresql.org/docs/current/datatype-numeric.html#DATATYPE-INT) for+more information.++@since 1.0.0.0+-}+int :: DataType+int =+  DataType (RawSql.fromString "INT")++{- | A 'DataType' that represents the PostgreSQL "SMALLINT" data type.++See [postgresql+documentation](https://www.postgresql.org/docs/current/datatype-numeric.html#DATATYPE-INT) for+more information.++@since 1.0.0.0+-}+smallint :: DataType+smallint =+  DataType (RawSql.fromString "SMALLINT")++{- |+  A 'DataType' that represents the PostgreSQL "JSONB" data type.++See [postgresql documentation](https://www.postgresql.org/docs/current/datatype-json.html) for more+information.++@since 1.0.0.0+-}+jsonb :: DataType+jsonb =+  DataType (RawSql.fromString "JSONB")++{- | A 'DataType' that represents the PostgreSQL "OID" data type.++See [postgresql+documentation](https://www.postgresql.org/docs/current/datatype-oid.html) for+more information.++@since 1.0.0.0+-}+oid :: DataType+oid =+  DataType (RawSql.fromString "OID")
+ src/Orville/PostgreSQL/Expr/Delete.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++Provides a type representing SQL DELETE and construction of that type.++@since 1.0.0.0+-}+module Orville.PostgreSQL.Expr.Delete+  ( DeleteExpr+  , deleteExpr+  )+where++import Data.Maybe (catMaybes)++import Orville.PostgreSQL.Expr.Name (Qualified, 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.++> DELETE FROM foo WHERE id < 10++'DeleteExpr' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype DeleteExpr+  = DeleteExpr RawSql.RawSql+  deriving+    ( -- | @since 1.0.0.0+      RawSql.SqlExpression+    )++{- |++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 ->+  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+        ]
+ src/Orville/PostgreSQL/Expr/GroupBy.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Expr.GroupBy+  ( GroupByClause+  , groupByClause+  , GroupByExpr+  , appendGroupByExpr+  , groupByColumnsExpr+  )+where++import Data.List.NonEmpty (NonEmpty)++import Orville.PostgreSQL.Expr.Name (ColumnName)+import qualified Orville.PostgreSQL.Raw.RawSql as RawSql++{- |+Type to represent a SQL group by clause. E.G.++> GROUP BY team_name++'GroupByClause' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype GroupByClause+  = GroupByClause RawSql.RawSql+  deriving+    ( -- | @since 1.0.0.0+      RawSql.SqlExpression+    )++{- | Create a full SQL GROUP BY clause with the given expression.++@since 1.0.0.0+-}+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+@GROUP BY@ in SQL). E.G.++> team_name++'GroupByExpr' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype GroupByExpr+  = GroupByExpr RawSql.RawSql+  deriving+    ( -- | @since 1.0.0.0+      RawSql.SqlExpression+    )++{- |+@since 1.0.0.0+-}+instance Semigroup GroupByExpr where+  (<>) = appendGroupByExpr++{- | Combines two 'GroupByExpr's with a comma between them.++@since 1.0.0.0+-}+appendGroupByExpr :: GroupByExpr -> GroupByExpr -> GroupByExpr+appendGroupByExpr (GroupByExpr a) (GroupByExpr b) =+  GroupByExpr (a <> RawSql.commaSpace <> b)++{- | Create a 'GroupByExpr' from the given 'ColumnName's.++@since 1.0.0.0+-}+groupByColumnsExpr :: NonEmpty ColumnName -> GroupByExpr+groupByColumnsExpr =+  GroupByExpr . RawSql.intercalate RawSql.commaSpace
+ src/Orville/PostgreSQL/Expr/IfExists.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Expr.IfExists+  ( IfExists+  , ifExists+  )+where++import qualified Orville.PostgreSQL.Raw.RawSql as RawSql++{- |+Type to represent a SQL "IF EXISTS" expression. E.G.++> IF EXISTS++'IfExists' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype IfExists+  = IfExists RawSql.RawSql+  deriving+    ( -- | @since 1.0.0.0+      RawSql.SqlExpression+    )++{- |+A value of the SQL "IF EXISTS".++@since 1.0.0.0+-}+ifExists :: IfExists+ifExists =+  IfExists $ RawSql.fromString "IF EXISTS"
+ src/Orville/PostgreSQL/Expr/Index.hs view
@@ -0,0 +1,211 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Expr.Index+  ( CreateIndexExpr+  , createIndexExpr+  , IndexUniqueness (UniqueIndex, NonUniqueIndex)+  , IndexBodyExpr+  , indexBodyColumns+  , ConcurrentlyExpr+  , concurrently+  , DropIndexExpr+  , dropIndexExpr+  , createNamedIndexExpr+  )+where++import Data.List.NonEmpty (NonEmpty)++import Orville.PostgreSQL.Expr.Name (ColumnName, IndexName, Qualified, TableName)+import qualified Orville.PostgreSQL.Raw.RawSql as RawSql++{- |+Type to represent a SQL "CREATE INDEX" statement. E.G.++> CREATE INDEX ON table (foo, bar, baz)++'CreateIndexExpr' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype CreateIndexExpr+  = CreateIndexExpr RawSql.RawSql+  deriving+    ( -- | @since 1.0.0.0+      RawSql.SqlExpression+    )++{- |+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+-}+createIndexExpr ::+  IndexUniqueness ->+  Maybe ConcurrentlyExpr ->+  Qualified TableName ->+  NonEmpty ColumnName ->+  CreateIndexExpr+createIndexExpr uniqueness mbConcurrently tableName columns =+  CreateIndexExpr $+    RawSql.fromString "CREATE "+      <> uniquenessToSql uniqueness+      <> RawSql.fromString "INDEX "+      <> maybe mempty (<> RawSql.space) (fmap 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+unique, a table, a name for the index, and some SQL representing the rest of+the index creation.++@since 1.0.0.0+-}+createNamedIndexExpr ::+  IndexUniqueness ->+  Maybe ConcurrentlyExpr ->+  Qualified TableName ->+  IndexName ->+  IndexBodyExpr ->+  CreateIndexExpr+createNamedIndexExpr uniqueness mbConcurrently tableName indexName bodyExpr =+  CreateIndexExpr $+    RawSql.fromString "CREATE "+      <> uniquenessToSql uniqueness+      <> RawSql.fromString "INDEX "+      <> maybe mempty (<> RawSql.space) (fmap 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.++> CONCURRENTLY++'ConcurrentlyExpr' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype ConcurrentlyExpr+  = ConcurrentlyExpr RawSql.RawSql+  deriving+    ( -- | @since 1.0.0.0+      RawSql.SqlExpression+    )++{- |+The @CONCURRENTLY@ keyword indicates to PostgreSQL that an index should be+created concurrently.++@since 1.0.0.0+-}+concurrently :: ConcurrentlyExpr+concurrently =+  RawSql.unsafeSqlExpression "CONCURRENTLY"++{- |+Type to represent the body of an index definition E.G.++> (foo, bar)++in++> CREATE some_index ON some_table (foo, bar)++'IndexBodyExpr' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype IndexBodyExpr+  = IndexBodyExpr RawSql.RawSql+  deriving+    ( -- | @since 1.0.0.0+      RawSql.SqlExpression+    )++{- |+Creates an 'IndexBodyExpr' for the given column names. The resulting+SQL looks like @(column1, column2, ...)@.++@since 1.0.0.0+-}+indexBodyColumns ::+  NonEmpty ColumnName ->+  IndexBodyExpr+indexBodyColumns columns =+  IndexBodyExpr $+    RawSql.leftParen+      <> RawSql.intercalate RawSql.comma columns+      <> RawSql.rightParen++{- |+Type to represent if an index should be unique.++@since 1.0.0.0+-}+data IndexUniqueness+  = UniqueIndex+  | NonUniqueIndex+  deriving+    ( -- | @since 1.0.0.0+      Eq+    , -- | @since 1.0.0.0+      Ord+    , -- | @since 1.0.0.0+      Show+    )++-- Internal helper+uniquenessToSql :: IndexUniqueness -> RawSql.RawSql+uniquenessToSql uniqueness =+  case uniqueness of+    UniqueIndex -> RawSql.fromString "UNIQUE "+    NonUniqueIndex -> mempty++{- |+Type to represent a SQL "DROP INDEX" statement. E.G.++> DROP INDEX foo++'DropIndexExpr' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype DropIndexExpr+  = DropIndexExpr RawSql.RawSql+  deriving+    ( -- | @since 1.0.0.0+      RawSql.SqlExpression+    )++{- |+Construct a SQL DROP INDEX for a given 'IndexName'.++@since 1.0.0.0+-}+dropIndexExpr :: IndexName -> DropIndexExpr+dropIndexExpr indexName =+  DropIndexExpr $+    RawSql.fromString "DROP INDEX " <> RawSql.toRawSql indexName
+ src/Orville/PostgreSQL/Expr/Insert.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Expr.Insert+  ( InsertExpr+  , insertExpr+  , InsertColumnList+  , insertColumnList+  , InsertSource+  , insertSqlValues+  , RowValues+  , rowValues+  )+where++import Data.Maybe (catMaybes)++import Orville.PostgreSQL.Expr.Name (ColumnName, Qualified, TableName)+import Orville.PostgreSQL.Expr.ReturningExpr (ReturningExpr)+import qualified Orville.PostgreSQL.Raw.RawSql as RawSql+import Orville.PostgreSQL.Raw.SqlValue (SqlValue)++{- |+Type to represent a SQL "INSERT" statement. E.G.++> INSERT INTO foo (id) VALUES (1),(3),(3)++'InsertExpr' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype InsertExpr+  = InsertExpr RawSql.RawSql+  deriving+    ( -- | @since 1.0.0.0+      RawSql.SqlExpression+    )++{- | Create an 'InsertExpr' for the given 'TableName', limited to the specific columns if+given. Callers of this likely want to use a function to create the 'InsertSource' to ensure the+input values are correctly used as parameters. This function does not include that protection+itself.++@since 1.0.0.0+-}+insertExpr ::+  Qualified TableName ->+  Maybe InsertColumnList ->+  InsertSource ->+  Maybe ReturningExpr ->+  InsertExpr+insertExpr target maybeInsertColumns source maybeReturning =+  InsertExpr+    . RawSql.intercalate RawSql.space+    $ catMaybes+      [ Just $ RawSql.fromString "INSERT INTO"+      , Just $ RawSql.toRawSql target+      , fmap RawSql.toRawSql maybeInsertColumns+      , Just $ RawSql.toRawSql source+      , fmap RawSql.toRawSql maybeReturning+      ]++{- |+Type to represent the SQL columns list for an insert statement. E.G.++> (foo,bar,baz)++'InsertColumnList' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype InsertColumnList+  = InsertColumnList RawSql.RawSql+  deriving+    ( -- | @since 1.0.0.0+      RawSql.SqlExpression+    )++{- | Create an 'InsertColumnList' for the given 'ColumnName's, making sure the columns are wrapped in+parens and commas are used to separate.++@since 1.0.0.0+-}+insertColumnList :: [ColumnName] -> InsertColumnList+insertColumnList columnNames =+  InsertColumnList $+    RawSql.leftParen+      <> RawSql.intercalate RawSql.comma (fmap RawSql.toRawSql columnNames)+      <> RawSql.rightParen++{- |+Type to represent the SQL for the source of data for an insert statement. E.G.++> VALUES ('Bob',32),('Cindy',33)++'InsertSource' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype InsertSource+  = InsertSource RawSql.RawSql+  deriving+    ( -- | @since 1.0.0.0+      RawSql.SqlExpression+    )++{- | Create an 'InsertSource' for the given 'RowValues'. This ensures that all input values are used+as parameters and comma-separated in the generated SQL.++@since 1.0.0.0+-}+insertRowValues :: [RowValues] -> InsertSource+insertRowValues rows =+  InsertSource $+    RawSql.fromString "VALUES "+      <> RawSql.intercalate RawSql.comma (fmap RawSql.toRawSql rows)++{- | 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.++@since 1.0.0.0+-}+insertSqlValues :: [[SqlValue]] -> InsertSource+insertSqlValues =+  insertRowValues . fmap rowValues++{- |+Type to represent a SQL row literal. For example, a single row to insert+in a @VALUES@ clause. E.G.++> ('Cindy',33)++'RowValues' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype RowValues+  = RowValues RawSql.RawSql+  deriving+    ( -- | @since 1.0.0.0+      RawSql.SqlExpression+    )++{- | Create a 'RowValues' for the given 'SqlValue's. This ensures that all input values are used as+parameters and comma-separated in the generated SQL.++@since 1.0.0.0+-}+rowValues :: [SqlValue] -> RowValues+rowValues values =+  RowValues $+    mconcat+      [ RawSql.leftParen+      , RawSql.intercalate RawSql.comma (fmap RawSql.parameter values)+      , RawSql.rightParen+      ]
+ src/Orville/PostgreSQL/Expr/Internal/Name/ColumnName.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Expr.Internal.Name.ColumnName+  ( ColumnName+  , columnName+  )+where++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+'columnName' function will be properly escaped as part of the generated SQL. E.G.++> "some_column_name"++'ColumnName' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype ColumnName+  = ColumnName Identifier+  deriving+    ( -- | @since 1.0.0.0+      RawSql.SqlExpression+    , -- | @since 1.0.0.0+      IdentifierExpression+    )++{- |+Construct a 'ColumnName' from a 'String' with proper escaping as part of the generated SQL.++@since 1.0.0.0+-}+columnName :: String -> ColumnName+columnName = ColumnName . identifier
+ src/Orville/PostgreSQL/Expr/Internal/Name/ConstraintName.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Expr.Internal.Name.ConstraintName+  ( ConstraintName+  , constraintName+  )+where++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+via the 'constraintName' function will be properly escaped as part of the+generated SQL. E.G.++> "some_constraint_name"++'ConstraintName' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype ConstraintName+  = ConstraintName Identifier+  deriving+    ( -- | @since 1.0.0.0+      RawSql.SqlExpression+    , -- | @since 1.0.0.0+      IdentifierExpression+    )++{- |+Construct a 'ConstraintName' from a 'String' with proper escaping as part of the generated SQL.++@since 1.0.0.0+-}+constraintName :: String -> ConstraintName+constraintName = ConstraintName . identifier
+ src/Orville/PostgreSQL/Expr/Internal/Name/CursorName.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Expr.Internal.Name.CursorName+  ( CursorName+  , cursorName+  )+where++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+via the 'cursorName' function will be properly escaped as part of the+generated SQL. E.G.++> "some_cursor_name"++'CursorName' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype CursorName+  = CursorName Identifier+  deriving+    ( -- | @since 1.0.0.0+      RawSql.SqlExpression+    , -- | @since 1.0.0.0+      IdentifierExpression+    )++{- |+Construct a 'CursorName' from a 'String' with proper escaping as part of the generated SQL.++@since 1.0.0.0+-}+cursorName :: String -> CursorName+cursorName =+  CursorName . identifier
+ src/Orville/PostgreSQL/Expr/Internal/Name/FunctionName.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Expr.Internal.Name.FunctionName+  ( FunctionName+  , functionName+  )+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+via the 'functionName' function will be properly escaped as part of the+generated SQL. E.G.++> "some_function_name"++'FunctionName' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype FunctionName+  = FunctionName Identifier+  deriving+    ( -- | @since 1.0.0.0+      RawSql.SqlExpression+    , -- | @since 1.0.0.0+      IdentifierExpression+    )++{- |+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
+ src/Orville/PostgreSQL/Expr/Internal/Name/Identifier.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Expr.Internal.Name.Identifier+  ( Identifier+  , identifier+  , identifierFromBytes+  , IdentifierExpression (toIdentifier, fromIdentifier)+  )+where++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+'identifier' function will be properly escaped as part of the generated SQL.+E.G.++> "some_identifier"++'Identifier' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype Identifier+  = Identifier RawSql.RawSql+  deriving+    ( -- | @since 1.0.0.0+      RawSql.SqlExpression+    )++{- |+Construct an 'Identifier' from a 'String' with proper escaping as part of the generated SQL.++@since 1.0.0.0+-}+identifier :: String -> Identifier+identifier =+  identifierFromBytes . B8.pack++{- |+Construct an 'Identifier' from a 'B8.ByteString' with proper escaping as part of the generated SQL.++@since 1.0.0.0+-}+identifierFromBytes :: B8.ByteString -> Identifier+identifierFromBytes =+  Identifier . RawSql.identifier++{- | This class aids in giving additional polymorphism so that many different identifiers can be+created without being forced to only use the `Identifier` type.++@since 1.0.0.0+-}+class IdentifierExpression name where+  -- | @since 1.0.0.0+  toIdentifier :: name -> Identifier++  -- | @since 1.0.0.0+  fromIdentifier :: Identifier -> name++{- |++@since 1.0.0.0+-}+instance IdentifierExpression Identifier where+  toIdentifier = id+  fromIdentifier = id
+ src/Orville/PostgreSQL/Expr/Internal/Name/IndexName.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Expr.Internal.Name.IndexName+  ( IndexName+  , indexName+  )+where++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+'indexName' function will be properly escaped as part of the generated SQL. E.G.++> "some_index_name"++'IndexName' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype IndexName+  = IndexName Identifier+  deriving+    ( -- | @since 1.0.0.0+      RawSql.SqlExpression+    , -- | @since 1.0.0.0+      IdentifierExpression+    )++{- |+Construct an 'IndexName' from a 'String' with proper escaping as part of the generated SQL.++@since 1.0.0.0+-}+indexName :: String -> IndexName+indexName = IndexName . identifier
+ src/Orville/PostgreSQL/Expr/Internal/Name/Qualified.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Expr.Internal.Name.Qualified+  ( Qualified+  , qualifyTable+  , qualifySequence+  , qualifyColumn+  )+where++import Orville.PostgreSQL.Expr.Internal.Name.ColumnName (ColumnName)+import Orville.PostgreSQL.Expr.Internal.Name.Identifier (IdentifierExpression (toIdentifier))+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.++> "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.++@since 1.0.0.0+-}+newtype Qualified name+  = Qualified RawSql.RawSql+  deriving+    ( -- | @since 1.0.0.0+      RawSql.SqlExpression+    )++{- |+Optionally qualifies a 'TableName' with a 'SchemaName'.++Note: If you already have a 'Orville.PostgreSQL.Schema.TableIdentifier' in+hand you should probably use+'Orville.PostgreSQL.Schema.tableIdQualifiedName' instead.+@since 1.0.0.0+-}+qualifyTable ::+  Maybe SchemaName ->+  TableName ->+  Qualified TableName+qualifyTable = unsafeSchemaQualify++{- |+Optionally qualifies a 'SequenceName' with a 'SchemaName'.++Note: If you already have a 'Orville.PostgreSQL.Schema.SequenceIdentifier' in+hand you should probably use+'Orville.PostgreSQL.Schema.sequenceIdQualifiedName' instead.++@since 1.0.0.0+-}+qualifySequence ::+  Maybe SchemaName ->+  SequenceName ->+  Qualified SequenceName+qualifySequence = 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.++@since 1.0.0.0+-}+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)++-- 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 ->+  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)+        )
+ src/Orville/PostgreSQL/Expr/Internal/Name/SavepointName.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Expr.Internal.Name.SavepointName+  ( SavepointName+  , savepointName+  )+where++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+the 'savepointName' function will be properly escaped as part of the generated+SQL. E.G.++> "some_savepoint_name"++'SavepointName' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype SavepointName+  = SavepointName Identifier+  deriving+    ( -- | @since 1.0.0.0+      RawSql.SqlExpression+    , -- | @since 1.0.0.0+      IdentifierExpression+    )++{- |+Construct a 'SavepointName' from a 'String' with proper escaping as part of the generated SQL.++@since 1.0.0.0+-}+savepointName :: String -> SavepointName+savepointName = SavepointName . identifier
+ src/Orville/PostgreSQL/Expr/Internal/Name/SchemaName.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Expr.Internal.Name.SchemaName+  ( SchemaName+  , schemaName+  )+where++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+'schemaName' function will be properly escaped as part of the generated SQL.+E.G.++> "some_schema_name"++'SchemaName' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype SchemaName+  = SchemaName Identifier+  deriving+    ( -- | @since 1.0.0.0+      RawSql.SqlExpression+    , -- | @since 1.0.0.0+      IdentifierExpression+    )++{- |+Construct a 'SchemaName' from a 'String' with proper escaping as part of the generated SQL.++@since 1.0.0.0+-}+schemaName :: String -> SchemaName+schemaName =+  SchemaName . identifier
+ src/Orville/PostgreSQL/Expr/Internal/Name/SequenceName.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Expr.Internal.Name.SequenceName+  ( SequenceName+  , sequenceName+  )+where++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+the 'sequenceName' function will be properly escaped as part of the generated+SQL. E.G.++> "some_sequence_name"++'SequenceName' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype SequenceName+  = SequenceName Identifier+  deriving+    ( -- | @since 1.0.0.0+      RawSql.SqlExpression+    , -- | @since 1.0.0.0+      IdentifierExpression+    )++{- |+Construct a 'SequenceName' from a 'String' with proper escaping as part of the generated SQL.++@since 1.0.0.0+-}+sequenceName :: String -> SequenceName+sequenceName =+  SequenceName . identifier
+ src/Orville/PostgreSQL/Expr/Internal/Name/TableName.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Expr.Internal.Name.TableName+  ( TableName+  , tableName+  )+where++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+'tableName' function will be properly escaped as part of the generated SQL.+E.G.++> "some_table_name"++'TableName' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype TableName+  = TableName Identifier+  deriving+    ( -- | @since 1.0.0.0+      RawSql.SqlExpression+    , -- | @since 1.0.0.0+      IdentifierExpression+    )++{- |+Construct a 'TableName' from a 'String' with proper escaping as part of the generated SQL.++@since 1.0.0.0+-}+tableName :: String -> TableName+tableName =+  TableName . identifier
+ src/Orville/PostgreSQL/Expr/LimitExpr.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Expr.LimitExpr+  ( LimitExpr+  , limitExpr+  )+where++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.++> LIMIT 10++'LimitExpr' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype LimitExpr+  = LimitExpr RawSql.RawSql+  deriving+    ( -- | @since 1.0.0.0+      RawSql.SqlExpression+    )++{- | Create a 'LimitExpr' for the given 'Int'. This ensures that the input value is used+as a parameter in the generated SQL.++@since 1.0.0.0+-}+limitExpr :: Int -> LimitExpr+limitExpr limitValue =+  LimitExpr $+    RawSql.fromString "LIMIT "+      <> RawSql.parameter (SqlValue.fromInt limitValue)
+ src/Orville/PostgreSQL/Expr/Math.hs view
@@ -0,0 +1,123 @@+{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Expr.Math+  ( plus+  , minus+  , multiply+  , divide+  , modulo+  , exponentiate+  , bitwiseAnd+  , bitwiseOr+  , bitwiseXor+  , bitwiseShiftLeft+  , bitwiseShiftRight+  )+where++import Orville.PostgreSQL.Expr.BinaryOperator (binaryOpExpression, bitwiseAndOp, bitwiseOrOp, bitwiseShiftLeftOp, bitwiseShiftRightOp, bitwiseXorOp, divisionOp, exponentiationOp, minusOp, moduloOp, multiplicationOp, plusOp)+import Orville.PostgreSQL.Expr.ValueExpression (ValueExpression)++{- | Apply a SQL + to the 'ValueExpression's. It is left to the caller to ensure that the operator+ makes sense with the arguments being passed.++@since 1.0.0.0+-}+plus :: ValueExpression -> ValueExpression -> ValueExpression+plus =+  binaryOpExpression plusOp++{- | Apply a SQL - to the 'ValueExpression's. It is left to the caller to ensure that the operator+ makes sense with the arguments being passed.++@since 1.0.0.0+-}+minus :: ValueExpression -> ValueExpression -> ValueExpression+minus =+  binaryOpExpression minusOp++{- | Apply a SQL * to the 'ValueExpression's. It is left to the caller to ensure that the operator+ makes sense with the arguments being passed.++@since 1.0.0.0+-}+multiply :: ValueExpression -> ValueExpression -> ValueExpression+multiply =+  binaryOpExpression multiplicationOp++{- | Apply a SQL / to the 'ValueExpression's. It is left to the caller to ensure that the operator+ makes sense with the arguments being passed.++@since 1.0.0.0+-}+divide :: ValueExpression -> ValueExpression -> ValueExpression+divide =+  binaryOpExpression divisionOp++{- | Apply a SQL % to the 'ValueExpression's. It is left to the caller to ensure that the operator+ makes sense with the arguments being passed.++@since 1.0.0.0+-}+modulo :: ValueExpression -> ValueExpression -> ValueExpression+modulo =+  binaryOpExpression moduloOp++{- | Apply a SQL ^ to the 'ValueExpression's. It is left to the caller to ensure that the operator+ makes sense with the arguments being passed.++@since 1.0.0.0+-}+exponentiate :: ValueExpression -> ValueExpression -> ValueExpression+exponentiate =+  binaryOpExpression exponentiationOp++{- | Apply a SQL & to the 'ValueExpression's. It is left to the caller to ensure that the operator+ makes sense with the arguments being passed.++@since 1.0.0.0+-}+bitwiseAnd :: ValueExpression -> ValueExpression -> ValueExpression+bitwiseAnd =+  binaryOpExpression bitwiseAndOp++{- | Apply a SQL | to the 'ValueExpression's. It is left to the caller to ensure that the operator+ makes sense with the arguments being passed.++@since 1.0.0.0+-}+bitwiseOr :: ValueExpression -> ValueExpression -> ValueExpression+bitwiseOr =+  binaryOpExpression bitwiseOrOp++{- | Apply a SQL # to the 'ValueExpression's. It is left to the caller to ensure that the operator+ makes sense with the arguments being passed.++@since 1.0.0.0+-}+bitwiseXor :: ValueExpression -> ValueExpression -> ValueExpression+bitwiseXor =+  binaryOpExpression bitwiseXorOp++{- | Apply a SQL << to the 'ValueExpression's. It is left to the caller to ensure that the operator+ makes sense with the arguments being passed.++@since 1.0.0.0+-}+bitwiseShiftLeft :: ValueExpression -> ValueExpression -> ValueExpression+bitwiseShiftLeft =+  binaryOpExpression bitwiseShiftLeftOp++{- | Apply a SQL >> to the 'ValueExpression's. It is left to the caller to ensure that the operator+ makes sense with the arguments being passed.++@since 1.0.0.0+-}+bitwiseShiftRight :: ValueExpression -> ValueExpression -> ValueExpression+bitwiseShiftRight =+  binaryOpExpression bitwiseShiftRightOp
+ src/Orville/PostgreSQL/Expr/Name.hs view
@@ -0,0 +1,25 @@+{-# OPTIONS_GHC -Wno-missing-import-lists #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Expr.Name+  ( module Export+  )+where++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.FunctionName as Export+import Orville.PostgreSQL.Expr.Internal.Name.Identifier as Export+import Orville.PostgreSQL.Expr.Internal.Name.IndexName as Export+import Orville.PostgreSQL.Expr.Internal.Name.Qualified as Export+import Orville.PostgreSQL.Expr.Internal.Name.SavepointName as Export+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
+ src/Orville/PostgreSQL/Expr/OffsetExpr.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Expr.OffsetExpr+  ( OffsetExpr+  , offsetExpr+  )+where++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.++> OFFSET 10++'OffsetExpr' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype OffsetExpr+  = OffsetExpr RawSql.RawSql+  deriving+    ( -- | @since 1.0.0.0+      RawSql.SqlExpression+    )++{- | Create an 'OffsetExpr' for the given 'Int'. This ensures that the input value is used+as a parameter in the generated SQL.++@since 1.0.0.0+-}+offsetExpr :: Int -> OffsetExpr+offsetExpr offsetValue =+  OffsetExpr $+    RawSql.fromString "OFFSET " <> RawSql.parameter (SqlValue.fromInt offsetValue)
+ src/Orville/PostgreSQL/Expr/OrderBy.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Expr.OrderBy+  ( OrderByClause+  , orderByClause+  , OrderByExpr+  , appendOrderByExpr+  , orderByColumnName+  , orderByColumnsExpr+  , OrderByDirection+  , NullsOrder (NullsFirst, NullsLast)+  , ascendingOrder+  , descendingOrder+  , ascendingOrderWith+  , descendingOrderWith+  )+where++import qualified Data.List.NonEmpty as NEL++import Orville.PostgreSQL.Expr.Name (ColumnName)+import qualified Orville.PostgreSQL.Raw.RawSql as RawSql++{- |+Type to represent a SQL order by clause. E.G.++> ORDER BY foo, bar++'OrderByClause' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype OrderByClause+  = OrderByClause RawSql.RawSql+  deriving (RawSql.SqlExpression)++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+BY@ in SQL). E.G.++> foo, bar++'OrderByExpr' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype OrderByExpr = OrderByExpr RawSql.RawSql+  deriving+    ( -- | @since 1.0.0.0+      RawSql.SqlExpression+    )++{- |+@since 1.0.0.0+-}+instance Semigroup OrderByExpr where+  (<>) = appendOrderByExpr++{- | Combines two 'OrderByExpr's with a comma between them.++@since 1.0.0.0+-}+appendOrderByExpr :: OrderByExpr -> OrderByExpr -> OrderByExpr+appendOrderByExpr (OrderByExpr a) (OrderByExpr b) =+  OrderByExpr (a <> RawSql.commaSpace <> b)++{- | Create an 'OrderByExpr' for 'ColumnName' and 'OrderByDirection' pairs, ensuring commas as+  needed.++@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++{-- |+  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)++{- |+Type to represent a SQL order by direction expression. E.G.++> ASC++'OrderByDirection' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype OrderByDirection = OrderByDirection RawSql.RawSql+  deriving (RawSql.SqlExpression)++{- |+Type to represent the ordering of Null, intended to be used with 'OrderByDirection'.++@since 1.0.0.0+-}+data NullsOrder+  = NullsFirst+  | NullsLast+  deriving+    ( -- | @since 1.0.0.0+      Eq+    , -- | @since 1.0.0.0+      Show+    , -- | @since 1.0.0.0+      Ord+    , -- | @since 1.0.0.0+      Enum+    , -- | @since 1.0.0.0+      Bounded+    )++{- | The SQL ASC order direction.++@since 1.0.0.0+-}+ascendingOrder :: OrderByDirection+ascendingOrder = OrderByDirection $ RawSql.fromString "ASC"++{- | The SQL DESC order direction.++@since 1.0.0.0+-}+descendingOrder :: OrderByDirection+descendingOrder = OrderByDirection $ RawSql.fromString "DESC"++{- | The SQL ASC order direction with NULLs ordered as given.++@since 1.0.0.0+-}+ascendingOrderWith :: NullsOrder -> OrderByDirection+ascendingOrderWith no =+  OrderByDirection $ RawSql.toRawSql ascendingOrder <> RawSql.space <> nullsOrder no++{- | The SQL DESC order direction with NULLs ordered as given.++@since 1.0.0.0+-}+descendingOrderWith :: NullsOrder -> OrderByDirection+descendingOrderWith no =+  OrderByDirection $ RawSql.toRawSql descendingOrder <> RawSql.space <> nullsOrder no++nullsOrder :: NullsOrder -> RawSql.RawSql+nullsOrder no = case no of+  NullsFirst -> RawSql.fromString "NULLS FIRST"+  NullsLast -> RawSql.fromString "NULLS LAST"
+ src/Orville/PostgreSQL/Expr/Query.hs view
@@ -0,0 +1,222 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Expr.Query+  ( QueryExpr+  , queryExpr+  , SelectList+  , selectColumns+  , DerivedColumn+  , deriveColumn+  , deriveColumnAs+  , selectDerivedColumns+  , selectStar+  , TableExpr+  , tableExpr+  )+where++import Data.Maybe (catMaybes, fromMaybe)++import Orville.PostgreSQL.Expr.GroupBy (GroupByClause)+import Orville.PostgreSQL.Expr.LimitExpr (LimitExpr)+import Orville.PostgreSQL.Expr.Name (ColumnName)+import Orville.PostgreSQL.Expr.OffsetExpr (OffsetExpr)+import Orville.PostgreSQL.Expr.OrderBy (OrderByClause)+import Orville.PostgreSQL.Expr.Select (SelectClause)+import Orville.PostgreSQL.Expr.TableReferenceList (TableReferenceList)+import Orville.PostgreSQL.Expr.ValueExpression (ValueExpression, columnReference)+import Orville.PostgreSQL.Expr.WhereClause (WhereClause)+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.++> SELECT id FROM some_table++'QueryExpr' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype QueryExpr+  = QueryExpr RawSql.RawSql+  deriving (RawSql.SqlExpression)++{- |+  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".++@since 1.0.0.0+-}+queryExpr :: SelectClause -> SelectList -> Maybe TableExpr -> QueryExpr+queryExpr querySelectClause selectList maybeTableExpr =+  let+    maybeFromClause = do+      table <- maybeTableExpr+      pure (RawSql.fromString " FROM " <> RawSql.toRawSql table)+  in+    QueryExpr $+      mconcat+        [ RawSql.toRawSql querySelectClause+        , RawSql.toRawSql selectList+        , fromMaybe (RawSql.fromString "") maybeFromClause+        ]++{- |+Type to represent the list of items to be selected in a @SELECT@ clause.+E.G. the++> foo, bar, baz++in++> SELECT foo, bar, baz FROM some_table++'SelectList' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype SelectList = SelectList RawSql.RawSql+  deriving (RawSql.SqlExpression)++{- |+  Constructs a 'SelectList' that will select all colums (i.e. the @*@ in+  @SELECT *@").++  @since 1.0.0.0+-}+selectStar :: SelectList+selectStar =+  SelectList (RawSql.fromString "*")++{- |+  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 =+  selectDerivedColumns . map (deriveColumn . columnReference)++{- |+Type to represent an individual item in a list of selected items. E.G.++> now() as current_time++'DerivedColumn' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype DerivedColumn = DerivedColumn RawSql.RawSql+  deriving (RawSql.SqlExpression)++{- |+  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.++@since 1.0.0.0+-}+selectDerivedColumns :: [DerivedColumn] -> SelectList+selectDerivedColumns =+  SelectList . RawSql.intercalate RawSql.comma++{- |+  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.++@since 1.0.0.0+-}+deriveColumn :: ValueExpression -> DerivedColumn+deriveColumn =+  DerivedColumn . RawSql.toRawSql++{- |+  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+-}+deriveColumnAs :: ValueExpression -> ColumnName -> DerivedColumn+deriveColumnAs valueExpr asColumn =+  DerivedColumn+    ( RawSql.toRawSql valueExpr+        <> RawSql.fromString " AS "+        <> RawSql.toRawSql asColumn+    )++{- |+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+> WHERE id > 100+> ORDER BY id+> LIMIT 1+> OFFSET 2++'TableExpr' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype TableExpr+  = TableExpr RawSql.RawSql+  deriving (RawSql.SqlExpression)++{- |+  Constructs a 'TableExpr' with the given options.++@since 1.0.0.0+-}+tableExpr ::+  -- | The list of tables to query from.+  TableReferenceList ->+  -- | An optional @WHERE@ clause to limit the results returned.+  Maybe WhereClause ->+  -- | An optional @GROUP BY@ clause to group the result set rows.+  Maybe GroupByClause ->+  -- | An optional @ORDER BY@ clause to order the result set rows.+  Maybe OrderByClause ->+  -- | An optional @LIMIT@ to apply to the result set.+  Maybe LimitExpr ->+  -- | An optional @OFFSET@ to apply to the result set.+  Maybe OffsetExpr ->+  TableExpr+tableExpr+  tableReferenceList+  maybeWhereClause+  maybeGroupByClause+  maybeOrderByClause+  maybeLimitExpr+  maybeOffsetExpr =+    TableExpr+      . RawSql.intercalate RawSql.space+      $ RawSql.toRawSql tableReferenceList+        : catMaybes+          [ RawSql.toRawSql <$> maybeWhereClause+          , RawSql.toRawSql <$> maybeGroupByClause+          , RawSql.toRawSql <$> maybeOrderByClause+          , RawSql.toRawSql <$> maybeLimitExpr+          , RawSql.toRawSql <$> maybeOffsetExpr+          ]
+ src/Orville/PostgreSQL/Expr/ReturningExpr.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Expr.ReturningExpr+  ( ReturningExpr+  , returningExpr+  )+where++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.++> RETURNING (id)++'ReturningExpr' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype ReturningExpr+  = ReturningExpr RawSql.RawSql+  deriving (RawSql.SqlExpression)++{- |+  Constructs a 'ReturningExpr' that returns the items given in the+  'SelectList'. Essentialy this retults @RETURNING <SelectList items>@.++@since 1.0.0.0+-}+returningExpr :: SelectList -> ReturningExpr+returningExpr selectList =+  ReturningExpr $+    RawSql.fromString "RETURNING "+      <> RawSql.toRawSql selectList
+ src/Orville/PostgreSQL/Expr/Select.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Expr.Select+  ( SelectClause+  , selectClause+  , SelectExpr+  , selectExpr+  , Distinct (Distinct)+  )+where++import qualified Orville.PostgreSQL.Raw.RawSql as RawSql++{- |+Type to represent the @SELECT@ part of a SQL query. E.G.++> SELECT++or++> SELECT DISTINCT++'SelectClause' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom SQL.++@since 1.0.0.0+-}+newtype SelectClause+  = SelectClause RawSql.RawSql+  deriving (RawSql.SqlExpression)++{- |+  Constructs a 'SelectClause' using the given 'SelectExpr', which may indicate+  that this is a @DISTINCT@ select.++@since 1.0.0.0+-}+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.++> DISTINCT++'SelectExpr' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom SQL.++@since 1.0.0.0+-}+newtype SelectExpr = SelectExpr RawSql.RawSql+  deriving (RawSql.SqlExpression)++{- |+  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,+  depending on whether 'Just Distinct' is passed or not.++@since 1.0.0.0+-}+selectExpr :: Maybe Distinct -> SelectExpr+selectExpr mbDistinct =+  SelectExpr . RawSql.fromString $+    case mbDistinct of+      Just Distinct -> "DISTINCT "+      Nothing -> ""
+ src/Orville/PostgreSQL/Expr/SequenceDefinition.hs view
@@ -0,0 +1,494 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Expr.SequenceDefinition+  ( CreateSequenceExpr+  , createSequenceExpr+  , AlterSequenceExpr+  , alterSequenceExpr+  , IncrementByExpr+  , incrementBy+  , MinValueExpr+  , minValue+  , noMinValue+  , MaxValueExpr+  , maxValue+  , noMaxValue+  , StartWithExpr+  , startWith+  , CacheExpr+  , cache+  , CycleExpr+  , cycle+  , noCycle+  , cycleIfTrue+  , DropSequenceExpr+  , dropSequenceExpr+  , nextVal+  , nextValFunction+  , currVal+  , currValFunction+  , setVal+  , setValFunction+  )+where++-- to avoid conflict with cycle+import Prelude (Bool, Maybe (Just), fmap, ($), (.), (<>))++import Data.Int (Int64)+import Data.Maybe (catMaybes)++import Orville.PostgreSQL.Expr.IfExists (IfExists)+import Orville.PostgreSQL.Expr.Name (FunctionName, Qualified, 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++{-+   From https://www.postgresql.org/docs/15/sql-createsequence.html++   @@+   CREATE [ { TEMPORARY | TEMP } | UNLOGGED ] SEQUENCE [ IF NOT EXISTS ] name+    [ AS data_type ]+    [ INCREMENT [ BY ] increment ]+    [ MINVALUE minvalue | NO MINVALUE ] [ MAXVALUE maxvalue | NO MAXVALUE ]+    [ START [ WITH ] start ] [ CACHE cache ] [ [ NO ] CYCLE ]+    [ OWNED BY { table_name.column_name | NONE } ]+   @@+-}++{- |+Type to represent a @CREATE SEQUENCE@ statement. E.G.++> CREATE SEQUENCE foo INCREMENT 2++'CreateSequenceExpr' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype CreateSequenceExpr+  = CreateSequenceExpr RawSql.RawSql+  deriving (RawSql.SqlExpression)++{- |+  Constructs a 'CreateSequenceExpr' with the given sequence options.++  @since 1.0.0.0+-}+createSequenceExpr ::+  -- | The name to be used for the sequence.+  Qualified SequenceName ->+  -- | An optional @INCREMENT@ expression.+  Maybe IncrementByExpr ->+  -- | An optional @MINVALUE@ expression.+  Maybe MinValueExpr ->+  -- | An optional @MAXVALUE@ expression.+  Maybe MaxValueExpr ->+  -- | An optional @START WITH@ expression.+  Maybe StartWithExpr ->+  -- | An optional @CACHE@ expression.+  Maybe CacheExpr ->+  -- | An optional @CYCLE@ expression.+  Maybe CycleExpr ->+  CreateSequenceExpr+createSequenceExpr sequenceName mbIncrementBy mbMinValue mbMaxValue mbStartWith mbCache mbCycle =+  CreateSequenceExpr+    . RawSql.intercalate RawSql.space+    . catMaybes+    $ [ Just (RawSql.fromString "CREATE SEQUENCE")+      , Just (RawSql.toRawSql sequenceName)+      , fmap RawSql.toRawSql mbIncrementBy+      , fmap RawSql.toRawSql mbMinValue+      , fmap RawSql.toRawSql mbMaxValue+      , fmap RawSql.toRawSql mbStartWith+      , fmap RawSql.toRawSql mbCache+      , fmap RawSql.toRawSql mbCycle+      ]++{-+  From https://www.postgresql.org/docs/15/sql-altersequence.html++  @@+  ALTER SEQUENCE [ IF EXISTS ] name+    [ AS data_type ]+    [ INCREMENT [ BY ] increment ]+    [ MINVALUE minvalue | NO MINVALUE ] [ MAXVALUE maxvalue | NO MAXVALUE ]+    [ START [ WITH ] start ]+    [ RESTART [ [ WITH ] restart ] ]+    [ CACHE cache ] [ [ NO ] CYCLE ]+    [ OWNED BY { table_name.column_name | NONE } ]+  ALTER SEQUENCE [ IF EXISTS ] name SET { LOGGED | UNLOGGED }+  ALTER SEQUENCE [ IF EXISTS ] name OWNER TO { new_owner | CURRENT_ROLE | CURRENT_USER | SESSION_USER }+  ALTER SEQUENCE [ IF EXISTS ] name RENAME TO new_name+  ALTER SEQUENCE [ IF EXISTS ] name SET SCHEMA new_schema+  @@+-}++{- |+Type to represent a @CREATE SEQUENCE@ statement. E.G.++> ALTER SEQUENCE foo START WITH 0++'AlterSequenceExpr' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype AlterSequenceExpr+  = AlterSequenceExpr RawSql.RawSql+  deriving (RawSql.SqlExpression)++{- |+  Constructs an 'AlterSequenceExpr' with the given sequence options.++  @since 1.0.0.0+-}+alterSequenceExpr ::+  -- | The name of the sequence to alter+  Qualified SequenceName ->+  -- | An optional @INCREMENT@ expression+  Maybe IncrementByExpr ->+  -- | An optional @MINVALUE@ expression+  Maybe MinValueExpr ->+  -- | An optional @MAXVALUE@ expression+  Maybe MaxValueExpr ->+  -- | An optional @START WITH@ expression+  Maybe StartWithExpr ->+  -- | An optional @CACHE@ expression+  Maybe CacheExpr ->+  -- | An optional @CYCLE@ expression+  Maybe CycleExpr ->+  AlterSequenceExpr+alterSequenceExpr sequenceName mbIncrementBy mbMinValue mbMaxValue mbStartWith mbCache mbCycle =+  AlterSequenceExpr+    . RawSql.intercalate RawSql.space+    . catMaybes+    $ [ Just (RawSql.fromString "ALTER SEQUENCE")+      , Just (RawSql.toRawSql sequenceName)+      , fmap RawSql.toRawSql mbIncrementBy+      , fmap RawSql.toRawSql mbMinValue+      , fmap RawSql.toRawSql mbMaxValue+      , fmap RawSql.toRawSql mbStartWith+      , fmap RawSql.toRawSql mbCache+      , fmap RawSql.toRawSql mbCycle+      ]++{- |+Type to represent an @INCREMENT BY@ expression for sequences. E.G.++> INCREMENT BY 0++'IncrementByExpr' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype IncrementByExpr+  = IncrementByExpr RawSql.RawSql+  deriving (RawSql.SqlExpression)++{- |+  Constructs an 'IncrementByExpr' that will make the sequence increment by+  the given value.++  @since 1.0.0.0+-}+incrementBy :: Int64 -> IncrementByExpr+incrementBy n =+  IncrementByExpr $+    RawSql.fromString "INCREMENT BY "+      <> RawSql.int64DecLiteral n++{- |+Type to represent a @MINVALUE@ expression for sequences. E.G.++> MINVALUE 0++'MinValueExpr' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype MinValueExpr+  = MinValueExpr RawSql.RawSql+  deriving (RawSql.SqlExpression)++{- |+  Constructs a 'MinValueExpr' which gives the sequence the specified minimum+  value.++  @since 1.0.0.0+-}+minValue :: Int64 -> MinValueExpr+minValue n =+  MinValueExpr $+    RawSql.fromString "MINVALUE "+      <> RawSql.int64DecLiteral n++{- |+  Constructs a 'MinValueExpr' which gives the sequence no minimum value (i.e.+  @NO MINVALUE@).++  @since 1.0.0.0+-}+noMinValue :: MinValueExpr+noMinValue =+  MinValueExpr . RawSql.fromString $ "NO MINVALUE"++{- |+Type to represent a @MAXVALUE@ expression for sequences. E.G.++> MAXVALUE 1000000++'MaxValueExpr' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype MaxValueExpr+  = MaxValueExpr RawSql.RawSql+  deriving (RawSql.SqlExpression)++{- |+  Constructs a 'MaxValueExpr' which gives the sequence the specified maximum+  value.++  @since 1.0.0.0+-}+maxValue :: Int64 -> MaxValueExpr+maxValue n =+  MaxValueExpr $+    RawSql.fromString "MAXVALUE "+      <> RawSql.int64DecLiteral n++{- |+  Constructs a 'MaxValueExpr' which gives the sequence no maximum value (i.e.+  @NO MAXVALUE@).++  @since 1.0.0.0+-}+noMaxValue :: MaxValueExpr+noMaxValue =+  MaxValueExpr . RawSql.fromString $ "NO MAXVALUE"++{- |+Type to represent a @START WITH@ expression for sequences. E.G.++> START WITH 1++'StartWithExpr' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype StartWithExpr+  = StartWithExpr RawSql.RawSql+  deriving (RawSql.SqlExpression)++{- |+  Constructs a 'StartWithExpr' which gives the sequence the specified start+  value.++  @since 1.0.0.0+-}+startWith :: Int64 -> StartWithExpr+startWith n =+  StartWithExpr $+    RawSql.fromString "START WITH "+      <> RawSql.int64DecLiteral n++{- |+Type to represent a @CACHE@ expression for sequences. E.G.++> CACHE 16++'CacheExpr' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype CacheExpr+  = CacheExpr RawSql.RawSql+  deriving (RawSql.SqlExpression)++{- |+  Constructs a 'CacheExpr' that will make the sequence pre-allocate the+  specified number of sequence values.++  @since 1.0.0.0+-}+cache :: Int64 -> CacheExpr+cache n =+  CacheExpr $+    RawSql.fromString "CACHE "+      <> RawSql.int64DecLiteral n++{- |+Type to represent a @CYCLE@ expression for sequences. E.G.++> CYCLE++or++> NO CYCLE++'CycleExpr' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype CycleExpr+  = CycleExpr RawSql.RawSql+  deriving (RawSql.SqlExpression)++{- |+  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.++  @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+  passed is @True@.++  @since 1.0.0.0+-}+cycleIfTrue :: Bool -> CycleExpr+cycleIfTrue cycleFlag =+  if cycleFlag+    then cycle+    else noCycle++{- |+Type to represent a @DROP SEQUENCE@ statement. E.G.++> DROP SEQUENCE foo++'DropSequenceExpr' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype DropSequenceExpr+  = DropSequenceExpr RawSql.RawSql+  deriving (RawSql.SqlExpression)++{- |+  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 maybeIfExists sequenceName =+  DropSequenceExpr $+    RawSql.intercalate+      RawSql.space+      ( catMaybes+          [ Just (RawSql.fromString "DROP SEQUENCE")+          , fmap RawSql.toRawSql maybeIfExists+          , Just (RawSql.toRawSql sequenceName)+          ]+      )++{- |+  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'+  to build the item to select.++  @since 1.0.0.0+-}+nextVal :: Qualified SequenceName -> ValueExpression+nextVal sequenceName =+  functionCall+    nextValFunction+    [valueExpression . SqlValue.fromRawBytes . RawSql.toExampleBytes $ sequenceName]++{- |+  The @nextval@ PostgreSQL function.++  @since 1.0.0.0+-}+nextValFunction :: FunctionName+nextValFunction =+  functionName "nextval"++{- |+  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'+  to build the item to select.++  @since 1.0.0.0+-}+currVal :: Qualified SequenceName -> ValueExpression+currVal sequenceName =+  functionCall+    currValFunction+    [valueExpression . SqlValue.fromRawBytes . RawSql.toExampleBytes $ sequenceName]++{- |+  The @currval@ PostgreSQL function.++  @since 1.0.0.0+-}+currValFunction :: FunctionName+currValFunction =+  functionName "currval"++{- |+  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+  item to select.++  @since 1.0.0.0+-}+setVal :: Qualified SequenceName -> Int64 -> ValueExpression+setVal sequenceName newValue =+  functionCall+    setValFunction+    [ valueExpression . SqlValue.fromRawBytes . RawSql.toExampleBytes $ sequenceName+    , valueExpression . SqlValue.fromInt64 $ newValue+    ]++{- |+  The @setval@ PostgreSQL function.++  @since 1.0.0.0+-}+setValFunction :: FunctionName+setValFunction =+  functionName "setval"
+ src/Orville/PostgreSQL/Expr/TableConstraint.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Expr.TableConstraint+  ( TableConstraint+  , uniqueConstraint+  , foreignKeyConstraint+  , ForeignKeyActionExpr+  , restrictExpr+  , cascadeExpr+  , setNullExpr+  , setDefaultExpr+  , ForeignKeyDeleteActionExpr+  , foreignKeyDeleteActionExpr+  , ForeignKeyUpdateActionExpr+  , foreignKeyUpdateActionExpr+  )+where++import Data.List.NonEmpty (NonEmpty)++import Orville.PostgreSQL.Expr.Name (ColumnName, Qualified, TableName)+import qualified Orville.PostgreSQL.Raw.RawSql as RawSql++{- |+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+>  ( id integer+>  , UNIQUE id+>  )+>++'TableConstraint' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype TableConstraint+  = TableConstraint RawSql.RawSql+  deriving (RawSql.SqlExpression)++{- |+  Constructs a 'TableConstraint' will create a @UNIQUE@ constraint on the+  given columns.++  @since 1.0.0.0+-}+uniqueConstraint :: NonEmpty ColumnName -> TableConstraint+uniqueConstraint columnNames =+  TableConstraint $+    RawSql.fromString "UNIQUE "+      <> RawSql.leftParen+      <> RawSql.intercalate RawSql.comma columnNames+      <> RawSql.rightParen++{- |+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++'ForeignKeyActionExpr' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype ForeignKeyActionExpr+  = ForeignKeyActionExpr RawSql.RawSql+  deriving (RawSql.SqlExpression)++{- |+  The foreign key action @RESTRICT@.++  @since 1.0.0.0+-}+restrictExpr :: ForeignKeyActionExpr+restrictExpr = ForeignKeyActionExpr $ RawSql.fromString "RESTRICT"++{- |+  The foreign key action @CASCADE@.++  @since 1.0.0.0+-}+cascadeExpr :: ForeignKeyActionExpr+cascadeExpr = ForeignKeyActionExpr $ RawSql.fromString "CASCADE"++{- |+  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@.++  @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.+the @ON UPDATE RESTRICT@ in++> FOREIGN KEY (foo_id) REFERENCES foo (id) ON UPDATE RESTRICT++'ForeignKeyUpdateActionExpr' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype ForeignKeyUpdateActionExpr+  = ForeignKeyUpdateActionExpr RawSql.RawSql+  deriving (RawSql.SqlExpression)++{- |+  Constructs a 'ForeignKeyActionExpr' that uses the given 'ForeignKeyActionExpr'+  in an @ON UPDATE@ clause for a foreign key.++  @since 1.0.0.0+-}+foreignKeyUpdateActionExpr :: ForeignKeyActionExpr -> ForeignKeyUpdateActionExpr+foreignKeyUpdateActionExpr action =+  ForeignKeyUpdateActionExpr $+    RawSql.fromString "ON UPDATE"+      <> RawSql.space+      <> RawSql.toRawSql action++{- |+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++'ForeignKeyDeleteActionExpr' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype ForeignKeyDeleteActionExpr+  = ForeignKeyDeleteActionExpr RawSql.RawSql+  deriving (RawSql.SqlExpression)++{- |+  Constructs a 'ForeignKeyActionExpr' that uses the given 'ForeignKeyActionExpr'+  in an @ON UPDATE@ clause for a foreign key.++  @since 1.0.0.0+-}+foreignKeyDeleteActionExpr :: ForeignKeyActionExpr -> ForeignKeyDeleteActionExpr+foreignKeyDeleteActionExpr action =+  ForeignKeyDeleteActionExpr $+    RawSql.fromString "ON DELETE"+      <> RawSql.space+      <> RawSql.toRawSql action++{- |+  Constructs a 'TableConstraint' that represent a @FOREIGN KEY@ constraint++  @since 1.0.0.0+-}+foreignKeyConstraint ::+  -- | 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 ->+  -- | 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.+  Maybe ForeignKeyUpdateActionExpr ->+  -- | An optional @ON DELETE@ foreign key action to perform.+  Maybe ForeignKeyDeleteActionExpr ->+  TableConstraint+foreignKeyConstraint columnNames foreignTableName foreignColumnNames mbUpdateAction mbDeleteAction =+  TableConstraint $+    RawSql.fromString "FOREIGN KEY "+      <> RawSql.leftParen+      <> RawSql.intercalate RawSql.comma columnNames+      <> RawSql.rightParen+      <> RawSql.fromString " REFERENCES "+      <> RawSql.toRawSql foreignTableName+      <> RawSql.space+      <> RawSql.leftParen+      <> RawSql.intercalate RawSql.comma foreignColumnNames+      <> RawSql.rightParen+      <> maybe mempty (\updateAction -> RawSql.space <> RawSql.toRawSql updateAction) mbUpdateAction+      <> maybe mempty (\deleteAction -> RawSql.space <> RawSql.toRawSql deleteAction) mbDeleteAction
+ src/Orville/PostgreSQL/Expr/TableDefinition.hs view
@@ -0,0 +1,389 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Expr.TableDefinition+  ( CreateTableExpr+  , createTableExpr+  , PrimaryKeyExpr+  , primaryKeyExpr+  , AlterTableExpr+  , alterTableExpr+  , AlterTableAction+  , addColumn+  , dropColumn+  , addConstraint+  , dropConstraint+  , alterColumnType+  , alterColumnSetDefault+  , alterColumnDropDefault+  , UsingClause+  , usingCast+  , alterColumnNullability+  , AlterNotNull+  , setNotNull+  , dropNotNull+  , DropTableExpr+  , dropTableExpr+  )+where++import Data.List.NonEmpty (NonEmpty)+import Data.Maybe (catMaybes, maybeToList)++import Orville.PostgreSQL.Expr.ColumnDefinition (ColumnDefinition)+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.TableConstraint (TableConstraint)+import qualified Orville.PostgreSQL.Raw.RawSql as RawSql++{- |+Type to represent a @CREATE TABLE@ statement. E.G.++> CREATE TABLE foo (id integer)++'CreateTableExpr' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype CreateTableExpr+  = CreateTableExpr RawSql.RawSql+  deriving (RawSql.SqlExpression)++{- |+  Constructs a 'CreateTableExpr' with the given options.++  @since 1.0.0.0+-}+createTableExpr ::+  -- | The name to be used for the table.+  Qualified TableName ->+  -- | The columns to include in the table.+  [ColumnDefinition] ->+  -- | A primary key expression for the table.+  Maybe PrimaryKeyExpr ->+  -- | Any table constraints to include with the table.+  [TableConstraint] ->+  CreateTableExpr+createTableExpr tableName columnDefs mbPrimaryKey constraints =+  let+    columnDefsSql =+      map RawSql.toRawSql columnDefs++    constraintsSql =+      map RawSql.toRawSql constraints++    tableElementsSql =+      case mbPrimaryKey of+        Nothing ->+          columnDefsSql <> constraintsSql+        Just primaryKey ->+          RawSql.toRawSql primaryKey : (columnDefsSql <> constraintsSql)+  in+    CreateTableExpr $+      mconcat+        [ RawSql.fromString "CREATE TABLE "+        , RawSql.toRawSql tableName+        , RawSql.space+        , RawSql.leftParen+        , RawSql.intercalate RawSql.comma tableElementsSql+        , RawSql.rightParen+        ]++{- |+Type to represent the primary key of a table. E.G.++> PRIMARY KEY (id)++'PrimaryKeyExpr' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype PrimaryKeyExpr+  = PrimaryKeyExpr RawSql.RawSql+  deriving (RawSql.SqlExpression)++{- |+  Constructs a 'PrimaryKeyExpr' with the given columns.++  @since 1.0.0.0+-}+primaryKeyExpr :: NonEmpty ColumnName -> PrimaryKeyExpr+primaryKeyExpr columnNames =+  PrimaryKeyExpr $+    mconcat+      [ RawSql.fromString "PRIMARY KEY "+      , RawSql.leftParen+      , RawSql.intercalate RawSql.comma columnNames+      , RawSql.rightParen+      ]++{- |+Type to represent an @ALTER TABLE@ statement. E.G.++> ALTER TABLE foo ADD COLUMN bar integer++'AlterTableExpr' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype AlterTableExpr+  = AlterTableExpr RawSql.RawSql+  deriving (RawSql.SqlExpression)++{- |+  Constructs an 'AlterTableExpr' with the given alter table actions.++  @since 1.0.0.0+-}+alterTableExpr :: Qualified TableName -> NonEmpty AlterTableAction -> AlterTableExpr+alterTableExpr tableName actions =+  AlterTableExpr $+    RawSql.fromString "ALTER TABLE "+      <> RawSql.toRawSql tableName+      <> RawSql.space+      <> RawSql.intercalate RawSql.commaSpace actions++{- |+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+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype AlterTableAction+  = AlterTableAction RawSql.RawSql+  deriving (RawSql.SqlExpression)++{- |+  Constructs an 'AlterTableAction' that will add the specified column to the+  table.++  @since 1.0.0.0+-}+addColumn :: ColumnDefinition -> AlterTableAction+addColumn columnDef =+  AlterTableAction $+    RawSql.fromString "ADD COLUMN " <> RawSql.toRawSql columnDef++{- |+  Constructs an 'AlterTableAction' that will drop the specified column from the+  table.++  @since 1.0.0.0+-}+dropColumn :: ColumnName -> AlterTableAction+dropColumn columnName =+  AlterTableAction $+    RawSql.fromString "DROP COLUMN " <> RawSql.toRawSql columnName++{- |+  Constructs an 'AlterTableAction' that will add the specified constraint to the+  table.++  @since 1.0.0.0+-}+addConstraint :: TableConstraint -> AlterTableAction+addConstraint constraint =+  AlterTableAction $+    RawSql.fromString "ADD " <> RawSql.toRawSql constraint++{- |+  Constructs an 'AlterTableAction' that will drop the specified constraint from the+  table.++  @since 1.0.0.0+-}+dropConstraint :: ConstraintName -> AlterTableAction+dropConstraint constraintName =+  AlterTableAction $+    RawSql.fromString "DROP CONSTRAINT " <> RawSql.toRawSql constraintName++{- |+  Constructs an 'AlterTableAction' that will alter the type of the specified+  column.++  @since 1.0.0.0+-}+alterColumnType ::+  -- | The name of the column whose type will be altered.+  ColumnName ->+  -- | The new type to use for the column.+  DataType ->+  -- | An optional 'UsingClause' to indicate to the database how data from the+  -- old type should be converted to the new type.+  Maybe UsingClause ->+  AlterTableAction+alterColumnType columnName dataType maybeUsingClause =+  AlterTableAction $+    RawSql.intercalate+      RawSql.space+      ( RawSql.fromString "ALTER COLUMN"+          : RawSql.toRawSql columnName+          : RawSql.fromString "TYPE"+          : RawSql.toRawSql dataType+          : maybeToList (fmap RawSql.toRawSql maybeUsingClause)+      )++{- |+Type to represent a @USING@ clause as part of an @ALTER COLUMN@ when changing+the type of a column. E.G.++> USING id :: integer++'UsingClause' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype UsingClause+  = UsingClause RawSql.RawSql+  deriving (RawSql.SqlExpression)++{- |+  Constructs a 'UsingClause' that will cast the column to the specified type.++  @since 1.0.0.0+-}+usingCast :: ColumnName -> DataType -> UsingClause+usingCast columnName dataType =+  UsingClause $+    RawSql.fromString "USING "+      <> RawSql.toRawSql columnName+      <> RawSql.doubleColon+      <> RawSql.toRawSql dataType++{- |+  Constructs an 'AlterTableAction' that will alter the nullability of the+  column.++  @since 1.0.0.0+-}+alterColumnNullability :: ColumnName -> AlterNotNull -> AlterTableAction+alterColumnNullability columnName alterNotNull =+  AlterTableAction $+    RawSql.intercalate+      RawSql.space+      [ RawSql.fromString "ALTER COLUMN"+      , RawSql.toRawSql columnName+      , RawSql.toRawSql alterNotNull+      ]++{- |+Type to represent an action to alter the nullability of a column. E.G.++> SET NOT NULL++'AlterNotNull' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype AlterNotNull+  = AlterNotNull RawSql.RawSql+  deriving (RawSql.SqlExpression)++{- |+  Sets the column to not null via @SET NOT NULL@.++  @since 1.0.0.0+-}+setNotNull :: AlterNotNull+setNotNull =+  AlterNotNull $ RawSql.fromString "SET NOT NULL"++{- |+  Sets the column to allow null via @DROP NOT NULL@.++  @since 1.0.0.0+-}+dropNotNull :: AlterNotNull+dropNotNull =+  AlterNotNull $ RawSql.fromString "DROP NOT NULL"++{- |+  Constructs an 'AlterTableAction' that will use @DROP DEFAULT@ to drop the+  default value of the specified column.++  @since 1.0.0.0+-}+alterColumnDropDefault :: ColumnName -> AlterTableAction+alterColumnDropDefault columnName =+  AlterTableAction $+    RawSql.intercalate+      RawSql.space+      [ RawSql.fromString "ALTER COLUMN"+      , RawSql.toRawSql columnName+      , RawSql.fromString "DROP DEFAULT"+      ]++{- |+  Constructs an 'AlterTableAction' that will use @SET DEFAULT@ to set the+  default value of the specified column.++  @since 1.0.0.0+-}+alterColumnSetDefault ::+  RawSql.SqlExpression valueExpression =>+  ColumnName ->+  valueExpression ->+  AlterTableAction+alterColumnSetDefault columnName defaultValue =+  AlterTableAction $+    RawSql.intercalate+      RawSql.space+      [ RawSql.fromString "ALTER COLUMN"+      , RawSql.toRawSql columnName+      , RawSql.fromString "SET DEFAULT"+      , RawSql.toRawSql defaultValue+      ]++{- |+Type to represent a @DROP TABLE@ statement. E.G.++> DROP TABLE FOO++'DropTableExpr' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype DropTableExpr+  = DropTableExpr RawSql.RawSql+  deriving (RawSql.SqlExpression)++{- |+  Constructs a 'DropTableExpr' that will drop the specified table.++  @since 1.0.0.0+-}+dropTableExpr :: Maybe IfExists -> Qualified TableName -> DropTableExpr+dropTableExpr maybeIfExists tableName =+  DropTableExpr $+    RawSql.intercalate+      RawSql.space+      ( catMaybes+          [ Just (RawSql.fromString "DROP TABLE")+          , fmap RawSql.toRawSql maybeIfExists+          , Just (RawSql.toRawSql tableName)+          ]+      )
+ src/Orville/PostgreSQL/Expr/TableReferenceList.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Expr.TableReferenceList+  ( TableReferenceList+  , referencesTable+  )+where++import Orville.PostgreSQL.Expr.Name (Qualified, 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++> foo++in++> FROM foo++'TableReferenceList' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype TableReferenceList+  = TableReferenceList RawSql.RawSql+  deriving (RawSql.SqlExpression)++{- |+  Constructs a 'TableReferenceList' consisting of just the specified table+  name.++  @since 1.0.0.0+-}+referencesTable :: Qualified TableName -> TableReferenceList+referencesTable qualifiedTableName =+  TableReferenceList $+    RawSql.toRawSql qualifiedTableName
+ src/Orville/PostgreSQL/Expr/Time.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Expr.Time+  ( now+  , makeInterval+  , IntervalArgument+  , years+  , months+  , weeks+  , days+  , hours+  , minutes+  , seconds+  )+where++import Orville.PostgreSQL.Expr.Name (functionName)+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()@.++  @since 1.0.0.0+-}+now :: ValueExpression+now = functionCall (functionName "now") []++{- |+  Constructs a 'ValueExpression' whose value in PostgreSQL is the result of+  calling @make_interval@ with the specified time intervals passed as named+  arguments.++  @since 1.0.0.0+-}+makeInterval :: [(IntervalArgument, ValueExpression)] -> ValueExpression+makeInterval args =+  functionCallNamedParams+    (functionName "make_interval")+    (fmap (\(IntervalArgument paramName, value) -> (paramName, value)) args)++{- |+Type to represent the name of a time interval argument to the PostgreSQL+@make_interval@ function. E.G.++> years++'IntervalArgument' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype IntervalArgument+  = IntervalArgument ParameterName+  deriving (RawSql.SqlExpression)++{- |+  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+-}+unsafeIntervalArg :: String -> IntervalArgument+unsafeIntervalArg =+  IntervalArgument . RawSql.unsafeSqlExpression++{- |+  The @years@ argument to @make_interval@.++  @since 1.0.0.0+-}+years :: IntervalArgument+years = unsafeIntervalArg "years"++{- |+  The @months@ argument to @make_interval@.++  @since 1.0.0.0+-}+months :: IntervalArgument+months = unsafeIntervalArg "months"++{- |+  The @weeks@ argument to @make_interval@.++  @since 1.0.0.0+-}+weeks :: IntervalArgument+weeks = unsafeIntervalArg "weeks"++{- |+  The @days@ argument to @make_interval@.++  @since 1.0.0.0+-}+days :: IntervalArgument+days = unsafeIntervalArg "days"++{- |+  The @hours@ argument to @make_interval@.++  @since 1.0.0.0+-}+hours :: IntervalArgument+hours = unsafeIntervalArg "hours"++{- |+  The @mins@ argument to @make_interval@.++  @since 1.0.0.0+-}+minutes :: IntervalArgument+minutes = unsafeIntervalArg "mins"++{- |+  The @secs@ argument to @make_interval@.++  @since 1.0.0.0+-}+seconds :: IntervalArgument+seconds = unsafeIntervalArg "secs"
+ src/Orville/PostgreSQL/Expr/Transaction.hs view
@@ -0,0 +1,289 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Expr.Transaction+  ( BeginTransactionExpr+  , beginTransaction+  , TransactionMode+  , readWrite+  , readOnly+  , deferrable+  , notDeferrable+  , isolationLevel+  , IsolationLevel+  , serializable+  , repeatableRead+  , readCommitted+  , readUncommitted+  , CommitExpr+  , commit+  , RollbackExpr+  , rollback+  , rollbackTo+  , SavepointExpr+  , savepoint+  , ReleaseSavepointExpr+  , releaseSavepoint+  )+where++import Data.Maybe (maybeToList)++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.++> BEGIN TRANSACTION++'BeginTransactionExpr' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype BeginTransactionExpr+  = BeginTransactionExpr RawSql.RawSql+  deriving (RawSql.SqlExpression)++{- |+  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)+      )++{- |+Type to represent the transaction mode. E.G.++> ISOLATION LEVEL SERIALIZABLE++'TransactionMode' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype TransactionMode+  = TransactionMode RawSql.RawSql+  deriving (RawSql.SqlExpression)++{- |+  The @READ WRITE@ transaction mode.++  @since 1.0.0.0+-}+readWrite :: TransactionMode+readWrite =+  TransactionMode (RawSql.fromString "READ WRITE")++{- |+  The @READ ONLY@ transaction mode.++  @since 1.0.0.0+-}+readOnly :: TransactionMode+readOnly =+  TransactionMode (RawSql.fromString "READ ONLY")++{- |+  The @DEFERRABLE@ transaction mode.++  @since 1.0.0.0+-}+deferrable :: TransactionMode+deferrable =+  TransactionMode (RawSql.fromString "DEFERRABLE")++{- |+  The @NOT DEFERRABLE@ transaction mode.++  @since 1.0.0.0+-}+notDeferrable :: TransactionMode+notDeferrable =+  TransactionMode (RawSql.fromString "NOT DEFERRABLE")++{- |+  An @ISOLATION LEVEL@ transaction mode with the given 'IsolationLevel'.++  @since 1.0.0.0+-}+isolationLevel :: IsolationLevel -> TransactionMode+isolationLevel level =+  TransactionMode $+    (RawSql.fromString "ISOLATION LEVEL " <> RawSql.toRawSql level)++{- |+Type to represent the transaction isolation level. E.G.++> SERIALIZABLE++'IsolationLevel' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype IsolationLevel+  = IsolationLevel RawSql.RawSql+  deriving (RawSql.SqlExpression)++{- |+  The @SERIALIZABLE@ isolation level.++  @since 1.0.0.0+-}+serializable :: IsolationLevel+serializable =+  IsolationLevel (RawSql.fromString "SERIALIZABLE")++{- |+  The @REPEATABLE READ@ isolation level.++  @since 1.0.0.0+-}+repeatableRead :: IsolationLevel+repeatableRead =+  IsolationLevel (RawSql.fromString "REPEATABLE READ")++{- |+  The @READ COMMITTED@ isolation level.++  @since 1.0.0.0+-}+readCommitted :: IsolationLevel+readCommitted =+  IsolationLevel (RawSql.fromString "READ COMMITTED")++{- |+  The @READ UNCOMMITTED@ isolation level.++  @since 1.0.0.0+-}+readUncommitted :: IsolationLevel+readUncommitted =+  IsolationLevel (RawSql.fromString "READ UNCOMMITTED")++{- |+Type to represent the transaction commit statement. E.G.++> COMMIT++'CommitExpr' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype CommitExpr+  = CommitExpr RawSql.RawSql+  deriving (RawSql.SqlExpression)++{- |+  A @COMMIT@ transaction statement.++  @since 1.0.0.0+-}+commit :: CommitExpr+commit =+  CommitExpr (RawSql.fromString "COMMIT")++{- |+Type to represent the transaction rollback statement. E.G.++> ROLLBACK++'RollbackExpr' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype RollbackExpr+  = RollbackExpr RawSql.RawSql+  deriving (RawSql.SqlExpression)++{- |+  A @ROLLBACK@ transaction statement.++  @since 1.0.0.0+-}+rollback :: RollbackExpr+rollback =+  RollbackExpr (RawSql.fromString "ROLLBACK")++{- |+  A @ROLLBACK TO@ transaction statement that will rollback to the specified+  savepoint.++  @since 1.0.0.0+-}+rollbackTo :: Name.SavepointName -> RollbackExpr+rollbackTo savepointName =+  RollbackExpr $+    RawSql.fromString "ROLLBACK TO SAVEPOINT " <> RawSql.toRawSql savepointName++{- |+Type to represent the transaction savepoint statement. E.G.++> SAVEPOINT foo++'SavepointExpr' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype SavepointExpr+  = SavepointExpr RawSql.RawSql+  deriving (RawSql.SqlExpression)++{- |+  A @SAVEPOINT@ statement that will create a savepoint with the given name.++  @since 1.0.0.0+-}+savepoint :: Name.SavepointName -> SavepointExpr+savepoint savepointName =+  SavepointExpr $+    RawSql.fromString "SAVEPOINT " <> RawSql.toRawSql savepointName++{- |+Type to represent the transaction release savepoint statement. E.G.++> RELEASE SAVEPOINT foo++'ReleaseSavepointExpr' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype ReleaseSavepointExpr+  = ReleaseSavepontExpr RawSql.RawSql+  deriving (RawSql.SqlExpression)++{- |+  A @RELEASE SAVEPOINT@ statement that will release the specified savepoint.++  @since 1.0.0.0+-}+releaseSavepoint :: Name.SavepointName -> ReleaseSavepointExpr+releaseSavepoint savepointName =+  ReleaseSavepontExpr $+    RawSql.fromString "RELEASE SAVEPOINT " <> RawSql.toRawSql savepointName
+ src/Orville/PostgreSQL/Expr/Update.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Expr.Update+  ( UpdateExpr+  , updateExpr+  , SetClauseList+  , setClauseList+  , SetClause+  , setColumn+  )+where++import Data.List.NonEmpty (NonEmpty)+import Data.Maybe (catMaybes)++import Orville.PostgreSQL.Expr.Name (ColumnName, Qualified, TableName)+import Orville.PostgreSQL.Expr.ReturningExpr (ReturningExpr)+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.++> UPDATE foo+> SET id = 1+> WHERE id <> 1++'UpdateExpr' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype UpdateExpr+  = UpdateExpr RawSql.RawSql+  deriving (RawSql.SqlExpression)++{- |+  Constructs an 'UpdateExpr' with the given options.++  @since 1.0.0.0+-}+updateExpr ::+  -- | The name of the table to be updated.+  Qualified TableName ->+  -- | The updates to be made to the table.+  SetClauseList ->+  -- | 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+        [ Just $ RawSql.fromString "UPDATE"+        , Just $ RawSql.toRawSql tableName+        , Just $ RawSql.fromString "SET"+        , Just $ RawSql.toRawSql setClause+        , fmap RawSql.toRawSql maybeWhereClause+        , fmap RawSql.toRawSql maybeReturningExpr+        ]++{- |+Type to represent the list of updates to be made in an @UPDATE@ statement. E.G.++> foo = 1,+> bar = 2++'SetClauseList' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype SetClauseList+  = SetClauseList RawSql.RawSql+  deriving (RawSql.SqlExpression)++{- |+  Constructs a 'SetClauseList' with the specified set clauses.++  @since 1.0.0.0+-}+setClauseList :: NonEmpty SetClause -> SetClauseList+setClauseList =+  SetClauseList . RawSql.intercalate RawSql.comma++{- |+Type to represent a single update to be made in an @UPDATE@ statement. E.G.++> foo = 1++'SetClause' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype SetClause+  = SetClause RawSql.RawSql+  deriving (RawSql.SqlExpression)++{- |+  Constructs a 'SetClause' that will set the specified column to the specified+  value.++  @since 1.0.0.0+-}+setColumn :: ColumnName -> SqlValue.SqlValue -> SetClause+setColumn columnName value =+  SetClause $+    RawSql.toRawSql columnName+      <> RawSql.fromString "="+      <> RawSql.parameter value
+ src/Orville/PostgreSQL/Expr/ValueExpression.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Expr.ValueExpression+  ( ValueExpression+  , cast+  , ParameterName+  , columnReference+  , valueExpression+  , rowValueConstructor+  , functionCall+  , functionCallNamedParams+  )+where++import qualified Data.List.NonEmpty as NE++import Orville.PostgreSQL.Expr.DataType (DataType)+import Orville.PostgreSQL.Expr.Name (ColumnName, FunctionName)+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+constant value, a column reference or any arbitrary calculated expression.+E.G.++> (foo + bar) > 20++'ValueExpression' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype ValueExpression = ValueExpression RawSql.RawSql+  deriving (RawSql.SqlExpression)++{- |+Performs a SQL type cast to the specified type on the given 'ValueExpression'.+E.G.++> foo :: integer++@since 1.0.0.0+-}+cast :: ValueExpression -> DataType -> ValueExpression+cast value dataType =+  ValueExpression $+    RawSql.toRawSql value+      <> RawSql.fromString "::"+      <> RawSql.toRawSql dataType++{- |+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 = ValueExpression . RawSql.toRawSql++{- |+  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+  cannot be used.++  @since 1.0.0.0+-}+valueExpression :: SqlValue -> ValueExpression+valueExpression = ValueExpression . RawSql.parameter++{- |+Constructs a PostgreSQL row value expression from the given list of+expressions. E.G.++> (foo, bar, now())++@since 1.0.0.0+-}+rowValueConstructor :: NE.NonEmpty ValueExpression -> ValueExpression+rowValueConstructor elements =+  ValueExpression $+    RawSql.leftParen+      <> RawSql.intercalate RawSql.comma elements+      <> RawSql.rightParen++{- |+Constructs a 'ValueExpression' that will call the specified PostgreSQL+function with the given arguments passed as position parameters. E.G.++> nextval(sequence_name)++@since 1.0.0.0+-}+functionCall :: FunctionName -> [ValueExpression] -> ValueExpression+functionCall functionName parameters =+  ValueExpression $+    RawSql.toRawSql functionName+      <> RawSql.leftParen+      <> RawSql.intercalate RawSql.comma parameters+      <> RawSql.rightParen++{- |+Type to represent the name of a name parameter in a PostgreSQL function call.+E.G.++> foo++in++> some_func(foo => 1)++'ParameterName' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype ParameterName = ParameterName RawSql.RawSql+  deriving (RawSql.SqlExpression)++{- |+Constructs a 'ValueExpression' that will call the specified PostgreSQL+function with the given arguments passed as named parameters. E.G.++> make_interval(years => 1)++@since 1.0.0.0+-}+functionCallNamedParams :: FunctionName -> [(ParameterName, ValueExpression)] -> ValueExpression+functionCallNamedParams functionName parameters =+  ValueExpression $+    RawSql.toRawSql functionName+      <> RawSql.leftParen+      <> RawSql.intercalate RawSql.comma (fmap (uncurry namedParameterArgument) parameters)+      <> RawSql.rightParen++{- |+  Constructs a sql fragment that will pass the given named argument with the+  specified value.++  @since 1.0.0.0+-}+namedParameterArgument :: ParameterName -> ValueExpression -> RawSql.RawSql+namedParameterArgument name value =+  RawSql.toRawSql name+    <> RawSql.space+    <> RawSql.fromString "=>"+    <> RawSql.space+    <> RawSql.toRawSql value
+ src/Orville/PostgreSQL/Expr/WhereClause.hs view
@@ -0,0 +1,368 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Expr.WhereClause+  ( WhereClause+  , whereClause+  , BooleanExpr+  , literalBooleanExpr+  , andExpr+  , (.&&)+  , orExpr+  , (.||)+  , parenthesized+  , equals+  , notEquals+  , greaterThan+  , lessThan+  , greaterThanOrEqualTo+  , lessThanOrEqualTo+  , like+  , likeInsensitive+  , isNull+  , isNotNull+  , valueIn+  , valueNotIn+  , tupleIn+  , tupleNotIn+  , InValuePredicate+  , inPredicate+  , notInPredicate+  , inValueList+  )+where++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.ValueExpression (ValueExpression, rowValueConstructor)+import qualified Orville.PostgreSQL.Raw.RawSql as RawSql++{- |+Type to represent a @WHERE@ clause restriction on a @SELECT@, @UPDATE@ or+@DELETE@ statement. E.G.++> WHERE (foo > 10)++'WhereClause' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype WhereClause+  = WhereClause RawSql.RawSql+  deriving (RawSql.SqlExpression)++{- |+Constructs a @WHERE@ clause from the given 'BooleanExpr'. E.G.++> WHERE <boolean expr>++@since 1.0.0.0+-}+whereClause :: BooleanExpr -> WhereClause+whereClause booleanExpr =+  WhereClause $+    RawSql.fromString "WHERE " <> RawSql.toRawSql booleanExpr++{- |+Type to represent a SQL value expression that evaluates to a boolean and therefore+can used with boolean logic functions. E.G.++> foo > 10++'BooleanExpr' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype BooleanExpr+  = BooleanExpr RawSql.RawSql+  deriving (RawSql.SqlExpression)++{- |+  Constructs a 'BooleanExpr' whose value is the SQL literal @TRUE@ or @FALSE@+  depending on the argument given.++  @since 1.0.0.0+-}+literalBooleanExpr :: Bool -> BooleanExpr+literalBooleanExpr bool =+  BooleanExpr . RawSql.fromString $+    case bool of+      False -> "FALSE"+      True -> "TRUE"++{- |+  Converts a 'BooleanExpr' to a 'ValueExpression' so that it can be used+  anywhere 'ValueExpression' is allowed.++  @since 1.0.0.0+-}+booleanValueExpression :: BooleanExpr -> ValueExpression+booleanValueExpression (BooleanExpr rawSql) =+  RawSql.unsafeFromRawSql rawSql++{- |+  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.++  @since 1.0.0.0+-}+orExpr :: BooleanExpr -> BooleanExpr -> BooleanExpr+orExpr left right =+  binaryOpExpression+    orOp+    (booleanValueExpression left)+    (booleanValueExpression right)++{- |+  The SQL @OR@ operator (alias for 'orExpr').++  @since 1.0.0.0+-}+(.||) :: BooleanExpr -> BooleanExpr -> BooleanExpr+(.||) = orExpr++infixr 8 .||++{- |+  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.++  @since 1.0.0.0+-}+andExpr :: BooleanExpr -> BooleanExpr -> BooleanExpr+andExpr left right =+  binaryOpExpression+    andOp+    (booleanValueExpression left)+    (booleanValueExpression right)++{- |+  The SQL @AND@ operator (alias for 'andExpr').++  @since 1.0.0.0+-}+(.&&) :: BooleanExpr -> BooleanExpr -> BooleanExpr+(.&&) = andExpr++infixr 8 .&&++{- |+  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+-}+valueIn :: ValueExpression -> NE.NonEmpty ValueExpression -> BooleanExpr+valueIn needle haystack =+  inPredicate needle (inValueList haystack)++{- |+  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+-}+valueNotIn :: ValueExpression -> NE.NonEmpty ValueExpression -> BooleanExpr+valueNotIn needle haystack =+  notInPredicate needle (inValueList haystack)++{- |+  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.++  @since 1.0.0.0+-}+tupleIn :: NE.NonEmpty ValueExpression -> NE.NonEmpty (NE.NonEmpty ValueExpression) -> BooleanExpr+tupleIn needle haystack =+  inPredicate+    (rowValueConstructor needle)+    (inValueList (fmap rowValueConstructor haystack))++{- |+  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.++  @since 1.0.0.0+-}+tupleNotIn :: NE.NonEmpty ValueExpression -> NE.NonEmpty (NE.NonEmpty ValueExpression) -> BooleanExpr+tupleNotIn needle haystack =+  notInPredicate+    (rowValueConstructor needle)+    (inValueList (fmap rowValueConstructor haystack))++{- |+  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.++  @since 1.0.0.0+-}+inPredicate :: ValueExpression -> InValuePredicate -> BooleanExpr+inPredicate predicand predicate =+  BooleanExpr $+    RawSql.parenthesized predicand+      <> RawSql.fromString " IN "+      <> RawSql.toRawSql predicate++{- |+  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.++  @since 1.0.0.0+-}+notInPredicate :: ValueExpression -> InValuePredicate -> BooleanExpr+notInPredicate predicand predicate =+  BooleanExpr $+    RawSql.parenthesized predicand+      <> RawSql.fromString " NOT IN "+      <> RawSql.toRawSql predicate++{- |+Type to represent the right hand side of an @IN@ or @NOT IN@ expression.+E.G.++> (10,12,13)++'InValuePredicate' provides a 'RawSql.SqlExpression' instance. See+'RawSql.unsafeSqlExpression' for how to construct a value with your own custom+SQL.++@since 1.0.0.0+-}+newtype InValuePredicate+  = InValuePredicate RawSql.RawSql+  deriving (RawSql.SqlExpression)++{- |+  Constructs an 'InValuePredicate' from the given list of 'ValueExpression'.++  @since 1.0.0.0+-}+inValueList :: NE.NonEmpty ValueExpression -> InValuePredicate+inValueList values =+  InValuePredicate $+    RawSql.leftParen+      <> RawSql.intercalate RawSql.commaSpace values+      <> RawSql.rightParen++{- |+  Surrounds the given 'BooleanExpr' with parentheses.++  @since 1.0.0.0+-}+parenthesized :: BooleanExpr -> BooleanExpr+parenthesized expr =+  BooleanExpr $+    RawSql.leftParen <> RawSql.toRawSql expr <> RawSql.rightParen++{- |+  The SQL @=@ operator.++  @since 1.0.0.0+-}+equals :: ValueExpression -> ValueExpression -> BooleanExpr+equals =+  binaryOpExpression equalsOp++{- |+  The SQL @<>@ operator.++  @since 1.0.0.0+-}+notEquals :: ValueExpression -> ValueExpression -> BooleanExpr+notEquals =+  binaryOpExpression notEqualsOp++{- |+  The SQL @>@ operator.++  @since 1.0.0.0+-}+greaterThan :: ValueExpression -> ValueExpression -> BooleanExpr+greaterThan =+  binaryOpExpression greaterThanOp++{- |+  The SQL @<@ operator.++  @since 1.0.0.0+-}+lessThan :: ValueExpression -> ValueExpression -> BooleanExpr+lessThan =+  binaryOpExpression lessThanOp++{- |+  The SQL @>=@ operator.++  @since 1.0.0.0+-}+greaterThanOrEqualTo :: ValueExpression -> ValueExpression -> BooleanExpr+greaterThanOrEqualTo =+  binaryOpExpression greaterThanOrEqualsOp++{- |+  The SQL @<=@ operator.++  @since 1.0.0.0+-}+lessThanOrEqualTo :: ValueExpression -> ValueExpression -> BooleanExpr+lessThanOrEqualTo =+  binaryOpExpression lessThanOrEqualsOp++{- |+  The SQL @LIKE@ operator.++  @since 1.0.0.0+-}+like :: ValueExpression -> ValueExpression -> BooleanExpr+like =+  binaryOpExpression likeOp++{- |+  The SQL @ILIKE@ operator.++  @since 1.0.0.0+-}+likeInsensitive :: ValueExpression -> ValueExpression -> BooleanExpr+likeInsensitive =+  binaryOpExpression iLikeOp++{- |+  The SQL @IS NULL@ condition.++  @since 1.0.0.0+-}+isNull :: ValueExpression -> BooleanExpr+isNull value =+  BooleanExpr $+    RawSql.toRawSql value+      <> RawSql.space+      <> RawSql.fromString "IS NULL"++{- |+  The SQL @IS NOT NULL@ condition.++  @since 1.0.0.0+-}+isNotNull :: ValueExpression -> BooleanExpr+isNotNull value =+  BooleanExpr $+    RawSql.toRawSql value+      <> RawSql.space+      <> RawSql.fromString "IS NOT NULL"
+ src/Orville/PostgreSQL/Internal/Bracket.hs view
@@ -0,0 +1,66 @@+{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Internal.Bracket+  ( bracketWithResult+  , BracketResult (BracketSuccess, BracketError)+  ) where++import Control.Exception (SomeException, catch, mask, throwIO)+import Control.Monad.IO.Class (MonadIO (liftIO))++import Orville.PostgreSQL.Monad.MonadOrville (MonadOrvilleControl (liftCatch, liftMask))++data BracketResult+  = BracketSuccess+  | BracketError++{- |+  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+  our exception handling semantics without forcing the Orville user's choice of+  library for lifting and unlift IO actions (e.g. UnliftIO).++@since 1.0.0.0+-}+bracketWithResult ::+  (MonadIO m, MonadOrvilleControl m) =>+  m a ->+  (a -> BracketResult -> 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++    pure result++{- |+  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 =>+  m a ->+  SomeException ->+  m b+handleAndRethrow handle ex = do+  _ <- handle+  liftIO . throwIO $ ex
+ src/Orville/PostgreSQL/Internal/Extra/NonEmpty.hs view
@@ -0,0 +1,18 @@+{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Internal.Extra.NonEmpty+  ( foldl1'+  )+where++import qualified Data.Foldable as Fold+import Data.List.NonEmpty (NonEmpty ((:|)))++foldl1' :: (a -> a -> a) -> NonEmpty a -> a+foldl1' f (first :| rest) =+  Fold.foldl' f first rest
+ src/Orville/PostgreSQL/Internal/FieldName.hs view
@@ -0,0 +1,73 @@+{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Internal.FieldName+  ( FieldName+  , stringToFieldName+  , fieldNameToString+  , fieldNameToColumnName+  , fieldNameToByteString+  , byteStringToFieldName+  ) where++import qualified Data.ByteString.Char8 as B8++import qualified Orville.PostgreSQL.Expr as Expr++{- |+  A simple type to represent the name of a field.++@since 1.0.0.0+-}+newtype FieldName+  = FieldName B8.ByteString+  deriving (Eq, Ord, Show)++{- |+  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)++{- |+  Constructs a 'FieldName' from a 'String'.++@since 1.0.0.0+-}+stringToFieldName :: String -> FieldName+stringToFieldName =+  FieldName . B8.pack++{- |+  Converts a 'FieldName' back to a 'String'.++@since 1.0.0.0+-}+fieldNameToString :: FieldName -> String+fieldNameToString =+  B8.unpack . fieldNameToByteString++{- |+  Converts a 'FieldName' back to a 'B8.ByteString'.++@since 1.0.0.0+-}+fieldNameToByteString :: FieldName -> B8.ByteString+fieldNameToByteString (FieldName name) =+  name++{- |+  Constructs a 'FieldName' from a 'B8.ByteString'.++@since 1.0.0.0+-}+byteStringToFieldName :: B8.ByteString -> FieldName+byteStringToFieldName = FieldName
+ src/Orville/PostgreSQL/Internal/IndexDefinition.hs view
@@ -0,0 +1,283 @@+{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Internal.IndexDefinition+  ( IndexDefinition+  , indexCreationStrategy+  , setIndexCreationStrategy+  , uniqueIndex+  , uniqueNamedIndex+  , nonUniqueIndex+  , nonUniqueNamedIndex+  , mkIndexDefinition+  , mkNamedIndexDefinition+  , IndexMigrationKey (AttributeBasedIndexKey, NamedIndexKey)+  , AttributeBasedIndexMigrationKey (AttributeBasedIndexMigrationKey, indexKeyUniqueness, indexKeyColumns)+  , NamedIndexMigrationKey+  , indexMigrationKey+  , indexCreateExpr+  , IndexCreationStrategy (Transactional, Concurrent)+  )+where++import Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NEL++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'.+  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.+  Orville will then add the index next time you run auto-migrations.++@since 1.0.0.0+-}+data IndexDefinition = IndexDefinition+  { i_indexCreateExpr ::+      IndexCreationStrategy ->+      Expr.Qualified Expr.TableName ->+      Expr.CreateIndexExpr+  , i_indexMigrationKey :: IndexMigrationKey+  , i_indexCreationStrategy :: IndexCreationStrategy+  }++{- |+  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.++@since 1.0.0.0+-}+setIndexCreationStrategy ::+  IndexCreationStrategy ->+  IndexDefinition ->+  IndexDefinition+setIndexCreationStrategy strategy indexDef =+  indexDef+    { i_indexCreationStrategy = strategy+    }++{- |+  Gets the 'IndexCreationStrategy' to be used when creating the index described+  by the 'IndexDefinition'. By default, all indexes are created using the+  'Transactional' strategy.++@since 1.0.0.0+-}+indexCreationStrategy ::+  IndexDefinition ->+  IndexCreationStrategy+indexCreationStrategy =+  i_indexCreationStrategy++{- |+  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+    --       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.+    --       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+    --       transaction, so indexes created using @CONCURRENTLY@ are created+    --       outside the normal schema transaction. Index creation may fail+    --       when using the 'Concurrent' strategy. Orville has no special+    --       provision to detect or recover from this failure currently. You+    --       should manually check that index creation has succeeded. If+    --       necessary, you can manually drop the index to cause Orville to+    --       recreate it the next time migrations are run. Note that while the+    --       table will not be locked, index migration will still block+    --       application startup by default. See the information about schema+    --       migration options in "Orville.PostgreSQL.AutoMigration" for+    --       details about how to work around this if it is a problem for you.+    --       Also, it a good idea to read the PostgreSQL docs about creating+    --       indexes concurrently before you use this strategy. See+    --       https://www.postgresql.org/docs/current/sql-createindex.html#SQL-CREATEINDEX-CONCURRENTLY.+    Concurrent+  deriving (Eq, Show)++{- |+  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.++@since 1.0.0.0+-}+data IndexMigrationKey+  = AttributeBasedIndexKey AttributeBasedIndexMigrationKey+  | NamedIndexKey NamedIndexMigrationKey+  deriving (Eq, Ord)++{- |+  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.++@since 1.0.0.0+-}+data AttributeBasedIndexMigrationKey = AttributeBasedIndexMigrationKey+  { indexKeyUniqueness :: Expr.IndexUniqueness+  , indexKeyColumns :: [FieldDefinition.FieldName]+  }+  deriving (Eq, Ord, Show)++{- |+  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+  created. This is often required when you create indexes using custom SQL+  where Orville is not able to do an accurate structural comparison of the+  desired index structure against the existing indexes.++@since 1.0.0.0+-}+type NamedIndexMigrationKey = String++{- |+  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+  table.++@since 1.0.0.0+-}+indexCreateExpr :: IndexDefinition -> Expr.Qualified Expr.TableName -> Expr.CreateIndexExpr+indexCreateExpr indexDef =+  i_indexCreateExpr+    indexDef+    (i_indexCreationStrategy indexDef)++{- |+  Constructs an 'IndexDefinition' for a non-unique index on the given columns.++@since 1.0.0.0+-}+nonUniqueIndex :: NonEmpty FieldDefinition.FieldName -> IndexDefinition+nonUniqueIndex =+  mkIndexDefinition Expr.NonUniqueIndex++{- |+  Constructs an 'IndexDefinition' for a non-unique index with given SQL and+  index name.++@since 1.0.0.0+-}+nonUniqueNamedIndex :: String -> Expr.IndexBodyExpr -> IndexDefinition+nonUniqueNamedIndex =+  mkNamedIndexDefinition Expr.NonUniqueIndex++{- |+  Constructs an 'IndexDefinition' for a @UNIQUE@ index on the given columns.++@since 1.0.0.0+-}+uniqueIndex :: NonEmpty FieldDefinition.FieldName -> IndexDefinition+uniqueIndex =+  mkIndexDefinition Expr.UniqueIndex++{- |+  Constructs an 'IndexDefinition' for a @UNIQUE@ index with given SQL and index+  name.++@since 1.0.0.0+-}+uniqueNamedIndex :: String -> Expr.IndexBodyExpr -> IndexDefinition+uniqueNamedIndex =+  mkNamedIndexDefinition Expr.UniqueIndex++{- |+  Constructs an 'IndexDefinition' for an index on the given columns with the+  given uniqueness.++@since 1.0.0.0+-}+mkIndexDefinition ::+  Expr.IndexUniqueness ->+  NonEmpty FieldDefinition.FieldName ->+  IndexDefinition+mkIndexDefinition uniqueness fieldNames =+  let+    expr strategy tableName =+      Expr.createIndexExpr+        uniqueness+        (mkMaybeConcurrently strategy)+        tableName+        (fmap FieldDefinition.fieldNameToColumnName fieldNames)++    migrationKey =+      AttributeBasedIndexMigrationKey+        { indexKeyUniqueness = uniqueness+        , indexKeyColumns = NEL.toList fieldNames+        }+  in+    IndexDefinition+      { i_indexCreateExpr = expr+      , i_indexMigrationKey = AttributeBasedIndexKey migrationKey+      , i_indexCreationStrategy = Transactional+      }++{- |+  Constructs an 'IndexDefinition' for an index with the given uniqueness, given+  name, and given SQL.++@since 1.0.0.0+-}+mkNamedIndexDefinition ::+  Expr.IndexUniqueness ->+  String ->+  Expr.IndexBodyExpr ->+  IndexDefinition+mkNamedIndexDefinition uniqueness indexName bodyExpr =+  let+    expr strategy tableName =+      Expr.createNamedIndexExpr+        uniqueness+        (mkMaybeConcurrently strategy)+        tableName+        (Expr.indexName indexName)+        bodyExpr+  in+    IndexDefinition+      { i_indexCreateExpr = expr+      , i_indexMigrationKey = NamedIndexKey indexName+      , i_indexCreationStrategy = Transactional+      }++{- |+  Internal helper to determine whether @CONCURRENTLY@ should be included in+  the SQL to create the index.++@since 1.0.0.0+-}+mkMaybeConcurrently :: IndexCreationStrategy -> Maybe Expr.ConcurrentlyExpr+mkMaybeConcurrently strategy =+  case strategy of+    Transactional -> Nothing+    Concurrent -> Just Expr.concurrently
+ src/Orville/PostgreSQL/Internal/MigrationLock.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE ScopedTypeVariables #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Internal.MigrationLock+  ( MigrationLockId+  , defaultLockId+  , nextLockId+  , withMigrationLock+  , MigrationLockError+  )+where++import Control.Concurrent (threadDelay)+import Control.Exception (Exception, throwIO)+import qualified Control.Monad as Monad+import qualified Control.Monad.IO.Class as MIO+import Data.Int (Int32)++import qualified Orville.PostgreSQL.Execution as Exec+import qualified Orville.PostgreSQL.Internal.Bracket as Bracket+import qualified Orville.PostgreSQL.Marshall as Marshall+import qualified Orville.PostgreSQL.Monad as Monad+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+'defaultLockId' to obtain the default value and 'nextLockId' to create custom+values if you need them.++@since 1.0.0.0+-}+data MigrationLockId = MigrationLockId+  { i_lockKey1 :: Int32+  , i_lockKey2 :: Int32+  }++{- |+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+-}+defaultLockId :: MigrationLockId+defaultLockId =+  MigrationLockId+    { i_lockKey1 = orvilleLockScope+    , i_lockKey2 = 7995632+    }++{- |+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.++@since 1.0.0.0+-}+nextLockId :: MigrationLockId -> MigrationLockId+nextLockId lockId =+  lockId+    { i_lockKey2 = 1 + i_lockKey2 lockId+    }++orvilleLockScope :: Int32+orvilleLockScope = 17772++{- |+  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.++@since 1.0.0.0+-}+withMigrationLock ::+  Monad.MonadOrville m =>+  MigrationLockId ->+  m a ->+  m a+withMigrationLock lockId action =+  Monad.withConnection_ $+    Bracket.bracketWithResult+      (accquireTransactionLock lockId)+      (\() _bracketResult -> releaseTransactionLock lockId)+      (\() -> action)++accquireTransactionLock ::+  forall m.+  Monad.MonadOrville m =>+  MigrationLockId ->+  m ()+accquireTransactionLock lockId =+  let+    go :: Int -> m ()+    go attempts = do+      locked <- attemptLockAcquisition+      if locked+        then pure ()+        else do+          MIO.liftIO $ do+            Monad.when (attempts >= 25) $ do+              throwIO $+                MigrationLockError+                  "Giving up after 25 attempts to aquire the migration lock."+            threadDelay 10000++          go $ attempts + 1++    attemptLockAcquisition = do+      tryLockResults <-+        Exec.executeAndDecode Exec.OtherQuery (tryLockExpr lockId) lockedMarshaller++      case tryLockResults of+        [locked] ->+          pure locked+        rows ->+          MIO.liftIO . throwIO . MigrationLockError $+            "Expected exactly one row from attempt to acquire migration lock, but got " <> show (length rows)+  in+    go 0++releaseTransactionLock :: Monad.MonadOrville m => MigrationLockId -> m ()+releaseTransactionLock =+  Exec.executeVoid Exec.OtherQuery . releaseLockExpr++lockedMarshaller :: Marshall.AnnotatedSqlMarshaller Bool Bool+lockedMarshaller =+  Marshall.annotateSqlMarshallerEmptyAnnotation $+    Marshall.marshallField id (Marshall.booleanField "locked")++tryLockExpr :: MigrationLockId -> RawSql.RawSql+tryLockExpr lockId =+  RawSql.fromString "SELECT pg_try_advisory_lock"+    <> RawSql.leftParen+    <> RawSql.parameter (SqlValue.fromInt32 (i_lockKey1 lockId))+    <> RawSql.comma+    <> RawSql.parameter (SqlValue.fromInt32 (i_lockKey2 lockId))+    <> RawSql.rightParen+    <> RawSql.fromString " as locked"++releaseLockExpr :: MigrationLockId -> RawSql.RawSql+releaseLockExpr lockId =+  RawSql.fromString "SELECT pg_advisory_unlock"+    <> RawSql.leftParen+    <> RawSql.parameter (SqlValue.fromInt32 (i_lockKey1 lockId))+    <> RawSql.comma+    <> RawSql.parameter (SqlValue.fromInt32 (i_lockKey2 lockId))+    <> RawSql.rightParen++{- |+  Raised if 'withMigrationLock' cannot acquire the migration lock in a+  timely manner.++@since 1.0.0.0+-}+newtype MigrationLockError+  = MigrationLockError String+  deriving (Show)++instance Exception MigrationLockError
+ src/Orville/PostgreSQL/Internal/MonadOrville.hs view
@@ -0,0 +1,199 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Internal.MonadOrville+  ( MonadOrville+  , MonadOrvilleControl (liftWithConnection, liftCatch, liftMask)+  , withConnection+  , withConnection_+  , withConnectedState+  )+where++import Control.Exception (Exception)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Trans.Reader (ReaderT (ReaderT), mapReaderT, runReaderT)++import Orville.PostgreSQL.Internal.OrvilleState+  ( ConnectedState (ConnectedState, connectedConnection, connectedTransaction)+  , ConnectionState (Connected, NotConnected)+  , OrvilleState+  , connectState+  , orvilleConnectionPool+  , orvilleConnectionState+  )+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+  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.++  If you want to be able to run Orville operations directly in your own+  application's Monad stack, a good starting place is to add++  @+    instance MonadOrville MyApplicationMonad+  @++  to your module and then let the compiler tell you what instances you+  are missing from the superclasses.++@since 1.0.0.0+-}+class+  ( HasOrvilleState m+  , MonadOrvilleControl m+  , MonadIO m+  ) =>+  MonadOrville m++{- |+  '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).++  For application monads built using only 'ReaderT' and 'IO', this can be+  trivially implemented (or derived), using the 'ReaderT' instance that is+  provided here. If your monad stack is sufficiently complicated, you may+  need to use the @unliftio@ package as a stepping stone to implementing+  'MonadOrvilleControl'. If your monad uses features that @unliftio@ cannot+  support (e.g. the State monad or continuations), then you may need to+  use @monad-control@ instead.++  See 'Orville.PostgreSQL.UnliftIO' for functions that can be used as the+  implementation of the methods below for monads that implement+  'Control.Monad.IO.Unlift.MonadUnliftIO'.++@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.+  --+  -- @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.+  --+  -- @since 1.0.0.0+  liftCatch ::+    Exception e =>+    (forall a. IO a -> (e -> IO a) -> IO a) ->+    m b ->+    (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.+  --+  -- @since 1.0.0.0+  liftMask ::+    (forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b) ->+    ((forall a. m a -> m a) -> m c) ->+    m c++instance MonadOrvilleControl IO where+  liftWithConnection ioWithConn =+    ioWithConn++  liftCatch ioCatch =+    ioCatch++  liftMask ioMask =+    ioMask++instance MonadOrvilleControl m => MonadOrvilleControl (ReaderT state m) where+  liftWithConnection ioWithConn action = do+    ReaderT $ \env ->+      liftWithConnection ioWithConn (flip runReaderT env . action)++  liftCatch ioCatch action handler =+    ReaderT $ \env ->+      liftCatch+        ioCatch+        (runReaderT action env)+        (\e -> runReaderT (handler e) env)++  liftMask ioMask action =+    ReaderT $ \env ->+      liftMask ioMask $ \restore ->+        runReaderT (action (mapReaderT restore)) env++instance (MonadOrvilleControl m, MonadIO m) => MonadOrville (ReaderT OrvilleState m)++{- |+  '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+  happen inside the 'm a' that uses the connection will return the same+  'Connection'. When the 'm a' finishes, the connection will be returned to the+  pool. If 'm a' throws an exception, the pool's exception handling will take+  effect, generally destroying the connection in case it was the source of the+  error.++@since 1.0.0.0+-}+withConnection :: MonadOrville m => (Connection -> m a) -> m a+withConnection connectedAction = do+  withConnectedState (connectedAction . connectedConnection)++{- |+  '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.+  Orville uses connection pooling, so unless you use either 'withConnection' or+  'Orville.PostgreSQL.withTransaction', each database operation may be+  performed on a different connection.++@since 1.0.0.0+-}+withConnection_ :: MonadOrville m => m a -> m a+withConnection_ =+  withConnection . const++{- |+  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+-}+withConnectedState :: MonadOrville m => (ConnectedState -> m a) -> m a+withConnectedState connectedAction = do+  state <- askOrvilleState++  case orvilleConnectionState state of+    Connected connectedState ->+      connectedAction connectedState+    NotConnected ->+      let+        pool = orvilleConnectionPool state+      in+        liftWithConnection (withPoolConnection pool) $ \conn ->+          let+            connectedState =+              ConnectedState+                { connectedConnection = conn+                , connectedTransaction = Nothing+                }+          in+            localOrvilleState (connectState connectedState) $+              connectedAction connectedState
+ src/Orville/PostgreSQL/Internal/OrvilleState.hs view
@@ -0,0 +1,487 @@+{-# LANGUAGE RankNTypes #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Internal.OrvilleState+  ( OrvilleState+  , newOrvilleState+  , resetOrvilleState+  , orvilleConnectionPool+  , orvilleConnectionState+  , orvilleErrorDetailLevel+  , orvilleTransactionCallback+  , orvilleSqlCommenterAttributes+  , addTransactionCallback+  , TransactionEvent (BeginTransaction, NewSavepoint, ReleaseSavepoint, RollbackToSavepoint, CommitTransaction, RollbackTransaction)+  , openTransactionEvent+  , rollbackTransactionEvent+  , transactionSuccessEvent+  , ConnectionState (NotConnected, Connected)+  , ConnectedState (ConnectedState, connectedConnection, connectedTransaction)+  , connectState+  , TransactionState (OutermostTransaction, SavepointTransaction)+  , newTransaction+  , Savepoint+  , savepointNestingLevel+  , initialSavepoint+  , nextSavepoint+  , orvilleSqlExecutionCallback+  , addSqlExecutionCallback+  , orvilleBeginTransactionExpr+  , setBeginTransactionExpr+  , setSqlCommenterAttributes+  , addSqlCommenterAttributes+  )+where++import qualified Data.Map.Strict as Map++import Orville.PostgreSQL.ErrorDetailLevel (ErrorDetailLevel)+import Orville.PostgreSQL.Execution.QueryType (QueryType)+import qualified Orville.PostgreSQL.Expr as Expr+import Orville.PostgreSQL.Raw.Connection (Connection, ConnectionPool)+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,+  transactions, etc. 'newOrvilleState' should be used to create an appopriate+  initial state for your monad's context.++@since 1.0.0.0+-}+data OrvilleState = OrvilleState+  { _orvilleConnectionPool :: ConnectionPool+  , _orvilleConnectionState :: ConnectionState+  , _orvilleErrorDetailLevel :: ErrorDetailLevel+  , _orvilleTransactionCallback :: TransactionEvent -> IO ()+  , _orvilleSqlExecutionCallback :: forall a. QueryType -> RawSql.RawSql -> IO a -> IO a+  , _orvilleBeginTransactionExpr :: Expr.BeginTransactionExpr+  , _orvilleSqlCommenterAttributes :: Maybe SqlCommenter.SqlCommenterAttributes+  }++{- |+  Get the connection pool being used for the 'OrvilleState'.++@since 1.0.0.0+-}+orvilleConnectionPool :: OrvilleState -> ConnectionPool+orvilleConnectionPool =+  _orvilleConnectionPool++{- |+  INTERNAL: The 'ConnectionState' indicates whether Orville currently has a+  connection open, and contains the connection if it does.++@since 1.0.0.0+-}+orvilleConnectionState :: OrvilleState -> ConnectionState+orvilleConnectionState =+  _orvilleConnectionState++{- |+  The 'ErrorDetailLevel' controls how much information Orville includes in+  error messages it generates when data cannot be decoded from rows in the+  database.++@since 1.0.0.0+-}+orvilleErrorDetailLevel :: OrvilleState -> ErrorDetailLevel+orvilleErrorDetailLevel =+  _orvilleErrorDetailLevel++{- |+  Orville will call the transaction callback any time a transaction event+  occurs. You can register a callback with 'addTransactionCallback'.++@since 1.0.0.0+-}+orvilleTransactionCallback :: OrvilleState -> TransactionEvent -> IO ()+orvilleTransactionCallback =+  _orvilleTransactionCallback++{- |+  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.++@since 1.0.0.0+-}+orvilleBeginTransactionExpr :: OrvilleState -> Expr.BeginTransactionExpr+orvilleBeginTransactionExpr =+  _orvilleBeginTransactionExpr++{- |+  The SqlCommenter attributes that Orville will include with queries. These can+  be modified with 'addSqlCommenterAttributes'. See+  https://google.github.io/sqlcommenter/.++@since 1.0.0.0+-}+orvilleSqlCommenterAttributes :: OrvilleState -> Maybe SqlCommenter.SqlCommenterAttributes+orvilleSqlCommenterAttributes =+  _orvilleSqlCommenterAttributes++{- |+  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+  in the order they are added.++  Note: There is no specialized error handling for these callbacks. This means+  that if a callback raises an exception, no further callbacks will be called+  and the exception will propagate up until it is caught elsewhere. In+  particular, if an exception is raised by a callback upon opening the+  transaction, it will cause the transaction to be rolled-back the same as any+  other exception that might happen during the transaction. In general, we+  recommend only using callbacks that either raise no exceptions or can handle+  their own exceptions cleanly.++@since 1.0.0.0+-}+addTransactionCallback ::+  (TransactionEvent -> IO ()) ->+  OrvilleState ->+  OrvilleState+addTransactionCallback newCallback state =+  let+    originalCallback =+      _orvilleTransactionCallback state++    wrappedCallback event = do+      originalCallback event+      newCallback event+  in+    state {_orvilleTransactionCallback = wrappedCallback}++{- |+  Creates an appropriate initial 'OrvilleState' that will use the connection+  pool given to initiate connections to the database.++@since 1.0.0.0+-}+newOrvilleState :: ErrorDetailLevel -> ConnectionPool -> OrvilleState+newOrvilleState errorDetailLevel pool =+  OrvilleState+    { _orvilleConnectionPool = pool+    , _orvilleConnectionState = NotConnected+    , _orvilleErrorDetailLevel = errorDetailLevel+    , _orvilleTransactionCallback = defaultTransactionCallback+    , _orvilleSqlExecutionCallback = defaultSqlExectionCallback+    , _orvilleBeginTransactionExpr = defaultBeginTransactionExpr+    , _orvilleSqlCommenterAttributes = Nothing+    }++{- |+  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.++@since 1.0.0.0+-}+resetOrvilleState :: OrvilleState -> OrvilleState+resetOrvilleState =+  newOrvilleState+    <$> _orvilleErrorDetailLevel+    <*> _orvilleConnectionPool++{- |+  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.++@since 1.0.0.0+-}+connectState :: ConnectedState -> OrvilleState -> OrvilleState+connectState connectedState state =+  state+    { _orvilleConnectionState = Connected connectedState+    }++{- |+  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+  separate connections for a multiple operations that needs to be run on the+  same connection (e.g. multiple operations inside a transaction).++@since 1.0.0.0+-}+data ConnectionState+  = NotConnected+  | Connected ConnectedState++{- |+  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+-}+data ConnectedState = ConnectedState+  { connectedConnection :: Connection+  , connectedTransaction :: Maybe TransactionState+  }++{- |+  INTERNAL: This type is use to track the state of open transactions and+  savepoints on an open connection.++@since 1.0.0.0+-}+data TransactionState+  = OutermostTransaction+  | SavepointTransaction Savepoint++{- |+  INTERNAL: Constructs a new 'TransactionState' to represent beginning a+  new transaction in SQL.++@since 1.0.0.0+-}+newTransaction :: Maybe TransactionState -> TransactionState+newTransaction maybeTransactionState =+  case maybeTransactionState of+    Nothing ->+      OutermostTransaction+    Just OutermostTransaction ->+      SavepointTransaction initialSavepoint+    Just (SavepointTransaction savepoint) ->+      SavepointTransaction (nextSavepoint savepoint)++{- |+  An internal Orville identifier for a savepoint in a PostgreSQL transaction.++@since 1.0.0.0+-}+newtype Savepoint+  = Savepoint Int+  deriving (Eq, Show)++{- |+  The initial identifier Orville uses to track the first savepoint within+  a transaction.++@since 1.0.0.0+-}+initialSavepoint :: Savepoint+initialSavepoint =+  Savepoint 1++{- |+  Determines the identifier for the next savepoint in a transaction after the+  given savepoint.++@since 1.0.0.0+-}+nextSavepoint :: Savepoint -> Savepoint+nextSavepoint (Savepoint n) =+  Savepoint (n + 1)++{- |+  Indicates how many levels of nested savepoints the given 'Savepoint'+  identifier represents.++@since 1.0.0.0+-}+savepointNestingLevel :: Savepoint -> Int+savepointNestingLevel (Savepoint n) = n++{- |+  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.++@since 1.0.0.0+-}+data TransactionEvent+  = -- | Indicates a new transaction has been started.+    BeginTransaction+  | -- | Indicates that a new savepoint has been saved within a transaction.+    NewSavepoint Savepoint+  | -- | Indicates that a previous savepoint has been released. It can no+    -- longer be rolled back to.+    ReleaseSavepoint Savepoint+  | -- | Indicates that rollback was performed to a prior savepoint.+    --+    -- Note: It is possible to rollback to a savepoint prior to the most recent+    -- one without releasing or rolling back to intermediate savepoints. Doing+    -- so destroys any savepoints created after the given savepoint. Although+    -- Orville currently always matches 'NewSavepoint' with either+    -- 'ReleaseSavepoint' or 'RollbackToSavepoint', it is recommended that you+    -- do not rely on this behavior.+    RollbackToSavepoint Savepoint+  | -- | Indicates that the transaction has been committed.+    CommitTransaction+  | -- | Indicates that the transaction has been rolled back.+    RollbackTransaction+  deriving (Eq, Show)++{- |+  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+  based on the current 'TransactionState'.++@since 1.0.0.0+-}+openTransactionEvent :: TransactionState -> TransactionEvent+openTransactionEvent txnState =+  case txnState of+    OutermostTransaction -> BeginTransaction+    SavepointTransaction savepoint -> NewSavepoint savepoint++{- |+  Constructs the appropriate 'TransactionEvent' for rolling back the innermost+  transaction based on the current 'TransactionState'.++@since 1.0.0.0+-}+rollbackTransactionEvent :: TransactionState -> TransactionEvent+rollbackTransactionEvent txnState =+  case txnState of+    OutermostTransaction -> RollbackTransaction+    SavepointTransaction savepoint -> RollbackToSavepoint savepoint++{- |+  Constructs the appropriate 'TransactionEvent' to represent a transaction+  completely successfully based on the current 'TransactionState'.++@since 1.0.0.0+-}+transactionSuccessEvent :: TransactionState -> TransactionEvent+transactionSuccessEvent txnState =+  case txnState of+    OutermostTransaction -> CommitTransaction+    SavepointTransaction savepoint -> ReleaseSavepoint savepoint++{- |+  The callback Orville will call whenever it wants to run SQL. You can+  register a callback using 'addSqlExecutionCallback'.++@since 1.0.0.0+-}+orvilleSqlExecutionCallback ::+  OrvilleState ->+  forall a.+  QueryType ->+  RawSql.RawSql ->+  IO a ->+  IO a+orvilleSqlExecutionCallback =+  _orvilleSqlExecutionCallback++{- |+  The default SQL execption callback simply runs the IO action given without+  doing anything else.++@since 1.0.0.0+-}+defaultSqlExectionCallback :: QueryType -> RawSql.RawSql -> IO a -> IO a+defaultSqlExectionCallback _ _ io = io++{- |+  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.++  Calls to any previously added callbacks will also be executed as part of+  the IO action passed to the new callback. Thus the newly added callback+  happens "around" the previously added callback.++  There is no special exception handling done for these callbacks beyond what+  they implement themselves. Any callbacks should allow for the possibility+  that the IO action they are given may raise an exception.++@since 1.0.0.0+-}+addSqlExecutionCallback ::+  (forall a. QueryType -> RawSql.RawSql -> IO a -> IO a) ->+  OrvilleState ->+  OrvilleState+addSqlExecutionCallback outerCallback state =+  let+    layeredCallback, innerCallback :: QueryType -> RawSql.RawSql -> IO a -> IO a+    layeredCallback queryType sql action =+      outerCallback queryType sql (innerCallback queryType sql action)+    innerCallback = _orvilleSqlExecutionCallback state+  in+    state {_orvilleSqlExecutionCallback = layeredCallback}++{- |+  The default begin transaction expression is simply @BEGIN TRANSACTION@+  with no options specified.++@since 1.0.0.0+-}+defaultBeginTransactionExpr :: Expr.BeginTransactionExpr+defaultBeginTransactionExpr =+  Expr.beginTransaction Nothing++{- |+  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.++@since 1.0.0.0+-}+setBeginTransactionExpr ::+  Expr.BeginTransactionExpr ->+  OrvilleState ->+  OrvilleState+setBeginTransactionExpr expr state =+  state+    { _orvilleBeginTransactionExpr = expr+    }++{- |+  Sets the SqlCommenterAttributes that Orville will then add to any following+  statement executions.++@since 1.0.0.0+-}+setSqlCommenterAttributes ::+  SqlCommenter.SqlCommenterAttributes ->+  OrvilleState ->+  OrvilleState+setSqlCommenterAttributes comments state =+  state+    { _orvilleSqlCommenterAttributes = Just comments+    }++{- |+  Adds the SqlCommenterAttributes to the already existing attributes that+  Orville will then add to any following statement executions.++@since 1.0.0.0+-}+addSqlCommenterAttributes ::+  SqlCommenter.SqlCommenterAttributes ->+  OrvilleState ->+  OrvilleState+addSqlCommenterAttributes comments state =+  case orvilleSqlCommenterAttributes state of+    Nothing ->+      state+        { _orvilleSqlCommenterAttributes = Just comments+        }+    Just existingAttrs ->+      state+        { _orvilleSqlCommenterAttributes = Just $ Map.union comments existingAttrs+        }
+ src/Orville/PostgreSQL/Internal/RowCountExpectation.hs view
@@ -0,0 +1,52 @@+{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Internal.RowCountExpectation+  ( expectExactlyOneRow+  , expectAtMostOneRow+  )+where++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+  thrown if the returning clause from an insert statement for a single record+  returned 0 records or more than 1 record.++@since 1.0.0.0+-}+newtype RowCountExpectationError+  = RowCountExpectationError String+  deriving (Show)++instance Exception RowCountExpectationError++expectExactlyOneRow :: MonadIO m => String -> [a] -> m a+expectExactlyOneRow caller rows =+  case rows of+    [row] ->+      pure row+    _ ->+      liftIO . throwIO . RowCountExpectationError $+        caller+          <> ": Expected exactly one row to be returned, but got "+          <> show (length rows)++expectAtMostOneRow :: MonadIO m => String -> [a] -> m (Maybe a)+expectAtMostOneRow caller rows =+  case rows of+    [] ->+      pure Nothing+    [row] ->+      pure (Just row)+    _ ->+      liftIO . throwIO . RowCountExpectationError $+        caller+          <> ": Expected exactly one row to be returned, but got "+          <> show (length rows)
+ src/Orville/PostgreSQL/Marshall.hs view
@@ -0,0 +1,34 @@+{-# OPTIONS_GHC -Wno-missing-import-lists #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++You can import "Orville.PostgreSQL.Marshall" to get access to all the functions+related to marshalling Haskell values to and from their SQL representations.+This includes a number of lower-level items not exported by+"Orville.PostgreSQL" that give you more control (and therefore responsibility)+over how the marshalling is performed.++@since 1.0.0.0+-}+module Orville.PostgreSQL.Marshall+  ( module Orville.PostgreSQL.Marshall.SqlMarshaller+  , module Orville.PostgreSQL.Marshall.FieldDefinition+  , module Orville.PostgreSQL.Marshall.DefaultValue+  , module Orville.PostgreSQL.Marshall.SyntheticField+  , module Orville.PostgreSQL.Marshall.MarshallError+  , module Orville.PostgreSQL.Marshall.SqlType+  )+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.DefaultValue+import Orville.PostgreSQL.Marshall.FieldDefinition+import Orville.PostgreSQL.Marshall.MarshallError+import Orville.PostgreSQL.Marshall.SqlMarshaller+import Orville.PostgreSQL.Marshall.SqlType+import Orville.PostgreSQL.Marshall.SyntheticField
+ src/Orville/PostgreSQL/Marshall/DefaultValue.hs view
@@ -0,0 +1,292 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Marshall.DefaultValue+  ( DefaultValue+  , integerDefault+  , smallIntegerDefault+  , bigIntegerDefault+  , integralDefault+  , doubleDefault+  , booleanDefault+  , textDefault+  , dateDefault+  , currentDateDefault+  , utcTimestampDefault+  , currentUTCTimestampDefault+  , localTimestampDefault+  , currentLocalTimestampDefault+  , coerceDefaultValue+  , defaultValueExpression+  , rawSqlDefault+  )+where++import qualified Data.ByteString.Builder as BSB+import qualified Data.ByteString.Lazy as LBS+import Data.Int (Int16, Int32, Int64)+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 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+  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.++  This is useful if you want to add a new column to a table that is already+  in production without breaking a previous version of your application that+  is running (e.g. during a zero-down-time deployment) and without needing to+  make the new column nullable. Default values can also be used to create+  database-assigned values such as using @now()@ to set a @created_at@ column+  on a row automatically in the database.++@since 1.0.0.0+-}+newtype DefaultValue a+  = DefaultValue Expr.ValueExpression++{- |+  Builds a default value for any 'Integral' type @n@ by converting it to an+  'Integer'.++@since 1.0.0.0+-}+integralDefault :: Integral n => n -> DefaultValue n+integralDefault n =+  let+    decimalBytes =+      LBS.toStrict+        . BSB.toLazyByteString+        . BSB.integerDec+        . toInteger+        $ n+  in+    if n < 0+      then+        DefaultValue . RawSql.unsafeFromRawSql $+          RawSql.stringLiteral decimalBytes+            <> RawSql.fromString "::integer"+      else DefaultValue . RawSql.unsafeFromRawSql . RawSql.fromBytes $ decimalBytes++{- |+  Builds a default value from an 'Int16' for use with small integer fields.++  This is a specialization of 'integerDefault'.++@since 1.0.0.0+-}+smallIntegerDefault :: Int16 -> DefaultValue Int16+smallIntegerDefault = integralDefault++{- |+  Builds a default value from an 'Int32' for use with integer fields.++  This is a specialization of 'integerDefault'.++@since 1.0.0.0+-}+integerDefault :: Int32 -> DefaultValue Int32+integerDefault = integralDefault++{- |+  Builds a default value from an 'Int16' for use with big integer fields.++  This is a specialization of 'integerDefault'.++@since 1.0.0.0+-}+bigIntegerDefault :: Int64 -> DefaultValue Int64+bigIntegerDefault = integralDefault++{- |+  Builds a default value from a 'Double' field for use with double fields.++@since 1.0.0.0+-}+doubleDefault :: Double -> DefaultValue Double+doubleDefault d =+  let+    decimalBytes =+      LBS.toStrict+        . BSB.toLazyByteString+        . BSB.string7+        $ Numeric.showFFloat Nothing d ""+  in+    if d < 0+      then+        DefaultValue . RawSql.unsafeFromRawSql $+          RawSql.stringLiteral decimalBytes+            <> RawSql.fromString "::numeric"+      else DefaultValue . RawSql.unsafeFromRawSql . RawSql.fromBytes $ decimalBytes++{- |+  Builds a default value from a 'Bool', for use with boolean fields.++@since 1.0.0.0+-}+booleanDefault :: Bool -> DefaultValue Bool+booleanDefault bool =+  let+    pgString =+      case bool of+        True -> "true"+        False -> "false"+  in+    DefaultValue $ RawSql.unsafeSqlExpression pgString++{- |+  Builds a default value from a 'T.Text', for use with unbounded, bounded+  and fixed-length text fields.++@since 1.0.0.0+-}+textDefault :: T.Text -> DefaultValue T.Text+textDefault text =+  DefaultValue . RawSql.unsafeFromRawSql $+    RawSql.stringLiteral (TextEnc.encodeUtf8 text)+      <> RawSql.fromString "::text"++{- |+  Builds a default value from a 'Time.Day' for use with date fields.++@since 1.0.0.0+-}+dateDefault :: Time.Day -> DefaultValue Time.Day+dateDefault day =+  let+    pgText =+      PgTime.dayToPostgreSQL day+  in+    DefaultValue . RawSql.unsafeFromRawSql $+      RawSql.stringLiteral pgText+        <> RawSql.fromString "::date"++{- |+  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.++@since 1.0.0.0+-}+currentDateDefault :: DefaultValue Time.Day+currentDateDefault =+  DefaultValue+    . RawSql.unsafeFromRawSql+    . RawSql.fromString+    $ "('now'::text)::date"++{- |+  Builds a default value from a 'Time.UTCTime' for use with UTC timestamp fields.++@since 1.0.0.0+-}+utcTimestampDefault :: Time.UTCTime -> DefaultValue Time.UTCTime+utcTimestampDefault utcTime =+  let+    pgText =+      PgTime.utcTimeToPostgreSQL utcTime+  in+    DefaultValue . RawSql.unsafeFromRawSql $+      RawSql.stringLiteral pgText+        <> RawSql.fromString "::timestamp with time zone"++{- |+  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.++@since 1.0.0.0+-}+currentUTCTimestampDefault :: DefaultValue Time.UTCTime+currentUTCTimestampDefault =+  DefaultValue $ RawSql.unsafeSqlExpression "now()"++{- |+  Builds a default value from a 'Time.LocalTime' for use with local timestamp fields.++@since 1.0.0.0+-}+localTimestampDefault :: Time.LocalTime -> DefaultValue Time.LocalTime+localTimestampDefault localTime =+  let+    pgText =+      PgTime.localTimeToPostgreSQL localTime+  in+    DefaultValue+      . RawSql.unsafeFromRawSql+      $ RawSql.stringLiteral pgText+        <> RawSql.fromString "::timestamp without time zone"++{- |+  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+  whatever timezone offset has been configured in its settings.++  For use with local timestamp fields.++@since 1.0.0.0+-}+currentLocalTimestampDefault :: DefaultValue Time.LocalTime+currentLocalTimestampDefault =+  DefaultValue $ RawSql.unsafeSqlExpression "('now'::text)::timestamp without time zone"++{- |+  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'+  was originally intended for, everything will work as expected.++@since 1.0.0.0+-}+coerceDefaultValue :: DefaultValue a -> DefaultValue b+coerceDefaultValue (DefaultValue expression) =+  DefaultValue expression++{- |+  Returns a database value expression for the default value.++@since 1.0.0.0+-}+defaultValueExpression :: DefaultValue a -> Expr.ValueExpression+defaultValueExpression (DefaultValue expression) =+  expression++{- |+  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.++  Note: If you are using auto-migrations, the 'Expr.ValueExpression' that you+  pass here must match what is returned by the PostgreSQL @pg_get_expr@+  function. @pg_get_expr@ decompiles the compiled version of the default+  experssion back to source text, sometimes in non-obvious ways. Orville's+  auto-migration compares the expression given in the field definition with the+  decompiled expression from the database to determine whether the default+  value needs to be updated in the schema or not. If the expression given by a+  'DefaultValue' is logically equivalent but does not match the decompiled+  form, auto-migration will continue to execute SQL statements to update the+  schema even when it does not need to.++@since 1.0.0.0+-}+rawSqlDefault :: Expr.ValueExpression -> DefaultValue a+rawSqlDefault =+  DefaultValue
+ src/Orville/PostgreSQL/Marshall/FieldDefinition.hs view
@@ -0,0 +1,1116 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++This module provides functions for working with Orville 'FieldDefinition'+values. 'FieldDefinition' is use to determine the column name and data type+that a Haskell field is mapped to via a+'Orville.PostgreSQL.Marhall.SqlMarshaller'. It is also used for constructing+boolean conditions for matching rows in queries.++@since 1.0.0.0+-}+module Orville.PostgreSQL.Marshall.FieldDefinition+  ( FieldDefinition+  , fieldName+  , setFieldName+  , fieldDescription+  , setFieldDescription+  , fieldType+  , fieldIsNotNullable+  , fieldDefaultValue+  , fieldNullability+  , fieldTableConstraints+  , addFieldTableConstraints+  , addForeignKeyConstraint+  , addForeignKeyConstraintWithOptions+  , addUniqueConstraint+  , fieldEquals+  , (.==)+  , fieldNotEquals+  , (./=)+  , fieldGreaterThan+  , (.>)+  , fieldLessThan+  , (.<)+  , fieldGreaterThanOrEqualTo+  , (.>=)+  , fieldLessThanOrEqualTo+  , (.<=)+  , fieldIsNull+  , fieldIsNotNull+  , fieldLike+  , fieldLikeInsensitive+  , fieldIn+  , (.<-)+  , fieldNotIn+  , (.</-)+  , fieldTupleIn+  , fieldTupleNotIn+  , setField+  , (.:=)+  , orderByField+  , FieldNullability (..)+  , fieldValueToExpression+  , fieldValueToSqlValue+  , fieldValueFromSqlValue+  , fieldColumnName+  , fieldColumnReference+  , fieldColumnDefinition+  , FieldName+  , stringToFieldName+  , fieldNameToString+  , fieldNameToColumnName+  , fieldNameToByteString+  , byteStringToFieldName+  , NotNull+  , Nullable+  , convertField+  , coerceField+  , nullableField+  , asymmetricNullableField+  , setDefaultValue+  , removeDefaultValue+  , prefixField+  , integerField+  , serialField+  , smallIntegerField+  , bigIntegerField+  , bigSerialField+  , doubleField+  , booleanField+  , unboundedTextField+  , boundedTextField+  , fixedTextField+  , textSearchVectorField+  , dateField+  , utcTimestampField+  , localTimestampField+  , uuidField+  , jsonbField+  , fieldOfType+  , whereColumnComparison+  )+where++import qualified Data.ByteString.Char8 as B8+import qualified Data.Coerce as Coerce+import Data.Int (Int16, Int32, Int64)+import Data.List.NonEmpty (NonEmpty ((:|)))+import qualified Data.Text as T+import qualified Data.Time as Time+import qualified Data.UUID as UUID++import qualified Orville.PostgreSQL.Expr as Expr+import Orville.PostgreSQL.Internal.FieldName (FieldName, byteStringToFieldName, fieldNameToByteString, fieldNameToColumnName, fieldNameToString, stringToFieldName)+import qualified Orville.PostgreSQL.Marshall.DefaultValue as DefaultValue+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+  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+  the field.++@since 1.0.0.0+-}+data FieldDefinition nullability a = FieldDefinition+  { i_fieldName :: FieldName+  , i_fieldType :: SqlType.SqlType a+  , i_fieldNullability :: NullabilityGADT nullability+  , i_fieldDefaultValue :: Maybe (DefaultValue.DefaultValue a)+  , i_fieldDescription :: Maybe String+  , i_fieldTableConstraints :: [FieldName -> ConstraintDefinition.ConstraintDefinition]+  }++{- |+  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.++@since 1.0.0.0+-}+setFieldName :: FieldName -> FieldDefinition nullability a -> FieldDefinition nullability a+setFieldName newName fieldDef =+  fieldDef+    { i_fieldName = newName+    }++{- |+  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+  'fieldDescription' for their own purposes (e.g. generating documentation).++@since 1.0.0.0+-}+setFieldDescription :: String -> FieldDefinition nullability a -> FieldDefinition nullability a+setFieldDescription description fieldDef =+  fieldDef+    { i_fieldDescription = Just description+    }++{- |+  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.++@since 1.0.0.0+-}+fieldType :: FieldDefinition nullability a -> SqlType.SqlType a+fieldType = i_fieldType++{- |+  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+ 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+ then work with a concrete 'Nullable' or 'NotNull' field.++@since 1.0.0.0+-}+data FieldNullability a+  = NullableField (FieldDefinition Nullable a)+  | NotNullField (FieldDefinition NotNull a)++{- |+ 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.++@since 1.0.0.0+-}+fieldNullability :: FieldDefinition nullability a -> FieldNullability a+fieldNullability field =+  case i_fieldNullability field of+    NullableGADT -> NullableField field+    NotNullGADT -> NotNullField field++{- |+  Indicates whether a field is not nullable.++@since 1.0.0.0+-}+fieldIsNotNullable :: FieldDefinition nullability a -> Bool+fieldIsNotNullable field =+  case i_fieldNullability field of+    NullableGADT -> False+    NotNullGADT -> True++{- |+  A list of table constraints that will be included on any table that uses this+  field definition.++@since 1.0.0.0+-}+fieldTableConstraints ::+  FieldDefinition nullability a ->+  ConstraintDefinition.TableConstraints+fieldTableConstraints fieldDef =+  let+    name =+      fieldName fieldDef++    constructedConstraints =+      fmap ($ name) (i_fieldTableConstraints fieldDef)+  in+    foldr+      ConstraintDefinition.addConstraint+      ConstraintDefinition.emptyTableConstraints+      constructedConstraints++{- |+  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+  'ConstraintDefinition.ConstraintDefinition's to use the correct name of the+  field in the case where 'setFieldName' is used after constraints are added.++  Note: If multiple constraints are added with the same+  'Orville.PostgreSQL.ConstraintMigrationKey', only the last one that is added+  will be part of the 'Orville.PostgreSQL.TableDefinition'. Any previously+  added constraint with the same key is replaced by the new one.++@since 1.0.0.0+-}+addFieldTableConstraints ::+  [FieldName -> ConstraintDefinition.ConstraintDefinition] ->+  FieldDefinition nullability a ->+  FieldDefinition nullability a+addFieldTableConstraints constraintDefs fieldDef =+  fieldDef+    { i_fieldTableConstraints =+        constraintDefs <> i_fieldTableConstraints fieldDef+    }++{- |+  Adds a @FOREIGN KEY@ constraint to the 'FieldDefinition' (using+  'addFieldTableConstraints'). This constraint will be included on any table+  that uses the field definition.++@since 1.0.0.0+-}+addForeignKeyConstraint ::+  -- | Identifier of the table referenced by the foreign key.+  TableIdentifier.TableIdentifier ->+  -- | The field name that this field definition references in the foreign table.+  FieldName ->+  FieldDefinition nullability a ->+  FieldDefinition nullability a+addForeignKeyConstraint foreignTableId foreignFieldName =+  addForeignKeyConstraintWithOptions+    foreignTableId+    foreignFieldName+    ConstraintDefinition.defaultForeignKeyOptions++{- |+  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+-}+addForeignKeyConstraintWithOptions ::+  -- | Identifier of the table referenced by the foreign key.+  TableIdentifier.TableIdentifier ->+  -- | The field name that this field definition references in the foreign table.+  FieldName ->+  ConstraintDefinition.ForeignKeyOptions ->+  FieldDefinition nullability a ->+  FieldDefinition nullability a+addForeignKeyConstraintWithOptions foreignTableId foreignFieldName options fieldDef =+  let+    mkReference name =+      ConstraintDefinition.ForeignReference+        { ConstraintDefinition.localFieldName = name+        , ConstraintDefinition.foreignFieldName = foreignFieldName+        }++    constraintToAdd name =+      ConstraintDefinition.foreignKeyConstraintWithOptions+        foreignTableId+        (mkReference name :| [])+        options+  in+    addFieldTableConstraints [constraintToAdd] fieldDef++{- |+  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+-}+addUniqueConstraint ::+  FieldDefinition nullability a ->+  FieldDefinition nullability a+addUniqueConstraint fieldDef =+  let+    constraintToAdd name =+      ConstraintDefinition.uniqueConstraint (name :| [])+  in+    addFieldTableConstraints [constraintToAdd] fieldDef++{- |+  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.++@since 1.0.0.0+-}+fieldValueToExpression :: FieldDefinition nullability a -> a -> Expr.ValueExpression+fieldValueToExpression field =+  Expr.valueExpression . fieldValueToSqlValue field++{- |+  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++{- |+  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+-}+fieldValueFromSqlValue :: FieldDefinition nullability a -> SqlValue.SqlValue -> Either String a+fieldValueFromSqlValue =+  SqlType.sqlTypeFromSql . fieldType++{- |+  Constructs the 'Expr.ColumnName' for a field for use in SQL expressions+  from the "Orville.PostgreSQL.Expr" module.++@since 1.0.0.0+-}+fieldColumnName :: FieldDefinition nullability a -> Expr.ColumnName+fieldColumnName =+  fieldNameToColumnName . fieldName++{- |+  Constructs the 'Expr.ValueExpression' for a field 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++{- |+  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+-}+fieldColumnDefinition :: FieldDefinition nullability a -> Expr.ColumnDefinition+fieldColumnDefinition fieldDef =+  Expr.columnDefinition+    (fieldColumnName fieldDef)+    (SqlType.sqlTypeExpr $ fieldType fieldDef)+    (Just $ fieldColumnConstraint 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.++@since 1.0.0.0+-}+fieldColumnConstraint :: FieldDefinition nullabily a -> Expr.ColumnConstraint+fieldColumnConstraint fieldDef =+  case fieldNullability fieldDef of+    NotNullField _ ->+      Expr.notNullConstraint+    NullableField _ ->+      Expr.nullConstraint++{- |++  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.++  The 'NullabilityGADT' represents whether a field will be marked as @NULL@ or+  'NOT NULL' in the database schema. It is a GADT so that the value+  constructors can be used to record this knowledge in the type system as well.+  This allows functions that work only on 'Nullable' or 'NotNull' fields to+  indicate this in their type signatures as appropriate.++@since 1.0.0.0+-}+data NullabilityGADT nullability where+  NullableGADT :: NullabilityGADT Nullable+  NotNullGADT :: NullabilityGADT NotNull++{- |++  '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.++@since 1.0.0.0+-}+data NotNull++{- |+  '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.++@since 1.0.0.0+-}+data Nullable++{- |+  Builds a 'FieldDefinition' that stores Haskell 'Int32' values as the+  PostgreSQL "INT" type.++@since 1.0.0.0+-}+integerField ::+  -- | Name of the field in the database.+  String ->+  FieldDefinition NotNull Int32+integerField = fieldOfType SqlType.integer++{- |+  Builds a 'FieldDefinition' that stores Haskell 'Int16' values as the+  PostgreSQL "SMALLINT" type.++@since 1.0.0.0+-}+smallIntegerField ::+  -- | Name of the field in the database.+  String ->+  FieldDefinition NotNull Int16+smallIntegerField = fieldOfType SqlType.smallInteger++{- |+  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+-}+serialField ::+  -- | Name of the field in the database.+  String ->+  FieldDefinition NotNull Int32+serialField = fieldOfType SqlType.serial++{- |+  Builds a 'FieldDefinition' that stores Haskell 'Int64' values as the+  PostgreSQL "BIGINT" type.++@since 1.0.0.0+-}+bigIntegerField ::+  -- | Name of the field in the database.+  String ->+  FieldDefinition NotNull Int64+bigIntegerField = fieldOfType SqlType.bigInteger++{- |+  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+-}+bigSerialField ::+  -- | Name of the field in the database.+  String ->+  FieldDefinition NotNull Int64+bigSerialField = fieldOfType SqlType.bigSerial++{- |+  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.++@since 1.0.0.0+-}+doubleField ::+  -- | Name of the field in the database.+  String ->+  FieldDefinition NotNull Double+doubleField = fieldOfType SqlType.double++{- |+  Builds a 'FieldDefinition' that stores Haskell 'Bool' values as the+  PostgreSQL "BOOLEAN" type.++@since 1.0.0.0+-}+booleanField ::+  -- | Name of the field in the database.+  String ->+  FieldDefinition NotNull Bool+booleanField = fieldOfType SqlType.boolean++{- |+  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.++@since 1.0.0.0+-}+unboundedTextField ::+  -- | Name of the field in the database.+  String ->+  FieldDefinition NotNull T.Text+unboundedTextField = fieldOfType SqlType.unboundedText++{- |+  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.++@since 1.0.0.0+-}+boundedTextField ::+  -- | Name of the field in the database.+  String ->+  -- | Maximum length of text in the field.+  Int32 ->+  FieldDefinition NotNull T.Text+boundedTextField name len = fieldOfType (SqlType.boundedText len) name++{- |+  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.++@since 1.0.0.0+-}+fixedTextField ::+  -- | Name of the field in the database.+  String ->+  -- | Maximum length of text in the field.+  Int32 ->+  FieldDefinition NotNull T.Text+fixedTextField name len = fieldOfType (SqlType.fixedText len) name++{- |+  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.++  See https://www.postgresql.org/docs/current/datatype-textsearch.html for+  information about how PostgreSQL creates @tsvector@ values from strings.++@since 1.0.0.0+-}+textSearchVectorField :: String -> FieldDefinition NotNull T.Text+textSearchVectorField = fieldOfType SqlType.textSearchVector++{- |+  Builds a 'FieldDefinition' that stores Haskell 'T.Text' values as the+  PostgreSQL "JSONB" type.++@since 1.0.0.0+-}+jsonbField ::+  String ->+  FieldDefinition NotNull T.Text+jsonbField = fieldOfType SqlType.jsonb++{- |+  Builds a 'FieldDefinition' that stores Haskell 'Time.Day' values as the+  PostgreSQL "DATE" type.++@since 1.0.0.0+-}+dateField ::+  -- | Name of the field in the database.+  String ->+  FieldDefinition NotNull Time.Day+dateField = fieldOfType SqlType.date++{- |+  Builds a 'FieldDefinition' that stores Haskell 'Time.UTCTime' values as the+  PostgreSQL "TIMESTAMP with time zone" type.++@since 1.0.0.0+-}+utcTimestampField ::+  -- | Name of the field in the database.+  String ->+  FieldDefinition NotNull Time.UTCTime+utcTimestampField = fieldOfType SqlType.timestamp++{- |+  Builds a 'FieldDefinition' that stores Haskell 'Time.UTCTime' values as the+  PostgreSQL "TIMESTAMP without time zone" type.++@since 1.0.0.0+-}+localTimestampField ::+  -- | Name of the field in the database.+  String ->+  FieldDefinition NotNull Time.LocalTime+localTimestampField = fieldOfType SqlType.timestampWithoutZone++{- |+  Builds a 'FieldDefinition' that stores Haskell 'UUID.UUID' values as the+  PostgreSQL "UUID" type.++@since 1.0.0.0+-}+uuidField ::+  -- | Name of the field in the database.+  String ->+  FieldDefinition NotNull UUID.UUID+uuidField = fieldOfType SqlType.uuid++{- |+  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+  your custom type.++@since 1.0.0.0+-}+fieldOfType ::+  -- | 'SqlType.SqlType' that represents the PostgreSQL data type for the field.+  SqlType.SqlType a ->+  -- | Name of the field in the database.+  String ->+  FieldDefinition NotNull a+fieldOfType sqlType name =+  FieldDefinition+    { i_fieldName = stringToFieldName name+    , i_fieldType = sqlType+    , i_fieldNullability = NotNullGADT+    , i_fieldDefaultValue = Nothing+    , i_fieldDescription = Nothing+    , i_fieldTableConstraints = mempty+    }++{- |+  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.++@since 1.0.0.0+-}+nullableField :: FieldDefinition NotNull a -> FieldDefinition Nullable (Maybe a)+nullableField field =+  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 Just <$> SqlType.sqlTypeFromSql sqlType sqlValue+        }+  in+    FieldDefinition+      { i_fieldName = fieldName field+      , i_fieldType = nullableType (fieldType field)+      , i_fieldNullability = NullableGADT+      , i_fieldDefaultValue = fmap DefaultValue.coerceDefaultValue (i_fieldDefaultValue field)+      , i_fieldDescription = fieldDescription field+      , i_fieldTableConstraints = i_fieldTableConstraints field+      }++{- |+  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+  from the database already have a representation in the @a@ type, so @NULL@+  will be decoded as 'Just <value of type a for NULL>'. This means if you+  insert a 'Nothing' value using the field, it will be read back as 'Just'+  value. This is useful for building high level combinators that might need to+  make fields 'Nullable' but need the value to be decoded in its underlying+  type when reading back (e.g. 'Orville.PostgreSQL.maybeMapper' from+  "Orville.PostgreSQL.Marshall.SqlMarshaller").++@since 1.0.0.0+-}+asymmetricNullableField :: FieldDefinition Nullable a -> FieldDefinition Nullable (Maybe a)+asymmetricNullableField field =+  let+    nullableType :: SqlType.SqlType a -> SqlType.SqlType (Maybe a)+    nullableType sqlType =+      sqlType+        { SqlType.sqlTypeToSql = maybe SqlValue.sqlNull (SqlType.sqlTypeToSql sqlType)+        , SqlType.sqlTypeFromSql = \sqlValue -> Just <$> SqlType.sqlTypeFromSql sqlType sqlValue+        }+  in+    FieldDefinition+      { i_fieldName = fieldName field+      , i_fieldType = nullableType (fieldType field)+      , i_fieldNullability = NullableGADT+      , i_fieldDefaultValue = fmap DefaultValue.coerceDefaultValue (i_fieldDefaultValue field)+      , i_fieldDescription = fieldDescription field+      , i_fieldTableConstraints = i_fieldTableConstraints field+      }++{- |+  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.++  See 'SqlType.convertSqlType' and 'SqlType.tryConvertSqlType' for functions+  to create the conversion needed as the first argument to 'convertField'.++@since 1.0.0.0+-}+convertField ::+  (SqlType.SqlType a -> SqlType.SqlType b) ->+  FieldDefinition nullability a ->+  FieldDefinition nullability b+convertField conversion fieldDef =+  fieldDef+    { i_fieldType = conversion (i_fieldType fieldDef)+    , i_fieldDefaultValue = fmap DefaultValue.coerceDefaultValue (i_fieldDefaultValue fieldDef)+    }++{- |+  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) =>+  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+  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+  available to use.++@since 1.0.0.0+-}+setDefaultValue ::+  DefaultValue.DefaultValue a ->+  FieldDefinition nullability a ->+  FieldDefinition nullability a+setDefaultValue defaultValue fieldDef =+  fieldDef+    { i_fieldDefaultValue = Just defaultValue+    }++{- |+  Removes any default value that may have been set on a field via+  @setDefaultValue@.++@since 1.0.0.0+-}+removeDefaultValue ::+  FieldDefinition nullability a ->+  FieldDefinition nullability a+removeDefaultValue fieldDef =+  fieldDef+    { i_fieldDefaultValue = Nothing+    }++{- |+  Adds a prefix, followed by an underscore, to a field's name.++@since 1.0.0.0+-}+prefixField ::+  String ->+  FieldDefinition nullability a ->+  FieldDefinition nullability a+prefixField prefix fieldDef =+  fieldDef+    { i_fieldName = byteStringToFieldName (B8.pack prefix <> "_" <> fieldNameToByteString (fieldName fieldDef))+    }++{- |+  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 =+  Expr.setColumn+    (fieldColumnName fieldDef)+    (fieldValueToSqlValue fieldDef value)++{- |+  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.++@since 1.0.0.0+-}+fieldEquals :: FieldDefinition nullability a -> a -> Expr.BooleanExpr+fieldEquals =+  whereColumnComparison Expr.equals++{- |+  Operator alias for 'fieldEquals'.++@since 1.0.0.0+-}+(.==) :: FieldDefinition nullability a -> a -> Expr.BooleanExpr+(.==) = fieldEquals++infixl 9 .==++{- |+  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++{- |+  Operator alias for 'fieldNotEquals'.++@since 1.0.0.0+-}+(./=) :: FieldDefinition nullability a -> a -> Expr.BooleanExpr+(./=) = fieldNotEquals++infixl 9 ./=++{- |+  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++{- |+  Operator alias for 'fieldGreaterThan'.++@since 1.0.0.0+-}+(.>) :: FieldDefinition nullability a -> a -> Expr.BooleanExpr+(.>) = fieldGreaterThan++infixl 9 .>++{- |+  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++{- |+  Operator alias for 'fieldLessThan'.++@since 1.0.0.0+-}+(.<) :: FieldDefinition nullability a -> a -> Expr.BooleanExpr+(.<) = fieldLessThan++infixl 9 .<++{- |+  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++{- |+  Operator alias for 'fieldGreaterThanOrEqualTo'.++@since 1.0.0.0+-}+(.>=) :: FieldDefinition nullability a -> a -> Expr.BooleanExpr+(.>=) = fieldGreaterThanOrEqualTo++infixl 9 .>=++{- |+  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++{- |+  Operator alias for 'fieldLessThanOrEqualTo'.++@since 1.0.0.0+-}+(.<=) :: FieldDefinition nullability a -> a -> Expr.BooleanExpr+(.<=) = fieldLessThanOrEqualTo++infixl 9 .<=++{- |+  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))++{- |+  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))++{- |+  Checks that the value in a field is null.++@since 1.0.0.0+-}+fieldIsNull :: FieldDefinition Nullable a -> Expr.BooleanExpr+fieldIsNull =+  Expr.isNull . fieldColumnReference++{- |+  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++{- |+  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)++{- |+  Operator alias for 'fieldIn'.++@since 1.0.0.0+-}+(.<-) :: FieldDefinition nullability a -> NonEmpty a -> Expr.BooleanExpr+(.<-) = fieldIn++infixl 9 .<-++{- |+  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)++{- |+  Operator alias for 'fieldNotIn'.++@since 1.0.0.0+-}+(.</-) :: FieldDefinition nullability a -> NonEmpty a -> Expr.BooleanExpr+(.</-) = fieldNotIn++infixl 9 .</-++{- |+  Checks that a tuple of two fields is in the list of specified tuples.++@since 1.0.0.0+-}+fieldTupleIn ::+  FieldDefinition nullabilityA a ->+  FieldDefinition nullabilityB b ->+  NonEmpty (a, b) ->+  Expr.BooleanExpr+fieldTupleIn fieldDefA fieldDefB values =+  Expr.tupleIn+    (fieldColumnReference fieldDefA :| [fieldColumnReference fieldDefB])+    (fmap (toSqlValueTuple fieldDefA fieldDefB) values)++{- |+  Checks that a tuple of two fields is not in the list of specified tuples.++@since 1.0.0.0+-}+fieldTupleNotIn ::+  FieldDefinition nullabilityA a ->+  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]++{- |+  Constructs a field-based 'Expr.BooleanExpr' using a function that+  builds a 'Expr.BooleanExpr'.++@since 1.0.0.0+-}+whereColumnComparison ::+  (Expr.ValueExpression -> Expr.ValueExpression -> Expr.BooleanExpr) ->+  (FieldDefinition nullability a -> a -> Expr.BooleanExpr)+whereColumnComparison columnComparison fieldDef a =+  columnComparison+    (fieldColumnReference fieldDef)+    (fieldValueToExpression fieldDef a)++{-- |+  Orders a query by the column name for the given field.+--}+orderByField ::+  FieldDefinition nullability value ->+  Expr.OrderByDirection ->+  Expr.OrderByExpr+orderByField =+  Expr.orderByColumnName . fieldColumnName
+ src/Orville/PostgreSQL/Marshall/MarshallError.hs view
@@ -0,0 +1,206 @@+{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Marshall.MarshallError+  ( MarshallError (MarshallError, marshallErrorDetailLevel, marshallErrorRowIdentifier, marshallErrorDetails)+  , renderMarshallError+  , MarshallErrorDetails (DecodingError, MissingColumnError)+  , renderMarshallErrorDetails+  , DecodingErrorDetails (DecodingErrorDetails, decodingErrorValues, decodingErrorMessage)+  , renderDecodingErrorDetails+  , MissingColumnErrorDetails (MissingColumnErrorDetails, missingColumnName, actualColumnNames)+  , renderMissingColumnErrorDetails+  )+where++import Control.Exception (Exception)+import qualified Data.ByteString.Char8 as B8+import qualified Data.List as List+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+  '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.++@since 1.0.0.0+-}+data MarshallError = MarshallError+  { marshallErrorDetailLevel :: ErrorDetailLevel+  -- ^ The level of detail that will be used to render this error as a+  -- message if 'show' is called.+  , marshallErrorRowIdentifier :: [(B8.ByteString, SqlValue.SqlValue)]+  -- ^ The identifier of the row that caused the error. This is a list+  -- of pairs of column name and value in their raw form from the database+  -- to avoid further possible decoding errors when reading the values.+  , marshallErrorDetails :: MarshallErrorDetails+  -- ^ The detailed information about the error that occurred during+  -- decoding.+  }++instance Show MarshallError where+  show decodingError =+    renderMarshallError+      (marshallErrorDetailLevel decodingError)+      decodingError++instance Exception MarshallError++{- |+  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.++  You may want to use this function to render certain errors with a higher+  level of detail than you consider safe for (for example) your application+  logs while using a lower default error detail level with the 'Show' instance+  of 'MarshallError' in case an exception is handled in a more visible section+  of code that returns information more publicly (e.g. a request handler for a+  public endpoint).++@since 1.0.0.0+-}+renderMarshallError :: ErrorDetailLevel -> MarshallError -> String+renderMarshallError detailLevel marshallError =+  let+    presentableRowId =+      map+        (presentSqlColumnValue detailLevel redactIdentifierValue)+        (marshallErrorRowIdentifier marshallError)+  in+    concat+      [ "Unable to decode row with identifier ["+      , List.intercalate ", " presentableRowId+      , "]: "+      , renderMarshallErrorDetails detailLevel (marshallErrorDetails marshallError)+      ]++{- |+  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.++@since 1.0.0.0+-}+presentSqlColumnValue ::+  ErrorDetailLevel ->+  (ErrorDetailLevel -> String -> String) ->+  (B8.ByteString, SqlValue.SqlValue) ->+  String+presentSqlColumnValue detailLevel redacter (columnName, sqlValue) =+  let+    sqlValueString =+      redacter detailLevel $+        case SqlValue.toPgValue sqlValue of+          Nothing ->+            "NULL"+          Just pgValue ->+            B8.unpack . PgTextFormatValue.toByteString $ pgValue+  in+    redactSchemaName detailLevel (B8.unpack columnName)+      <> " = "+      <> sqlValueString++{- |+  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.++@since 1.0.0.0+-}+data MarshallErrorDetails+  = -- | Indicates that one or more values in a column could not be decoded,+    -- either individually or as a group.+    DecodingError DecodingErrorDetails+  | -- | Indicates that an expected column was not found in the result set.+    MissingColumnError MissingColumnErrorDetails++{- |+  Renders a 'MarshallErrorDetails' to a 'String' with a specified+  'ErrorDetailLevel'.++@since 1.0.0.0+-}+renderMarshallErrorDetails :: ErrorDetailLevel -> MarshallErrorDetails -> String+renderMarshallErrorDetails detailLevel err =+  case err of+    DecodingError details -> renderDecodingErrorDetails detailLevel details+    MissingColumnError details -> renderMissingColumnErrorDetails detailLevel details++{- |+  Details about an error that occurred while decoding values found in a SQL+  result set.++@since 1.0.0.0+-}+data DecodingErrorDetails = DecodingErrorDetails+  { decodingErrorValues :: [(B8.ByteString, SqlValue.SqlValue)]+  , decodingErrorMessage :: String+  }++{- |+  Renders a 'DecodingErrorDetails' to a 'String' with a specified+  'ErrorDetailLevel'.++@since 1.0.0.0+-}+renderDecodingErrorDetails :: ErrorDetailLevel -> DecodingErrorDetails -> String+renderDecodingErrorDetails detailLevel details =+  let+    presentableErrorValues =+      map+        (presentSqlColumnValue detailLevel redactNonIdentifierValue)+        (decodingErrorValues details)+  in+    concat+      [ "Unable to decode columns from result set: "+      , redactErrorMessage detailLevel (decodingErrorMessage details)+      , ". Value(s) that failed to decode: ["+      , List.intercalate ", " presentableErrorValues+      , "]"+      ]++{- |+  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)+  }++{- |+  Renders a 'MissingColumnErrorDetails' to a 'String' with a specified+  'ErrorDetailLevel'.++@since 1.0.0.0+-}+renderMissingColumnErrorDetails :: ErrorDetailLevel -> MissingColumnErrorDetails -> String+renderMissingColumnErrorDetails detailLevel details =+  let+    presentableActualNames =+      map+        (redactSchemaName detailLevel . B8.unpack)+        (Set.toList $ actualColumnNames details)+  in+    concat+      [ "Column "+      , redactSchemaName detailLevel (B8.unpack $ missingColumnName details)+      , " not found in results set. Actual columns were ["+      , List.intercalate ", " presentableActualNames+      , "]"+      ]
+ src/Orville/PostgreSQL/Marshall/SqlMarshaller.hs view
@@ -0,0 +1,968 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++This module provides functions for constructing a mapping between Haskell data+types and SQL column schemas. The 'SqlMarshaller' that represents this mapping+can be used to serialize Haskell values both to and from SQL column sets. In+most cases, you construct a 'SqlMarshaller' as part of building your+'Orville.PostgreSQL.Schema.TableDefinition' and Orville handles the rest. In+other cases, you might use a 'SqlMarshaller' with a lower-level Orville+function. For instance, to decode the result set of a custom SQL query.++@since 1.0.0.0+-}+module Orville.PostgreSQL.Marshall.SqlMarshaller+  ( SqlMarshaller+  , AnnotatedSqlMarshaller+  , annotateSqlMarshaller+  , annotateSqlMarshallerEmptyAnnotation+  , unannotatedSqlMarshaller+  , mapSqlMarshaller+  , MarshallerField (Natural, Synthetic)+  , marshallResultFromSql+  , marshallResultFromSqlUsingRowIdExtractor+  , RowIdentityExtractor+  , mkRowIdentityExtractor+  , marshallField+  , marshallSyntheticField+  , marshallReadOnlyField+  , marshallReadOnly+  , marshallNested+  , marshallMaybe+  , marshallPartial+  , prefixMarshaller+  , ReadOnlyColumnOption (IncludeReadOnlyColumns, ExcludeReadOnlyColumns)+  , collectFromField+  , marshallEntityToSetClauses+  , foldMarshallerFields+  , marshallerDerivedColumns+  , marshallerTableConstraints+  , mkRowSource+  , RowSource+  , mapRowSource+  , applyRowSource+  , constRowSource+  , failRowSource+  )+where++import Control.Monad (join)+import qualified Data.ByteString.Char8 as B8+import qualified Data.Map.Strict as Map+import Data.Maybe (catMaybes)+import qualified Data.Set as Set++import Orville.PostgreSQL.ErrorDetailLevel (ErrorDetailLevel)+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 qualified Orville.PostgreSQL.Marshall.MarshallError as MarshallError+import Orville.PostgreSQL.Marshall.SyntheticField (SyntheticField, nullableSyntheticField, prefixSyntheticField, syntheticFieldAlias, syntheticFieldExpression, syntheticFieldValueFromSqlValue)+import qualified Orville.PostgreSQL.Raw.SqlValue as SqlValue+import qualified Orville.PostgreSQL.Schema.ConstraintDefinition as ConstraintDefinition++{- |+  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+  decoding.++  Normally you will not need to interact with this type directly -- the+  @TableDefinition@ type creates it for you using the information it has about+  the primary key of the table to identify rows in decoding errors. If you are+  executing custom queries directly, you may need to annotate a raw+  'SqlMarshaller' yourself so that rows can be identified. See+  'annotateSqlMarshaller' and 'annotateSqlMarshallerEmptyAnnotation'.++@since 1.0.0.0+-}+data AnnotatedSqlMarshaller writeEntity readEntity = AnnotatedSqlMarshaller+  { rowIdFieldNames :: [FieldName]+  , unannotatedSqlMarshaller :: SqlMarshaller writeEntity readEntity+  }++{- |+  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.++@since 1.0.0.0+-}+annotateSqlMarshaller ::+  [FieldName] ->+  SqlMarshaller writeEntity readEntity ->+  AnnotatedSqlMarshaller writeEntity readEntity+annotateSqlMarshaller =+  AnnotatedSqlMarshaller++{- |+  Creates an 'AnnotatedSqlMarshaller' that will identify rows in decoding+  errors by any columns. This is the equivalent of @annotateSqlMarshaller []@.++@since 1.0.0.0+-}+annotateSqlMarshallerEmptyAnnotation ::+  SqlMarshaller writeEntity readEntity ->+  AnnotatedSqlMarshaller writeEntity readEntity+annotateSqlMarshallerEmptyAnnotation =+  annotateSqlMarshaller []++{- |+  Applies the provided function to a 'SqlMarshaller' that has been annotated,+  preserving the annotations.++@since 1.0.0.0+-}+mapSqlMarshaller ::+  (SqlMarshaller readEntityA writeEntityA -> SqlMarshaller readEntityB writeEntityB) ->+  AnnotatedSqlMarshaller readEntityA writeEntityA ->+  AnnotatedSqlMarshaller readEntityB writeEntityB+mapSqlMarshaller f (AnnotatedSqlMarshaller rowIdFields marshaller) =+  AnnotatedSqlMarshaller rowIdFields (f marshaller)++{- |+  '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+  "marshall" the data as we want to model it in SQL and Haskell.++@since 1.0.0.0+-}+data SqlMarshaller a b where+  -- | Our representation of 'pure' in the 'Applicative' sense.+  MarshallPure :: b -> SqlMarshaller a b+  -- | Representation of application like '<*>' from 'Applicative'.+  MarshallApply :: SqlMarshaller a (b -> c) -> SqlMarshaller a b -> SqlMarshaller a c+  -- | Nest an arbitrary function; this is used when modeling a SQL table as nested Haskell records.+  MarshallNest :: (a -> b) -> SqlMarshaller b c -> SqlMarshaller a c+  -- | Marshall a SQL column using the given 'FieldDefinition'.+  MarshallField :: FieldDefinition nullability a -> SqlMarshaller a a+  -- | Marshall a SQL expression on selecting using the given 'SyntheticField'+  -- to generate selects. SyntheticFields are implicitly read-only, as they+  -- do not represent a column that can be inserted into.+  MarshallSyntheticField :: SyntheticField a -> SqlMarshaller b a+  -- | Tag a maybe-mapped marshaller so we don't map it twice.+  MarshallMaybeTag :: SqlMarshaller (Maybe a) (Maybe b) -> SqlMarshaller (Maybe a) (Maybe b)+  -- | Marshall a column with a possibility of error.+  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++instance Functor (SqlMarshaller a) where+  fmap f marsh = MarshallApply (MarshallPure f) marsh++instance Applicative (SqlMarshaller a) where+  pure = MarshallPure+  (<*>) = MarshallApply++{- |+  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.++@since 1.0.0.0+-}+marshallerDerivedColumns ::+  SqlMarshaller writeEntity readEntity ->+  [Expr.DerivedColumn]+marshallerDerivedColumns marshaller =+  let+    collectDerivedColumn ::+      MarshallerField writeEntity ->+      [Expr.DerivedColumn] ->+      [Expr.DerivedColumn]+    collectDerivedColumn entry columns =+      case entry of+        Natural fieldDef _ ->+          (Expr.deriveColumn . Expr.columnReference . fieldColumnName $ fieldDef)+            : columns+        Synthetic synthField ->+          Expr.deriveColumnAs+            (syntheticFieldExpression synthField)+            (fieldNameToColumnName $ syntheticFieldAlias synthField)+            : columns+  in+    foldMarshallerFields marshaller [] collectDerivedColumn++{- |+  Returns the table constraints for all the 'FieldDefinition's used in the+  'SqlMarshaller'.++@since 1.0.0.0+-}+marshallerTableConstraints ::+  SqlMarshaller writeEntity readEntity ->+  ConstraintDefinition.TableConstraints+marshallerTableConstraints marshaller =+  let+    collectTableConstraints ::+      MarshallerField writeEntity ->+      ConstraintDefinition.TableConstraints ->+      ConstraintDefinition.TableConstraints+    collectTableConstraints entry constraints =+      case entry of+        Natural fieldDef _ -> constraints <> fieldTableConstraints fieldDef+        Synthetic _synthField -> constraints+  in+    foldMarshallerFields+      marshaller+      ConstraintDefinition.emptyTableConstraints+      collectTableConstraints++{- |+  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+  Synthetic :: SyntheticField a -> MarshallerField writeEntity++{- |+  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.++  Note: Folds executed with 'collectFromField' ignore 'Synthetic' entries in+  the marshaller. You should only use 'collectFromField' in situations where+  you only care about the actual columns referenced by the marshaller.++@since 1.0.0.0+-}+collectFromField ::+  ReadOnlyColumnOption ->+  (forall nullability a. 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 ->+      case readOnlyColumnOption of+        IncludeReadOnlyColumns -> fromField fieldDef : results+        ExcludeReadOnlyColumns -> results+    Synthetic _ ->+      results++{- |+  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.++@since 1.0.0.0+-}+marshallEntityToSetClauses ::+  SqlMarshaller writeEntity readEntity ->+  writeEntity ->+  [Expr.SetClause]+marshallEntityToSetClauses marshaller writeEntity =+  foldMarshallerFields+    marshaller+    []+    (collectSetClauses writeEntity)++{- |+  An internal helper function that collects the 'Expr.SetClause's to+  update all the fields contained in a 'SqlMarshaller'++@since 1.0.0.0+-}+collectSetClauses ::+  entity ->+  MarshallerField entity ->+  [Expr.SetClause] ->+  [Expr.SetClause]+collectSetClauses entity entry clauses =+  case entry of+    Natural fieldDef (Just accessor) ->+      setField fieldDef (accessor entity) : clauses+    Natural _ Nothing ->+      clauses+    Synthetic _ ->+      clauses++{- |+  Specifies whether read-only fields should be included when using functions+  such as 'collectFromField'.++@since 1.0.0.0+-}+data ReadOnlyColumnOption+  = IncludeReadOnlyColumns+  | ExcludeReadOnlyColumns++{- |+  '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.++@since 1.0.0.0+-}+foldMarshallerFields ::+  SqlMarshaller writeEntity readEntity ->+  result ->+  (MarshallerField writeEntity -> result -> result) ->+  result+foldMarshallerFields marshaller =+  foldMarshallerFieldsPart marshaller (Just id)++{- |+  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.++@since 1.0.0.0+-}+foldMarshallerFieldsPart ::+  SqlMarshaller entityPart readEntity ->+  Maybe (writeEntity -> entityPart) ->+  result ->+  (MarshallerField writeEntity -> result -> result) ->+  result+foldMarshallerFieldsPart marshaller getPart currentResult addToResult =+  case marshaller of+    MarshallPure _ ->+      currentResult+    MarshallApply submarshallerA submarshallerB ->+      let+        subresultB =+          foldMarshallerFieldsPart submarshallerB getPart currentResult addToResult+      in+        foldMarshallerFieldsPart submarshallerA getPart subresultB addToResult+    MarshallNest nestingFunction submarshaller ->+      foldMarshallerFieldsPart submarshaller (fmap (nestingFunction .) getPart) currentResult addToResult+    MarshallField fieldDefinition ->+      addToResult (Natural fieldDefinition getPart) currentResult+    MarshallSyntheticField syntheticField ->+      addToResult (Synthetic syntheticField) currentResult+    MarshallMaybeTag m ->+      foldMarshallerFieldsPart m getPart currentResult addToResult+    MarshallPartial m ->+      foldMarshallerFieldsPart m getPart currentResult addToResult+    MarshallReadOnly m ->+      foldMarshallerFieldsPart m Nothing currentResult addToResult++{- |+  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.++  Note that this function loads all decoded rows into memory at once, so it+  should only be used with result sets that you know will fit into memory.++@since 1.0.0.0+-}+marshallResultFromSql ::+  ExecutionResult result =>+  ErrorDetailLevel ->+  AnnotatedSqlMarshaller writeEntity readEntity ->+  result ->+  IO (Either MarshallError.MarshallError [readEntity])+marshallResultFromSql errorDetailLevel marshallerWithMeta result =+  marshallResultFromSqlUsingRowIdExtractor+    errorDetailLevel+    (mkRowIdentityExtractor (rowIdFieldNames marshallerWithMeta) result)+    (unannotatedSqlMarshaller marshallerWithMeta)+    result++{- |+  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+  values to identify the row in the error details.++  Note that this function loads all decoded rows into memory at once, so it+  should only be used with result sets that you know will fit into memory.++@since 1.0.0.0+-}+marshallResultFromSqlUsingRowIdExtractor ::+  ExecutionResult result =>+  ErrorDetailLevel ->+  RowIdentityExtractor ->+  SqlMarshaller writeEntity readEntity ->+  result ->+  IO (Either MarshallError.MarshallError [readEntity])+marshallResultFromSqlUsingRowIdExtractor errorDetailLevel rowIdExtractor marshaller result = do+  mbMaxRow <- Result.maxRowNumber result++  case mbMaxRow of+    Nothing ->+      pure (Right [])+    Just maxRow -> do+      rowSource <- mkRowSource marshaller result+      traverseSequence (decodeRow errorDetailLevel rowSource rowIdExtractor) [Row 0 .. maxRow]++traverseSequence :: (a -> IO (Either err b)) -> [a] -> IO (Either err [b])+traverseSequence f =+  go+ where+  go as =+    case as of+      [] ->+        pure (Right [])+      a : rest -> do+        eitherB <- f a+        case eitherB of+          Left err ->+            pure (Left err)+          Right b -> do+            eitherBS <- go rest+            case eitherBS of+              Left err ->+                pure (Left err)+              Right bs ->+                pure (Right (b : bs))++{- |+  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.++@since 1.0.0.0+-}+decodeRow ::+  ErrorDetailLevel ->+  RowSource readEntity ->+  RowIdentityExtractor ->+  Row ->+  IO (Either MarshallError.MarshallError readEntity)+decodeRow errorDetailLevel (RowSource source) (RowIdentityExtractor getRowId) row = do+  result <- source row+  case result of+    Left err -> do+      rowId <- getRowId row+      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' gives random access to the rows in the result set, only+  attempting to decode them when they are requested by the user via 'decodeRow'.++  Note that even though the rows are not decoded into Haskell until 'decodeRow'+  is called, all the rows returned from the query are held in memory on the+  client waiting to be decoded until the 'RowSource' is garbage collected.+  As such, you can't use 'RowSource' (alone) to achieve any form of streaming+  or pagination of rows between the database server and the client.++@since 1.0.0.0+-}+newtype RowSource readEntity+  = RowSource (Row -> IO (Either MarshallError.MarshallErrorDetails readEntity))++instance Functor RowSource where+  fmap = mapRowSource++instance Applicative RowSource where+  pure = constRowSource+  (<*>) = applyRowSource++{- |+  Adds a function to the decoding proocess to transform the value returned+  by a 'RowSource'.++@since 1.0.0.0+-}+mapRowSource :: (a -> b) -> RowSource a -> RowSource b+mapRowSource f (RowSource decodeA) =+  RowSource $ \row -> fmap (fmap f) (decodeA row)++{- |+  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+-}+constRowSource :: readEntity -> RowSource readEntity+constRowSource =+  RowSource . const . pure . Right++{- |+  Applies a function that will be decoded from the result set to another+  value decoded from the result set.++@since 1.0.0.0+-}+applyRowSource :: RowSource (a -> b) -> RowSource a -> RowSource b+applyRowSource (RowSource decodeAtoB) (RowSource decodeA) =+  RowSource $ \row -> do+    eitherAToB <- decodeAtoB row++    case eitherAToB of+      Left err ->+        pure (Left err)+      Right aToB -> do+        eitherA <- decodeA row+        pure (fmap aToB eitherA)++{- |+  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+  a column that does not exist in the result set.++@since 1.0.0.0+-}+failRowSource :: MarshallError.MarshallErrorDetails -> RowSource a+failRowSource =+  RowSource . const . pure . Left++{- |+  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+  collected.++@since 1.0.0.0+-}+mkRowSource ::+  ExecutionResult result =>+  SqlMarshaller writeEntity readEntity ->+  result ->+  IO (RowSource readEntity)+mkRowSource marshaller result = do+  columnMap <- prepareColumnMap result++  let+    mkSource :: SqlMarshaller a b -> RowSource b+    mkSource 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.+      case marshallerPart of+        MarshallPure readEntity ->+          constRowSource readEntity+        MarshallApply marshallAToB marshallA ->+          mkSource marshallAToB <*> mkSource marshallA+        MarshallNest _ someMarshaller ->+          mkSource someMarshaller+        MarshallField fieldDef ->+          mkFieldNameSource+            (fieldName fieldDef)+            (fieldValueFromSqlValue fieldDef)+            columnMap+            result+        MarshallSyntheticField syntheticField ->+          mkFieldNameSource+            (syntheticFieldAlias syntheticField)+            (syntheticFieldValueFromSqlValue syntheticField)+            columnMap+            result+        MarshallMaybeTag m ->+          mkSource m+        MarshallPartial m ->+          let+            fieldNames =+              foldMarshallerFields m [] $ \marshallerField names ->+                case marshallerField of+                  Natural field _ ->+                    fieldName field : names+                  Synthetic field ->+                    syntheticFieldAlias field : names+          in+            partialRowSource fieldNames columnMap result (mkSource m)+        MarshallReadOnly m ->+          mkSource m++  pure . mkSource $ marshaller++partialRowSource ::+  ExecutionResult result =>+  [FieldName] ->+  Map.Map B8.ByteString Column ->+  result ->+  RowSource (Either String readEntity) ->+  RowSource readEntity+partialRowSource fieldNames columnMap result (RowSource f) =+  RowSource $ \row -> do+    partialResult <- f row+    case partialResult of+      Left marshallError ->+        pure $ Left marshallError+      Right (Left errorMessage) -> do+        let+          columnNames =+            map fieldNameToByteString fieldNames++          lookupValue columnName =+            case Map.lookup columnName columnMap of+              Nothing ->+                pure (columnName, SqlValue.sqlNull)+              Just columnNumber -> do+                value <- Result.getValue result row columnNumber+                pure (columnName, value)++        values <- traverse lookupValue columnNames++        pure . Left . MarshallError.DecodingError $+          MarshallError.DecodingErrorDetails+            { MarshallError.decodingErrorValues = values+            , MarshallError.decodingErrorMessage = errorMessage+            }+      Right (Right entity) ->+        pure $ Right entity++{- |+  Builds a 'RowSource' that will retrieve and decode the name field from+  the result.++@since 1.0.0.0+-}+mkFieldNameSource ::+  ExecutionResult result =>+  FieldName ->+  (SqlValue.SqlValue -> Either String a) ->+  Map.Map B8.ByteString Column ->+  result ->+  RowSource a+mkFieldNameSource sourceFieldName fromSqlValue columnMap result =+  case Map.lookup (fieldNameToByteString sourceFieldName) columnMap of+    Just columnNumber ->+      mkColumnRowSource sourceFieldName fromSqlValue result columnNumber+    Nothing ->+      failRowSource . MarshallError.MissingColumnError $+        MarshallError.MissingColumnErrorDetails+          { MarshallError.missingColumnName = fieldNameToByteString sourceFieldName+          , MarshallError.actualColumnNames = Map.keysSet columnMap+          }++{- |+  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+-}+prepareColumnMap ::+  ExecutionResult result =>+  result ->+  IO (Map.Map B8.ByteString Column)+prepareColumnMap result = do+  mbMaxColumn <- Result.maxColumnNumber result++  let+    mkNameEntry columnNumber = do+      mbColumnName <- Result.columnName result columnNumber++      pure $+        case mbColumnName of+          Just name ->+            Just (name, columnNumber)+          Nothing ->+            Nothing++  case mbMaxColumn of+    Nothing ->+      pure Map.empty+    Just maxColumn -> do+      entries <- traverse mkNameEntry [Column 0 .. maxColumn]+      pure $ Map.fromList (catMaybes entries)++{- |+  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+-}+mkColumnRowSource ::+  ExecutionResult result =>+  FieldName ->+  (SqlValue.SqlValue -> Either String a) ->+  result ->+  Column ->+  RowSource a+mkColumnRowSource sourceFieldName fromSqlValue result column =+  RowSource $ \row -> do+    sqlValue <- Result.getValue result row column++    case fromSqlValue sqlValue of+      Right value ->+        pure (Right value)+      Left err ->+        let+          details =+            MarshallError.DecodingErrorDetails+              { MarshallError.decodingErrorValues = [(fieldNameToByteString sourceFieldName, sqlValue)]+              , MarshallError.decodingErrorMessage = err+              }+        in+          pure (Left $ MarshallError.DecodingError details)++{- |+  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+  'marshallResultFromSqlUsingRowIdExtractor' and need to manually provide it.+  When possible, it's easier to annotate a 'SqlMarshaller' with the field names+  you would like rows to be identified by and then use 'marshallResultFromSql'+  instead.++@since 1.0.0.0+-}+newtype RowIdentityExtractor+  = RowIdentityExtractor (Row -> IO [(B8.ByteString, SqlValue.SqlValue)])++{- |+  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.++@since 1.0.0.0+-}+mkRowIdentityExtractor ::+  ExecutionResult result =>+  [FieldName] ->+  result ->+  RowIdentityExtractor+mkRowIdentityExtractor fields result =+  RowIdentityExtractor $ \row -> do+    let+      fieldNameSet =+        Set.fromList+          . fmap fieldNameToByteString+          $ fields++      getIdentityValue columnNumber = do+        mbColumnName <- Result.columnName result columnNumber++        case mbColumnName of+          Just name | Set.member name fieldNameSet -> do+            value <- Result.getValue result row columnNumber+            pure $ Just (name, value)+          _ ->+            pure Nothing++    mbMaxColumn <- Result.maxColumnNumber result++    case mbMaxColumn of+      Nothing ->+        pure []+      Just maxColumn ->+        fmap catMaybes $ traverse getIdentityValue [Column 0 .. maxColumn]++{- |+  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+  pass values read from the database to a constructor function to rebuild the+  entity containing the field, like so:++  @++  data Foo = Foo { bar :: Int32, baz :: Text }++  fooMarshaller :: SqlMarshaller Foo Foo+  fooMarshaller =+    Foo+      \<$\> marshallField bar (integerField "bar")+      \<*\> marshallField baz (unboundedTextField "baz")++  @++@since 1.0.0.0+-}+marshallField ::+  (writeEntity -> fieldValue) ->+  FieldDefinition nullability fieldValue ->+  SqlMarshaller writeEntity fieldValue+marshallField accessor fieldDef =+  MarshallNest accessor (MarshallField fieldDef)++{- |+  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+  be referenced.++  @+  data AgeCheck+    { atLeast21 :: Bool+    }++  fooMarshaller :: SqlMarshaller Void AgeCheck+  fooMarshaller =+    AgeCheck+      \<*\> Orville.marshallSyntheticField atLeast21Field++  atLeast21Field :: SyntheticField Bool+  atLeast21Field =+    SyntheticField+      { syntheticFieldExpression = RawSql.unsafeSqlExpression "age >= 21"+      , syntheticFieldAlias = Orville.stringToFieldName "over21"+      , syntheticFieldValueFromSqlValue = SqlValue.toBool+      }+  @++@since 1.0.0.0+-}+marshallSyntheticField ::+  SyntheticField fieldValue ->+  SqlMarshaller writeEntity fieldValue+marshallSyntheticField =+  MarshallSyntheticField++{- |+  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.++  For Example:++  @+  data Person =+    Person+      { personId :: PersonId+      , personName :: Name+      }++  data Name =+    Name+      { firstName :: Text+      , lastName :: Text+      }++  personMarshaller :: SqlMarshaller Person Person+  personMarshaller =+    Person+      \<$\> marshallField personId personIdField+      \<*\> marshallNested personName nameMarshaller++  nameMarshaller :: SqlMarshaller Name Name+  nameMarshaller =+    Name+      \<$\> marshallField firstName firstNameField+      \<*\> marshallField lastName lastNameField+  @++@since 1.0.0.0+-}+marshallNested ::+  (parentEntity -> nestedWriteEntity) ->+  SqlMarshaller nestedWriteEntity nestedReadEntity ->+  SqlMarshaller parentEntity nestedReadEntity+marshallNested =+  MarshallNest++{- |+  Lifts a 'SqlMarshaller' to have both read/write entities be 'Maybe',+  and applies a tag to avoid double mapping.++@since 1.0.0.0+-}+marshallMaybe :: SqlMarshaller a b -> SqlMarshaller (Maybe a) (Maybe b)+marshallMaybe =+  -- rewrite the mapper to handle null fields, then tag+  -- it as having been done so we don't double-map it+  -- in a future 'maybeMapper' call.+  MarshallMaybeTag . go+ where+  go :: SqlMarshaller a b -> SqlMarshaller (Maybe a) (Maybe b)+  go marshaller =+    case marshaller of+      MarshallPure a ->+        MarshallPure $ pure a+      MarshallApply func a ->+        MarshallApply (fmap (<*>) $ go func) (go a)+      MarshallNest f a ->+        MarshallNest (fmap f) (go a)+      (MarshallMaybeTag _) ->+        Just <$> MarshallNest join marshaller+      MarshallField field ->+        case fieldNullability field of+          NotNullField f -> MarshallField (nullableField f)+          NullableField f -> MarshallField (asymmetricNullableField f)+      MarshallSyntheticField synthField ->+        MarshallSyntheticField (nullableSyntheticField synthField)+      MarshallPartial m ->+        MarshallPartial (fmap sequence $ go m)+      MarshallReadOnly m ->+        MarshallReadOnly (go m)++{- |+  Builds a 'SqlMarshaller' that will raise a decoding error when the value+  produced is a 'Left'.++@since 1.0.0.0+-}+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+  and synthetic fields in a 'SqlMarshaller'.++@since 1.0.0.0+-}+prefixMarshaller ::+  String ->+  SqlMarshaller readEntity writeEntity ->+  SqlMarshaller readEntity writeEntity+prefixMarshaller prefix = go+ where+  go :: SqlMarshaller a b -> SqlMarshaller a b+  go marshaller = case marshaller of+    MarshallPure b -> MarshallPure b+    MarshallApply m1 m2 ->+      MarshallApply (go m1) $ go m2+    MarshallNest f m ->+      MarshallNest f $ go m+    MarshallField fieldDefinition ->+      MarshallField $ prefixField prefix fieldDefinition+    MarshallSyntheticField syntheticField ->+      MarshallSyntheticField $ prefixSyntheticField prefix syntheticField+    MarshallMaybeTag m -> MarshallMaybeTag $ go m+    MarshallPartial m -> MarshallPartial $ go m+    MarshallReadOnly m -> MarshallReadOnly $ go m++{- |+  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.++@since 1.0.0.0+-}+marshallReadOnly :: SqlMarshaller a b -> SqlMarshaller c b+marshallReadOnly = MarshallReadOnly++{- |+  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.++@since 1.0.0.0+-}+marshallReadOnlyField ::+  FieldDefinition nullability fieldValue ->+  SqlMarshaller writeEntity fieldValue+marshallReadOnlyField = MarshallReadOnly . MarshallField
+ src/Orville/PostgreSQL/Marshall/SqlType.hs view
@@ -0,0 +1,464 @@+{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++This module provides functions and types for describing a single-column data+type that exists in PostgreSQL so that Orville can determine how to serialize+Haskell values to and from the SQL type. If you need to use a SQL type that+Orville does not provide support for here, you can construct your own 'SqlType'+value and use 'Orville.PostgreSQL.Marshall.fieldOfType' to build the required+'Orville.PostgreSQL.Marshall.FieldDefinition'.++@since 1.0.0.0+-}+module Orville.PostgreSQL.Marshall.SqlType+  ( SqlType+      ( SqlType+      , sqlTypeExpr+      , sqlTypeReferenceExpr+      , sqlTypeOid+      , sqlTypeMaximumLength+      , sqlTypeToSql+      , sqlTypeFromSql+      , sqlTypeDontDropImplicitDefaultDuringMigrate+      )+  -- numeric types+  , integer+  , serial+  , bigInteger+  , bigSerial+  , smallInteger+  , double+  -- textual-ish types+  , boolean+  , unboundedText+  , fixedText+  , boundedText+  , textSearchVector+  , uuid+  -- date types+  , date+  , timestamp+  , timestampWithoutZone+  -- json types+  , jsonb+  -- postgresql types+  , oid+  -- type conversions+  , foreignRefType+  , convertSqlType+  , tryConvertSqlType+  )+where++import Data.Int (Int16, Int32, Int64)+import Data.Text (Text)+import qualified Data.Time as Time+import qualified Data.UUID as UUID+import qualified Database.PostgreSQL.LibPQ as LibPQ+import qualified Foreign.C.Types as CTypes++import qualified Orville.PostgreSQL.Expr as Expr+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+  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.++@since 1.0.0.0+-}+data SqlType a = SqlType+  { sqlTypeExpr :: Expr.DataType+  -- ^ The SQL data type expression to use when creating/migrating columns of+  -- this type.+  , sqlTypeReferenceExpr :: Maybe Expr.DataType+  -- ^ The SQL data type expression to use when creating/migrating columns+  -- with foreign keys to this type. This is used by 'foreignRefType' to build a+  -- new SqlType when making foreign key fields.+  , sqlTypeOid :: LibPQ.Oid+  -- ^ The Oid for the type in PostgreSQL. This will be used during+  -- migrations to determine whether the column type needs to be altered.+  , sqlTypeMaximumLength :: Maybe Int32+  -- ^ The maximum length for types that take a type parameter (such as+  -- @char@ and @varchar@). This will be used during migration to determine+  -- whether the column type needs to be altered.+  , sqlTypeToSql :: a -> SqlValue+  -- ^ A function for converting Haskell values of this type into values to+  -- be stored in the database.+  , sqlTypeFromSql :: SqlValue -> Either String a+  -- ^ A function for converting values of this type stored in the database+  -- into Haskell values. This function should return 'Left' to indicate+  -- an error if the conversion is impossible. Otherwise it should return+  -- a 'Right' of the corresponding @a@ value.+  , sqlTypeDontDropImplicitDefaultDuringMigrate :: Bool+  -- ^ The SERIAL and BIGSERIAL PostgreSQL types are really pseudo-types that+  -- create an implicit default value. This flag tells Orville's auto-migration+  -- 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.++@since 1.0.0.0+-}+integer :: SqlType Int32+integer =+  SqlType+    { sqlTypeExpr = Expr.int+    , sqlTypeReferenceExpr = Nothing+    , sqlTypeOid = LibPQ.Oid 23+    , sqlTypeMaximumLength = Nothing+    , sqlTypeToSql = SqlValue.fromInt32+    , sqlTypeFromSql = SqlValue.toInt32+    , sqlTypeDontDropImplicitDefaultDuringMigrate = False+    }++{- |+  'serial' defines a 32-bit auto-incrementing column type. This corresponds to+  the "SERIAL" type in PostgreSQL.++@since 1.0.0.0+-}+serial :: SqlType Int32+serial =+  SqlType+    { sqlTypeExpr = Expr.serial+    , sqlTypeReferenceExpr = Just Expr.int+    , sqlTypeOid = LibPQ.Oid 23+    , sqlTypeMaximumLength = Nothing+    , sqlTypeToSql = SqlValue.fromInt32+    , sqlTypeFromSql = SqlValue.toInt32+    , sqlTypeDontDropImplicitDefaultDuringMigrate = True+    }++{- |+  'bigInteger' defines a 64-bit integer type. This corresponds to the "BIGINT"+  type in SQL.++@since 1.0.0.0+-}+bigInteger :: SqlType Int64+bigInteger =+  SqlType+    { sqlTypeExpr = Expr.bigInt+    , sqlTypeReferenceExpr = Nothing+    , sqlTypeOid = LibPQ.Oid 20+    , sqlTypeMaximumLength = Nothing+    , sqlTypeToSql = SqlValue.fromInt64+    , sqlTypeFromSql = SqlValue.toInt64+    , sqlTypeDontDropImplicitDefaultDuringMigrate = False+    }++{- |+  'bigSerial' defines a 64-bit auto-incrementing column type. This corresponds to+  the "BIGSERIAL" type in PostgresSQL.++@since 1.0.0.0+-}+bigSerial :: SqlType Int64+bigSerial =+  SqlType+    { sqlTypeExpr = Expr.bigSerial+    , sqlTypeReferenceExpr = Just Expr.bigInt+    , sqlTypeOid = LibPQ.Oid 20+    , sqlTypeMaximumLength = Nothing+    , sqlTypeToSql = SqlValue.fromInt64+    , sqlTypeFromSql = SqlValue.toInt64+    , sqlTypeDontDropImplicitDefaultDuringMigrate = True+    }++{- |+  'smallInteger' defines a 16-bit integer type. This corresponds to the "SMALLINT" type in SQL.++@since 1.0.0.0+-}+smallInteger :: SqlType Int16+smallInteger =+  SqlType+    { sqlTypeExpr = Expr.smallint+    , sqlTypeReferenceExpr = Nothing+    , sqlTypeOid = LibPQ.Oid 21+    , sqlTypeMaximumLength = Nothing+    , sqlTypeToSql = SqlValue.fromInt16+    , sqlTypeFromSql = SqlValue.toInt16+    , sqlTypeDontDropImplicitDefaultDuringMigrate = False+    }++{- |+  'double' defines a floating point numeric type. This corresponds to the+  "DOUBLE PRECISION" type in SQL.++@since 1.0.0.0+-}+double :: SqlType Double+double =+  SqlType+    { sqlTypeExpr = Expr.doublePrecision+    , sqlTypeReferenceExpr = Nothing+    , sqlTypeOid = LibPQ.Oid 701+    , sqlTypeMaximumLength = Nothing+    , sqlTypeToSql = SqlValue.fromDouble+    , sqlTypeFromSql = SqlValue.toDouble+    , sqlTypeDontDropImplicitDefaultDuringMigrate = False+    }++{- |+  'boolean' defines a True/False boolean type. This corresponds to the "BOOLEAN"+  type in SQL.++@since 1.0.0.0+-}+boolean :: SqlType Bool+boolean =+  SqlType+    { sqlTypeExpr = Expr.boolean+    , sqlTypeReferenceExpr = Nothing+    , sqlTypeOid = LibPQ.Oid 16+    , sqlTypeMaximumLength = Nothing+    , sqlTypeToSql = SqlValue.fromBool+    , sqlTypeFromSql = SqlValue.toBool+    , sqlTypeDontDropImplicitDefaultDuringMigrate = False+    }++{- |+  'unboundedText' defines an unbounded length text field type. This corresponds to a+  "TEXT" type in PostgreSQL.++@since 1.0.0.0+-}+unboundedText :: SqlType Text+unboundedText =+  SqlType+    { sqlTypeExpr = Expr.text+    , sqlTypeReferenceExpr = Nothing+    , sqlTypeOid = LibPQ.Oid 25+    , sqlTypeMaximumLength = Nothing+    , sqlTypeToSql = SqlValue.fromText+    , sqlTypeFromSql = SqlValue.toText+    , sqlTypeDontDropImplicitDefaultDuringMigrate = False+    }++{- |+  'fixedText' defines a fixed length text field type. This corresponds to a+  "CHAR(len)" type in PostgreSQL.++@since 1.0.0.0+-}+fixedText :: Int32 -> SqlType Text+fixedText len =+  SqlType+    { sqlTypeExpr = Expr.char len+    , sqlTypeReferenceExpr = Nothing+    , sqlTypeOid = LibPQ.Oid 1042+    , sqlTypeMaximumLength = Just len+    , sqlTypeToSql = SqlValue.fromText+    , sqlTypeFromSql = SqlValue.toText+    , sqlTypeDontDropImplicitDefaultDuringMigrate = False+    }++{- |+  'boundedText' defines a variable length text field type. This corresponds to a+  "VARCHAR(len)" type in PostgreSQL.++@since 1.0.0.0+-}+boundedText :: Int32 -> SqlType Text+boundedText len =+  SqlType+    { sqlTypeExpr = Expr.varchar len+    , sqlTypeReferenceExpr = Nothing+    , sqlTypeOid = LibPQ.Oid 1043+    , sqlTypeMaximumLength = Just len+    , sqlTypeToSql = SqlValue.fromText+    , sqlTypeFromSql = SqlValue.toText+    , sqlTypeDontDropImplicitDefaultDuringMigrate = False+    }++{- |+  'textSearchVector' defines a type for indexed text searching. It corresponds to the+  "TSVECTOR" type in PostgreSQL.++@since 1.0.0.0+-}+textSearchVector :: SqlType Text+textSearchVector =+  SqlType+    { sqlTypeExpr = Expr.tsvector+    , sqlTypeReferenceExpr = Nothing+    , sqlTypeOid = LibPQ.Oid 3614+    , sqlTypeMaximumLength = Nothing+    , sqlTypeToSql = SqlValue.fromText+    , sqlTypeFromSql = SqlValue.toText+    , sqlTypeDontDropImplicitDefaultDuringMigrate = False+    }++{- |+  'uuid' defines a UUID type. It corresponds to the "UUID" type in PostgreSQL.++@since 1.0.0.0+-}+uuid :: SqlType UUID.UUID+uuid =+  let+    uuidFromText t =+      case UUID.fromText t of+        Nothing -> Left "Invalid UUID value"+        Just validUuid -> Right validUuid+  in+    SqlType+      { sqlTypeExpr = Expr.uuid+      , sqlTypeReferenceExpr = Nothing+      , sqlTypeOid = LibPQ.Oid 2950+      , sqlTypeMaximumLength = Nothing+      , sqlTypeToSql = SqlValue.fromText . UUID.toText+      , sqlTypeFromSql = \a -> uuidFromText =<< SqlValue.toText a+      , sqlTypeDontDropImplicitDefaultDuringMigrate = False+      }++{- |+  'date' defines a type representing a calendar date (without time zone). It corresponds+  to the "DATE" type in SQL.++@since 1.0.0.0+-}+date :: SqlType Time.Day+date =+  SqlType+    { sqlTypeExpr = Expr.date+    , sqlTypeReferenceExpr = Nothing+    , sqlTypeOid = LibPQ.Oid 1082+    , sqlTypeMaximumLength = Nothing+    , sqlTypeToSql = SqlValue.fromDay+    , sqlTypeFromSql = SqlValue.toDay+    , sqlTypeDontDropImplicitDefaultDuringMigrate = False+    }++{- |+  '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.++  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:+  http://blog.untrod.com/2016/08/actually-understanding-timezones-in-postgresql.html++@since 1.0.0.0+-}+timestamp :: SqlType Time.UTCTime+timestamp =+  SqlType+    { sqlTypeExpr = Expr.timestampWithZone+    , sqlTypeReferenceExpr = Nothing+    , sqlTypeOid = LibPQ.Oid 1184+    , sqlTypeMaximumLength = Nothing+    , sqlTypeToSql = SqlValue.fromUTCTime+    , sqlTypeFromSql = SqlValue.toUTCTime+    , sqlTypeDontDropImplicitDefaultDuringMigrate = False+    }++{- |+  'timestampWithoutZone' defines a type representing a particular point in time (without time zone).+  It corresponds to the "TIMESTAMP without time zone" type in SQL.++  http://blog.untrod.com/2016/08/actually-understanding-timezones-in-postgresql.html++@since 1.0.0.0+-}+timestampWithoutZone :: SqlType Time.LocalTime+timestampWithoutZone =+  SqlType+    { sqlTypeExpr = Expr.timestampWithoutZone+    , sqlTypeReferenceExpr = Nothing+    , sqlTypeOid = LibPQ.Oid 1114+    , sqlTypeMaximumLength = Nothing+    , sqlTypeToSql = SqlValue.fromLocalTime+    , sqlTypeFromSql = SqlValue.toLocalTime+    , sqlTypeDontDropImplicitDefaultDuringMigrate = False+    }++{- |+   'jsonb' represents any type that can be converted To and From JSON. This corresponds+   to the "JSONB" type in PostgreSQL.++@since 1.0.0.0+-}+jsonb :: SqlType Text+jsonb =+  SqlType+    { sqlTypeExpr = Expr.jsonb+    , sqlTypeReferenceExpr = Nothing+    , sqlTypeOid = LibPQ.Oid 3802+    , sqlTypeMaximumLength = Nothing+    , sqlTypeToSql = SqlValue.fromText+    , sqlTypeFromSql = SqlValue.toText+    , sqlTypeDontDropImplicitDefaultDuringMigrate = False+    }++{- |+  'oid' corresponds to the type used in PostgreSQL for identifying system+  objects.++@since 1.0.0.0+-}+oid :: SqlType LibPQ.Oid+oid =+  SqlType+    { sqlTypeExpr = Expr.oid+    , sqlTypeReferenceExpr = Nothing+    , sqlTypeOid = LibPQ.Oid 26+    , sqlTypeMaximumLength = Nothing+    , sqlTypeToSql = \(LibPQ.Oid (CTypes.CUInt word)) -> SqlValue.fromWord32 word+    , sqlTypeFromSql = fmap (LibPQ.Oid . CTypes.CUInt) . SqlValue.toWord32+    , sqlTypeDontDropImplicitDefaultDuringMigrate = False+    }++{- |+  '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+  have a regular underlying SQL type. Each 'SqlType' definition must specify any+  special handling required when creating foreign reference types by setting+  the 'sqlTypeReferenceExpr' field to an appropriate value.++@since 1.0.0.0+-}+foreignRefType :: SqlType a -> SqlType a+foreignRefType sqlType =+  case sqlTypeReferenceExpr sqlType of+    Nothing -> sqlType+    Just refExpr -> sqlType {sqlTypeExpr = refExpr, sqlTypeReferenceExpr = Nothing}++{- |+  '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+  an @a@ value from the database, the conversion function should produce 'Left'+  with an error message if the value cannot be successfully converted to a @b@.++@since 1.0.0.0+-}+tryConvertSqlType :: (b -> a) -> (a -> Either String b) -> SqlType a -> SqlType b+tryConvertSqlType bToA aToB sqlType =+  sqlType+    { sqlTypeToSql = sqlTypeToSql sqlType . bToA+    , sqlTypeFromSql = \sql -> do+        a <- sqlTypeFromSql sqlType sql+        aToB a+    }++{- |+  '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+-}+convertSqlType :: (b -> a) -> (a -> b) -> SqlType a -> SqlType b+convertSqlType bToA aToB =+  tryConvertSqlType bToA (Right . aToB)
+ src/Orville/PostgreSQL/Marshall/SyntheticField.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE OverloadedStrings #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Marshall.SyntheticField+  ( SyntheticField+  , syntheticFieldExpression+  , syntheticFieldAlias+  , syntheticFieldValueFromSqlValue+  , syntheticField+  , nullableSyntheticField+  , prefixSyntheticField+  )+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 qualified Orville.PostgreSQL.Raw.SqlValue as SqlValue++{- |+  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+  }++{- |+  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++{- |+  Returns the alias that should be used in select statements to name the+  synthetic field.++@since 1.0.0.0+-}+syntheticFieldAlias :: SyntheticField a -> FieldName+syntheticFieldAlias =+  _syntheticFieldAlias++{- |+  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++{- |+  Constructs a 'SyntheticField' that will select a SQL expression using+  the given alias.++@since 1.0.0.0+-}+syntheticField ::+  -- | The SQL expression to be selected.+  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) ->+  SyntheticField a+syntheticField expression alias fromSqlValue =+  SyntheticField+    { _syntheticFieldExpression = expression+    , _syntheticFieldAlias = stringToFieldName alias+    , _syntheticFieldValueFromSqlValue = fromSqlValue+    }++{- |+  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+    }++{- |+  Adds a prefix, followed by an underscore, to the alias used to name the+  synthetic field.++@since 1.0.0.0+-}+prefixSyntheticField ::+  String ->+  SyntheticField a ->+  SyntheticField a+prefixSyntheticField prefix synthField =+  synthField+    { _syntheticFieldAlias = byteStringToFieldName (B8.pack prefix <> "_" <> fieldNameToByteString (syntheticFieldAlias synthField))+    }
+ src/Orville/PostgreSQL/Monad.hs view
@@ -0,0 +1,27 @@+{-# OPTIONS_GHC -Wno-missing-import-lists #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++You can import "Orville.PostgreSQL.Monad" to get access to all the functions+related to managing Orville context within an application Monad. This includes+a number of lower-level items not exported by "Orville.PostgreSQL" that give+you more control (and therefore responsibility) over the Monad context.++@since 1.0.0.0+-}+module Orville.PostgreSQL.Monad+  ( module Orville.PostgreSQL.Monad.Orville+  , module Orville.PostgreSQL.Monad.HasOrvilleState+  , module Orville.PostgreSQL.Monad.MonadOrville+  )+where++-- Note: we list the re-exports explicity above to control the order that they+-- appear in the generated haddock documentation.++import Orville.PostgreSQL.Monad.HasOrvilleState+import Orville.PostgreSQL.Monad.MonadOrville+import Orville.PostgreSQL.Monad.Orville
+ src/Orville/PostgreSQL/Monad/HasOrvilleState.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Monad.HasOrvilleState+  ( HasOrvilleState (askOrvilleState, localOrvilleState)+  )+where++import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader (ReaderT, ask, local, mapReaderT)++import Orville.PostgreSQL.OrvilleState (OrvilleState)++{- |+  '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+  context and want to simply add 'OrvilleState' as an attribute to that+  context, like so++  @+    data MyApplicationState =+      MyApplicationState+        { appConfig :: MyAppConfig+        , appOrvilleState :: OrvilleState+        }++    newtype MyApplicationMonad a =+      MyApplicationMonad (ReaderT MyApplicationState IO) a++    instance HasOrvilleState MyApplicationMonad where+      askOrvilleState =+        MyApplicationMonad (asks appOrvilleState)++      localOrvilleState f (MyApplicationMonad reader) =+        MyApplicationMonad $+          local+            (\\state -> state { appOrvilleState = f (appOrvilleState state))+            reader+  @++  An instance for 'ReaderT OrvilleState m' is provided as a convenience in+  the case that your application has no extra context to track.++@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'.+  --+  -- @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'.+  --+  -- @since 1.0.0.0+  localOrvilleState ::+    -- | The function to modify the 'OrvilleState'.+    (OrvilleState -> OrvilleState) ->+    -- | The monad operation to execute with the modified state.+    m a ->+    m a++instance Monad m => HasOrvilleState (ReaderT OrvilleState m) where+  askOrvilleState = ask+  localOrvilleState = local++instance {-# OVERLAPS #-} (Monad m, HasOrvilleState m) => HasOrvilleState (ReaderT r m) where+  askOrvilleState = lift askOrvilleState+  localOrvilleState f = mapReaderT (localOrvilleState f)
+ src/Orville/PostgreSQL/Monad/MonadOrville.hs view
@@ -0,0 +1,16 @@+{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Monad.MonadOrville+  ( MonadOrville.MonadOrville+  , MonadOrville.MonadOrvilleControl (liftWithConnection, liftCatch, liftMask)+  , MonadOrville.withConnection+  , MonadOrville.withConnection_+  )+where++import qualified Orville.PostgreSQL.Internal.MonadOrville as MonadOrville
+ src/Orville/PostgreSQL/Monad/Orville.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Monad.Orville+  ( Orville+  , runOrville+  , runOrvilleWithState+  )+where++import qualified Control.Exception.Safe as ExSafe+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Trans.Reader (ReaderT, runReaderT)++import qualified Orville.PostgreSQL.ErrorDetailLevel as ErrorDetailLevel+import qualified Orville.PostgreSQL.Monad.HasOrvilleState as HasOrvilleState+import qualified Orville.PostgreSQL.Monad.MonadOrville as MonadOrville+import qualified Orville.PostgreSQL.OrvilleState as OrvilleState+import Orville.PostgreSQL.Raw.Connection (ConnectionPool)++{- |+  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.++  If you want to add Orville capabilities to your own monad, take a look at+  'MonadOrville.MonadOrville' to learn what needs to be done.++@since 1.0.0.0+-}+newtype Orville a = Orville+  { unwrapOrville :: ReaderT OrvilleState.OrvilleState IO a+  }+  deriving+    ( Functor+    , Applicative+    , Monad+    , MonadIO+    , MonadOrville.MonadOrvilleControl+    , MonadOrville.MonadOrville+    , HasOrvilleState.HasOrvilleState+    , ExSafe.MonadThrow+    , ExSafe.MonadCatch+    )++{- |+  Runs an 'Orville' operation in the 'IO' monad using the given connection+  pool.++  This will run the 'Orville' operation with the+  'ErrorDetailLevel.ErrorDetailLevel' set to the default. If you want to run+  with a different detail level, you can use 'OrvilleState.newOrvilleState' to+  create a state with the desired detail level and then use+  'runOrvilleWithState'.++@since 1.0.0.0+-}+runOrville :: ConnectionPool -> Orville a -> IO a+runOrville =+  runOrvilleWithState+    . OrvilleState.newOrvilleState ErrorDetailLevel.defaultErrorDetailLevel++{- |+  Runs an 'Orville' operation in the 'IO' monad, starting from the provided+  'OrvilleState.OrvilleState'.++  Caution: If you harvest an 'OrvilleState.OrvilleState' from inside a+  'MonadOrville.MonadOrville' monad using 'MonadOrville.askOrvilleState',+  you may pick up connection tracking state that you didn't intend to. You+  may want to use 'MonadOrville.resetOrvilleState' in this situation to get+  a new initial state before passing it to 'runOrvilleWithState'.++  On the other hand, if you know that you want to pass the existing connection+  state from another monad into the 'Orville' monad, this is how you do it.++@since 1.0.0.0+-}+runOrvilleWithState :: OrvilleState.OrvilleState -> Orville a -> IO a+runOrvilleWithState state orville =+  runReaderT (unwrapOrville orville) state
+ src/Orville/PostgreSQL/OrvilleState.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE RankNTypes #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.OrvilleState+  ( OrvilleState.OrvilleState+  , OrvilleState.newOrvilleState+  , OrvilleState.resetOrvilleState+  , OrvilleState.orvilleConnectionPool+  , OrvilleState.orvilleErrorDetailLevel+  , OrvilleState.orvilleTransactionCallback+  , OrvilleState.orvilleSqlCommenterAttributes+  , OrvilleState.addTransactionCallback+  , OrvilleState.TransactionEvent (BeginTransaction, NewSavepoint, ReleaseSavepoint, RollbackToSavepoint, CommitTransaction, RollbackTransaction)+  , OrvilleState.Savepoint+  , OrvilleState.savepointNestingLevel+  , OrvilleState.initialSavepoint+  , OrvilleState.nextSavepoint+  , OrvilleState.orvilleSqlExecutionCallback+  , OrvilleState.addSqlExecutionCallback+  , OrvilleState.orvilleBeginTransactionExpr+  , OrvilleState.setBeginTransactionExpr+  , OrvilleState.setSqlCommenterAttributes+  , OrvilleState.addSqlCommenterAttributes+  )+where++import qualified Orville.PostgreSQL.Internal.OrvilleState as OrvilleState
+ src/Orville/PostgreSQL/PgCatalog.hs view
@@ -0,0 +1,23 @@+{-# OPTIONS_GHC -Wno-missing-import-lists #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.PgCatalog+  ( module Export+  )+where++import Orville.PostgreSQL.PgCatalog.DatabaseDescription as Export+import Orville.PostgreSQL.PgCatalog.OidField as Export+import Orville.PostgreSQL.PgCatalog.PgAttribute as Export+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.PgIndex as Export+import Orville.PostgreSQL.PgCatalog.PgNamespace as Export+import Orville.PostgreSQL.PgCatalog.PgSequence as Export
+ src/Orville/PostgreSQL/PgCatalog/DatabaseDescription.hs view
@@ -0,0 +1,435 @@+{-# LANGUAGE CPP #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.PgCatalog.DatabaseDescription+  ( DatabaseDescription (..)+  , RelationDescription (..)+  , ConstraintDescription (..)+  , ForeignRelationDescription (..)+  , IndexDescription (..)+  , IndexMember (..)+  , lookupRelation+  , lookupRelationOfKind+  , lookupAttribute+  , lookupAttributeDefault+  , describeDatabaseRelations+  )+where++#if MIN_VERSION_base(4,18,0)+#else+import Control.Applicative (liftA2)+#endif+import qualified Data.Map.Strict as Map+import qualified Database.PostgreSQL.LibPQ as LibPQ++import qualified Orville.PostgreSQL as Orville+import Orville.PostgreSQL.PgCatalog.OidField (oidField)+import Orville.PostgreSQL.PgCatalog.PgAttribute (AttributeName, AttributeNumber, PgAttribute (pgAttributeName, pgAttributeNumber), attributeIsDroppedField, attributeNumberToInt16, attributeRelationOidField, pgAttributeTable)+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.PgIndex (PgIndex (pgIndexAttributeNumbers, pgIndexPgClassOid), indexIsLiveField, indexRelationOidField, pgIndexTable)+import Orville.PostgreSQL.PgCatalog.PgNamespace (NamespaceName, PgNamespace (pgNamespaceOid), namespaceNameField, pgNamespaceTable)+import Orville.PostgreSQL.PgCatalog.PgSequence (PgSequence, pgSequenceTable, sequencePgClassOidField)+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+  items.++@since 1.0.0.0+-}+data DatabaseDescription = DatabaseDescription+  { databaseRelations :: Map.Map (NamespaceName, RelationName) RelationDescription+  }++{- |+  Lookup a relation by its qualified name in the @pg_catalog@ schema.++@since 1.0.0.0+-}+lookupRelation ::+  (NamespaceName, RelationName) ->+  DatabaseDescription ->+  Maybe RelationDescription+lookupRelation key =+  Map.lookup key . databaseRelations++{- |+  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+-}+lookupRelationOfKind ::+  RelationKind ->+  (NamespaceName, RelationName) ->+  DatabaseDescription ->+  Maybe RelationDescription+lookupRelationOfKind kind key dbDesc =+  case Map.lookup key (databaseRelations dbDesc) of+    Just relation ->+      if pgClassRelationKind (relationRecord relation) == kind+        then Just relation+        else Nothing+    Nothing ->+      Nothing++{- |+  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+  , relationAttributes :: Map.Map AttributeName PgAttribute+  , relationAttributeDefaults :: Map.Map AttributeNumber PgAttributeDefault+  , relationConstraints :: [ConstraintDescription]+  , relationIndexes :: [IndexDescription]+  , relationSequence :: Maybe PgSequence+  }++{- |+  Find an attribute by name from the 'RelationDescription'.++@since 1.0.0.0+-}+lookupAttribute ::+  AttributeName ->+  RelationDescription ->+  Maybe PgAttribute+lookupAttribute key =+  Map.lookup key . relationAttributes++{- |+  Find an attribute default from the 'RelationDescription'.++@since 1.0.0.0+-}+lookupAttributeDefault ::+  PgAttribute ->+  RelationDescription ->+  Maybe PgAttributeDefault+lookupAttributeDefault attr =+  Map.lookup (pgAttributeNumber attr) . relationAttributeDefaults++{- |+  A description of a particular constraint in the PostgreSQL database, including+  the attributes and relations that it references.++@since 1.0.0.0+-}+data ConstraintDescription = ConstraintDescription+  { constraintRecord :: PgConstraint+  , constraintKey :: Maybe [PgAttribute]+  , constraintForeignRelation :: Maybe ForeignRelationDescription+  , constraintForeignKey :: Maybe [PgAttribute]+  }++{- |+  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+-}+data ForeignRelationDescription = ForeignRelationDescription+  { foreignRelationClass :: PgClass+  , foreignRelationNamespace :: PgNamespace+  }++{- |+  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).++@since 1.0.0.0+-}+data IndexDescription = IndexDescription+  { indexRecord :: PgIndex+  , indexPgClass :: PgClass+  , indexMembers :: [IndexMember]+  }++{- |+  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.++@since 1.0.0.0+-}+data IndexMember+  = IndexAttribute PgAttribute+  | IndexExpression++{- |+  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+-}+describeDatabaseRelations ::+  Orville.MonadOrville m =>+  [(NamespaceName, RelationName)] ->+  m DatabaseDescription+describeDatabaseRelations relations = do+  manyRelations <-+    Plan.execute+      (Plan.planMany describeRelationByName)+      relations++  let+    relationsMap =+      Map.mapMaybe id+        . Many.toMap+        $ manyRelations++  pure $+    DatabaseDescription+      { databaseRelations = relationsMap+      }++describeRelationByName :: Plan.Plan scope (NamespaceName, RelationName) (Maybe RelationDescription)+describeRelationByName =+  Plan.bind (fst <$> Plan.askParam) $ \namespaceName ->+    Plan.bind (snd <$> Plan.askParam) $ \relationName ->+      Plan.bind (Plan.using namespaceName findNamespace) $ \namespace ->+        let+          namespaceAndRelName =+            (,) <$> Plan.use namespace <*> Plan.use relationName+        in+          Plan.bind (Plan.chain namespaceAndRelName findRelation) $ \maybePgClass ->+            Plan.using maybePgClass (Plan.planMaybe describeRelationByClass)++describeRelationByClass :: Plan.Plan scope PgClass RelationDescription+describeRelationByClass =+  Plan.bind Plan.askParam $ \pgClass ->+    Plan.bind findClassAttributes $ \attributes ->+      let+        classAndAttributes =+          mkPgClassAndAttributes+            <$> 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++findRelation :: Plan.Plan scope (PgNamespace, RelationName) (Maybe PgClass)+findRelation =+  Plan.focusParam (\(ns, relname) -> (pgNamespaceOid ns, relname)) $+    Plan.planOperation $+      Op.findOne pgClassTable byNamespaceOidAndRelationName++byNamespaceOidAndRelationName :: Op.WherePlanner (LibPQ.Oid, RelationName)+byNamespaceOidAndRelationName =+  Op.byFieldTuple namespaceOidField relationNameField++findNamespace :: Plan.Plan scope NamespaceName PgNamespace+findNamespace =+  Plan.findOne pgNamespaceTable namespaceNameField++findClassAttributes :: Plan.Plan scope PgClass [PgAttribute]+findClassAttributes =+  Plan.focusParam pgClassOid $+    Plan.findAllWhere+      pgAttributeTable+      attributeRelationOidField+      (Orville.fieldEquals attributeIsDroppedField False)++findClassAttributeDefaults :: Plan.Plan scope PgClass [PgAttributeDefault]+findClassAttributeDefaults =+  Plan.focusParam pgClassOid $+    Plan.findAll+      pgAttributeDefaultTable+      attributeDefaultRelationOidField++findClassConstraints :: Plan.Plan scope PgClassAndAttributes [ConstraintDescription]+findClassConstraints =+  let+    relationOid =+      pgClassOid . pgClassRecord+  in+    Plan.bind (Plan.focusParam relationOid $ Plan.findAll pgConstraintTable constraintRelationOidField) $ \constraints ->+      Plan.bind Plan.askParam $ \pgClassAndAttrs ->+        Plan.chain+          (zip <$> Plan.use (fmap repeat pgClassAndAttrs) <*> Plan.use constraints)+          (Plan.planList describeConstraint)++describeConstraint :: Plan.Plan scope (PgClassAndAttributes, PgConstraint) ConstraintDescription+describeConstraint =+  let+    prepareAttributeLookups :: (PgClassAndAttributes, PgConstraint) -> Maybe [(PgClassAndAttributes, AttributeNumber)]+    prepareAttributeLookups (pgClassAndAttrs, pgConstraint) =+      case pgConstraintKey pgConstraint of+        Nothing -> Nothing+        Just key -> Just (fmap (\attNum -> (pgClassAndAttrs, attNum)) key)+  in+    Plan.bind (snd <$> Plan.askParam) $ \constraint ->+      Plan.bind (Plan.using constraint findConstraintForeignRelationClass) $ \maybeForeignPgClass ->+        let+          maybeForeignClassAndAttrNums =+            liftA2+              (liftA2 (,))+              (Plan.use maybeForeignPgClass)+              (fmap (pgConstraintForeignKey . snd) Plan.askParam)+        in+          ConstraintDescription+            <$> Plan.use constraint+            <*> Plan.focusParam prepareAttributeLookups (Plan.planMaybe $ Plan.planList findAttributeByNumber)+            <*> Plan.using maybeForeignPgClass (Plan.planMaybe describeForeignRelation)+            <*> Plan.chain maybeForeignClassAndAttrNums (Plan.planMaybe findForeignKeyAttributes)++describeForeignRelation :: Plan.Plan scope PgClass ForeignRelationDescription+describeForeignRelation =+  ForeignRelationDescription+    <$> Plan.askParam+    <*> Plan.focusParam pgClassNamespaceOid (Plan.findOne pgNamespaceTable oidField)++findForeignKeyAttributes :: Plan.Plan scope (PgClass, [AttributeNumber]) [PgAttribute]+findForeignKeyAttributes =+  Plan.bind (fst <$> Plan.askParam) $ \pgClass ->+    Plan.bind (snd <$> Plan.askParam) $ \attrNums ->+      Plan.bind (Plan.focusParam fst findClassAttributes) $ \attributes ->+        let+          attrSource =+            mkPgClassAndAttributes+              <$> Plan.use pgClass+              <*> Plan.use attributes+        in+          Plan.chain+            (zip <$> fmap repeat attrSource <*> Plan.use attrNums)+            (Plan.planList findAttributeByNumber)++findConstraintForeignRelationClass :: Plan.Plan scope PgConstraint (Maybe PgClass)+findConstraintForeignRelationClass =+  let+    relationId constraint =+      case pgConstraintForeignRelationOid constraint of+        LibPQ.Oid 0 -> Nothing+        nonZero -> Just nonZero+  in+    Plan.focusParam relationId $+      Plan.planMaybe $+        Plan.findOne pgClassTable oidField++findClassIndexes :: Plan.Plan scope PgClassAndAttributes [IndexDescription]+findClassIndexes =+  let+    findIndexes :: Plan.Plan scope PgClassAndAttributes [PgIndex]+    findIndexes =+      Plan.focusParam (pgClassOid . pgClassRecord) $+        Plan.findAllWhere+          pgIndexTable+          indexRelationOidField+          (Orville.fieldEquals indexIsLiveField True)++    indexesWithClassAndAttrs :: Plan.Plan scope PgClassAndAttributes [(PgClassAndAttributes, PgIndex)]+    indexesWithClassAndAttrs =+      zip+        <$> fmap repeat Plan.askParam+        <*> findIndexes+  in+    Plan.chain indexesWithClassAndAttrs (Plan.planList describeIndex)++describeIndex :: Plan.Plan scope (PgClassAndAttributes, PgIndex) IndexDescription+describeIndex =+  let+    expressionsOrAttributeLookups ::+      PgClassAndAttributes ->+      [AttributeNumber] ->+      [Either IndexMember (PgClassAndAttributes, AttributeNumber)]+    expressionsOrAttributeLookups pgClassAndAttrs attNumList = do+      attNum <- attNumList+      pure $+        if attNum == 0+          then Left IndexExpression+          else Right (pgClassAndAttrs, attNum)++    indexMemberLookups ::+      Plan.Plan+        scope+        (PgClassAndAttributes, PgIndex)+        [Either IndexMember (PgClassAndAttributes, AttributeNumber)]+    indexMemberLookups =+      Plan.bind (fst <$> Plan.askParam) $ \pgClassAndAttrs ->+        Plan.bind (pgIndexAttributeNumbers . snd <$> Plan.askParam) $ \attNums ->+          expressionsOrAttributeLookups+            <$> Plan.use pgClassAndAttrs+            <*> Plan.use attNums++    resolveIndexMemberLookup ::+      Plan.Plan+        scope+        (Either IndexMember (PgClassAndAttributes, AttributeNumber))+        IndexMember+    resolveIndexMemberLookup =+      either id IndexAttribute+        <$> Plan.planEither Plan.askParam findAttributeByNumber+  in+    IndexDescription+      <$> fmap snd Plan.askParam+      <*> Plan.focusParam (pgIndexPgClassOid . snd) (Plan.findOne pgClassTable oidField)+      <*> Plan.chain indexMemberLookups (Plan.planList resolveIndexMemberLookup)++data PgClassAndAttributes = PgClassAndAttributes+  { pgClassRecord :: PgClass+  , pgClassAttributes :: Map.Map AttributeNumber PgAttribute+  }++mkPgClassAndAttributes :: PgClass -> [PgAttribute] -> PgClassAndAttributes+mkPgClassAndAttributes pgClass attributes =+  PgClassAndAttributes+    { pgClassRecord = pgClass+    , pgClassAttributes = indexBy pgAttributeNumber attributes+    }++findAttributeByNumber :: Plan.Plan scope (PgClassAndAttributes, AttributeNumber) PgAttribute+findAttributeByNumber =+  let+    lookupAttr (pgClassAndAttrs, attrNum) =+      Map.lookup attrNum (pgClassAttributes pgClassAndAttrs)++    assertFound ::+      (PgClassAndAttributes, AttributeNumber) ->+      Maybe PgAttribute ->+      Either String PgAttribute+    assertFound (pgClassAndAttrs, attrNum) maybeAttr =+      case maybeAttr of+        Nothing ->+          Left $+            "Unable to find attribute number "+              <> show (attributeNumberToInt16 attrNum)+              <> " of relation "+              <> (relationNameToString . pgClassRelationName . pgClassRecord $ pgClassAndAttrs)+        Just attr ->+          Right attr+  in+    Plan.assert assertFound $ fmap lookupAttr Plan.askParam++findClassSequence :: Plan.Plan scope PgClass (Maybe PgSequence)+findClassSequence =+  Plan.focusParam pgClassOid $+    Plan.findMaybeOne pgSequenceTable sequencePgClassOidField++indexBy :: Ord key => (row -> key) -> [row] -> Map.Map key row+indexBy rowKey =+  Map.fromList . fmap (\row -> (rowKey row, row))
+ src/Orville/PostgreSQL/PgCatalog/OidField.hs view
@@ -0,0 +1,36 @@+{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.PgCatalog.OidField+  ( oidField+  , oidTypeField+  )+where++import qualified Database.PostgreSQL.LibPQ as LibPQ++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.++@since 1.0.0.0+-}+oidField :: Orville.FieldDefinition Orville.NotNull LibPQ.Oid+oidField =+  oidTypeField "oid"++{- |+  Builds a 'Orville.FieldDefinition' with the given column name that stores+  an @oid@ value.++@since 1.0.0.0+-}+oidTypeField :: String -> Orville.FieldDefinition Orville.NotNull LibPQ.Oid+oidTypeField =+  Orville.fieldOfType SqlType.oid
+ src/Orville/PostgreSQL/PgCatalog/PgAttribute.hs view
@@ -0,0 +1,284 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.PgCatalog.PgAttribute+  ( PgAttribute (..)+  , pgAttributeMaxLength+  , AttributeName+  , attributeNameToString+  , AttributeNumber+  , attributeNumberToInt16+  , attributeNumberFromInt16+  , attributeNumberTextBuilder+  , attributeNumberParser+  , isOrdinaryColumn+  , pgAttributeTable+  , attributeRelationOidField+  , attributeNameField+  , attributeTypeOidField+  , attributeLengthField+  , attributeIsDroppedField+  , attributeNumberTypeField+  )+where++import qualified Data.Attoparsec.Text as AttoText+import Data.Int (Int16, Int32)+import qualified Data.String as String+import qualified Data.Text as T+import qualified Data.Text.Lazy.Builder as LTB+import qualified Data.Text.Lazy.Builder.Int as LTBI+import qualified Database.PostgreSQL.LibPQ as LibPQ++import qualified Orville.PostgreSQL as Orville+import Orville.PostgreSQL.PgCatalog.OidField (oidTypeField)++{- |+  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.++  See also 'Orville.PostgreSQL.PgCatalog.PgClass'.++@since 1.0.0.0+-}+data PgAttribute = PgAttribute+  { pgAttributeRelationOid :: LibPQ.Oid+  -- ^ The PostgreSQL @oid@ for the relation that this+  -- attribute belongs to. References @pg_class.oid@.+  , pgAttributeName :: AttributeName+  -- ^ The name of the attribute.+  , pgAttributeNumber :: AttributeNumber+  -- ^ The PostgreSQL number of the attribute.+  , pgAttributeTypeOid :: LibPQ.Oid+  -- ^ The PostgreSQL @oid@ for the type of this attribute. References+  -- @pg_type.oid@.+  , pgAttributeLength :: Int16+  -- ^ The length of this attribute\'s type (a copy of @pg_type.typlen@). Note+  -- that this is _NOT_ the maximum length of a @varchar@ column!+  , pgAttributeTypeModifier :: Int32+  -- ^ Type-specific data supplied at creation time, such as the maximum length+  -- of a @varchar@ column.+  , 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,+  or 'Nothing' if the length of the type is not variable.++@since 1.0.0.0+-}+pgAttributeMaxLength :: PgAttribute -> Maybe Int32+pgAttributeMaxLength attr =+  -- This function is a port of the following function from _pg_char_max_length+  -- function postgresql:+  --+  -- Note that it does not handle DOMAIN (user created) types correctly at the+  -- moment. Handling domain types would require loading the pg_type record and+  -- checking whether to use the typid and typmod from the attribute or the+  -- base type and typemod from the domain type.+  --+  let+    charTypes =+      [LibPQ.Oid 1042, LibPQ.Oid 1043] -- char, varchar+    bitTypes =+      [LibPQ.Oid 1560, LibPQ.Oid 1562] -- bit, varbit+    typeOid =+      pgAttributeTypeOid attr++    typeMod =+      pgAttributeTypeModifier attr+  in+    if typeMod == -1+      then Nothing+      else+        if typeOid `elem` charTypes+          then Just (typeMod - 4)+          else+            if typeOid `elem` bitTypes+              then Just typeMod+              else Nothing++{- |+  Determines whether the attribute represents a system column by inspecting+  the attribute\'s 'AttributeNumber'. Ordinary columns have attribute numbers+  starting at 1.++@since 1.0.0.0+-}+isOrdinaryColumn :: PgAttribute -> Bool+isOrdinaryColumn attr =+  pgAttributeNumber attr > AttributeNumber 0++{- |+  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)++{- |+  Converts an 'AttributeName' to a plain 'String'.++@since 1.0.0.0+-}+attributeNameToString :: AttributeName -> String+attributeNameToString (AttributeName txt) =+  T.unpack txt++{- |+  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)++{- |+  Converts an 'AttributeNumber' to an integer.+-}+attributeNumberToInt16 :: AttributeNumber -> Int16+attributeNumberToInt16 (AttributeNumber int) = int++{- |+  Converts an integer to an 'AttributeNumber'.+-}+attributeNumberFromInt16 :: Int16 -> AttributeNumber+attributeNumberFromInt16 = AttributeNumber++{- |+  Attoparsec parser for 'AttributeNumber'.++@since 1.0.0.0+-}+attributeNumberParser :: AttoText.Parser AttributeNumber+attributeNumberParser =+  AttoText.signed AttoText.decimal++{- |+  Encodes an 'AttributeNumber' to lazy text as a builder.++@since 1.0.0.0+-}+attributeNumberTextBuilder :: AttributeNumber -> LTB.Builder+attributeNumberTextBuilder =+  LTBI.decimal . attributeNumberToInt16++{- |+  An Orville 'Orville.TableDefinition' for querying the+  @pg_catalog.pg_attribute@ table.++@since 1.0.0.0+-}+pgAttributeTable :: Orville.TableDefinition Orville.NoKey PgAttribute PgAttribute+pgAttributeTable =+  Orville.setTableSchema "pg_catalog" $+    Orville.mkTableDefinitionWithoutKey+      "pg_attribute"+      pgAttributeMarshaller++pgAttributeMarshaller :: Orville.SqlMarshaller PgAttribute PgAttribute+pgAttributeMarshaller =+  PgAttribute+    <$> Orville.marshallField pgAttributeRelationOid attributeRelationOidField+    <*> Orville.marshallField pgAttributeName attributeNameField+    <*> Orville.marshallField pgAttributeNumber attributeNumberField+    <*> Orville.marshallField pgAttributeTypeOid attributeTypeOidField+    <*> Orville.marshallField pgAttributeLength attributeLengthField+    <*> Orville.marshallField pgAttributeTypeModifier attributeTypeModifierField+    <*> Orville.marshallField pgAttributeIsDropped attributeIsDroppedField+    <*> Orville.marshallField pgAttributeIsNotNull attributeIsNotNullField++{- |+  The @attrelid@ column of the @pg_catalog.pg_attribute@ table.++@since 1.0.0.0+-}+attributeRelationOidField :: Orville.FieldDefinition Orville.NotNull LibPQ.Oid+attributeRelationOidField =+  oidTypeField "attrelid"++{- |+  The @attname@ column of the @pg_catalog.pg_attribute@ table.++@since 1.0.0.0+-}+attributeNameField :: Orville.FieldDefinition Orville.NotNull AttributeName+attributeNameField =+  Orville.coerceField $+    Orville.unboundedTextField "attname"++{- |+  The @attnum@ column of the @pg_catalog.pg_attribute@ table.++@since 1.0.0.0+-}+attributeNumberField :: Orville.FieldDefinition Orville.NotNull AttributeNumber+attributeNumberField =+  attributeNumberTypeField "attnum"++{- |+  Builds a 'Orville.FieldDefinition' for a field with type 'AttributeNumber'.++@since 1.0.0.0+-}+attributeNumberTypeField :: String -> Orville.FieldDefinition Orville.NotNull AttributeNumber+attributeNumberTypeField =+  Orville.coerceField . Orville.smallIntegerField++{- |+  The @atttypid@ column of the @pg_catalog.pg_attribute@ table.++@since 1.0.0.0+-}+attributeTypeOidField :: Orville.FieldDefinition Orville.NotNull LibPQ.Oid+attributeTypeOidField =+  oidTypeField "atttypid"++{- |+  The @attlen@ column of the @pg_catalog.pg_attribute@ table.++@since 1.0.0.0+-}+attributeLengthField :: Orville.FieldDefinition Orville.NotNull Int16+attributeLengthField =+  Orville.smallIntegerField "attlen"++{- |+  The @atttypmod@ column of the @pg_catalog.pg_attribute@ table.++@since 1.0.0.0+-}+attributeTypeModifierField :: Orville.FieldDefinition Orville.NotNull Int32+attributeTypeModifierField =+  Orville.integerField "atttypmod"++{- |+  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.++@since 1.0.0.0+-}+attributeIsNotNullField :: Orville.FieldDefinition Orville.NotNull Bool+attributeIsNotNullField =+  Orville.booleanField "attnotnull"
+ src/Orville/PostgreSQL/PgCatalog/PgAttributeDefault.hs view
@@ -0,0 +1,96 @@+{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.PgCatalog.PgAttributeDefault+  ( PgAttributeDefault (..)+  , pgAttributeDefaultTable+  , attributeDefaultRelationOidField+  )+where++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)+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@+  table.++@since 1.0.0.0+-}+data PgAttributeDefault = PgAttributeDefault+  { pgAttributeDefaultOid :: LibPQ.Oid+  -- ^ The PostgreSQL @oid@ for the default value.+  , pgAttributeDefaultRelationOid :: LibPQ.Oid+  -- ^ The PostgreSQL @oid@ for the relation that this+  -- attribute belongs to. References @pg_class.oid@.+  , pgAttributeDefaultAttributeNumber :: AttributeNumber+  -- ^ The PostgreSQL attribute number for the column that this+  -- default belongs to. References @pg_attribute.attnum@.+  , pgAttributeDefaultExpression :: T.Text+  -- ^ The PostgreSQL default value expression, as decompiled from the+  -- @adbin@ column using the PostgreSQL @pg_get_expr@ function.+  }++{- |+  An Orville 'Orville.TableDefinition' for querying the+  @pg_catalog.pg_attrdef@ table.++@since 1.0.0.0+-}+pgAttributeDefaultTable :: Orville.TableDefinition Orville.NoKey PgAttributeDefault PgAttributeDefault+pgAttributeDefaultTable =+  Orville.setTableSchema "pg_catalog" $+    Orville.mkTableDefinitionWithoutKey+      "pg_attrdef"+      pgAttributeDefaultMarshaller++pgAttributeDefaultMarshaller :: Orville.SqlMarshaller PgAttributeDefault PgAttributeDefault+pgAttributeDefaultMarshaller =+  PgAttributeDefault+    <$> Orville.marshallField pgAttributeDefaultOid oidField+    <*> Orville.marshallField pgAttributeDefaultRelationOid attributeDefaultRelationOidField+    <*> Orville.marshallField pgAttributeDefaultAttributeNumber attributeDefaultAttributeNumberField+    <*> Orville.marshallSyntheticField attributeDefaultExpressionField++{- |+  The @adrelid@ column of the @pg_catalog.pg_attrdef@ table.++@since 1.0.0.0+-}+attributeDefaultRelationOidField :: Orville.FieldDefinition Orville.NotNull LibPQ.Oid+attributeDefaultRelationOidField =+  oidTypeField "adrelid"++{- |+  The @adnum@ column of the @pg_catalog.pg_attrdef@ table.++@since 1.0.0.0+-}+attributeDefaultAttributeNumberField :: Orville.FieldDefinition Orville.NotNull AttributeNumber+attributeDefaultAttributeNumberField =+  attributeNumberTypeField "adnum"++{- |+  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)@.++@since 1.0.0.0+-}+attributeDefaultExpressionField :: Orville.SyntheticField T.Text+attributeDefaultExpressionField =+  Orville.syntheticField+    (RawSql.unsafeSqlExpression "pg_get_expr(adbin,adrelid)")+    "expression"+    SqlValue.toText
+ src/Orville/PostgreSQL/PgCatalog/PgClass.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.PgCatalog.PgClass+  ( PgClass (..)+  , RelationName+  , relationNameToString+  , RelationKind (..)+  , pgClassTable+  , relationNameField+  , namespaceOidField+  , relationKindField+  )+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_class@+  table. Rows in this table correspond to tables, indexes, sequences, views,+  materialized views, composite types and TOAST tables.++@since 1.0.0.0+-}+data PgClass = PgClass+  { pgClassOid :: LibPQ.Oid+  -- ^ The PostgreSQL @oid@ for the relation.+  , pgClassNamespaceOid :: LibPQ.Oid+  -- ^ The PostgreSQL @oid@ of the namespace that the relation belongs to.+  -- References @pg_namespace.oid@.+  , pgClassRelationName :: RelationName+  -- ^ The name of the relation.+  , pgClassRelationKind :: RelationKind+  -- ^ The kind of relation (table, view, etc).+  }++{- |+  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)++{- |+  Convert a 'RelationName' to a plain 'String'.++@since 1.0.0.0+-}+relationNameToString :: RelationName -> String+relationNameToString (RelationName text) =+  T.unpack text++{- |+  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+-}+data RelationKind+  = OrdinaryTable+  | Index+  | Sequence+  | ToastTable+  | View+  | MaterializedView+  | CompositeType+  | ForeignTable+  | PartitionedTable+  | PartitionedIndex+  deriving (Show, Eq)++{- |+  An Orville 'Orville.TableDefinition' for querying the+  @pg_catalog.pg_class@ table.++@since 1.0.0.0+-}+pgClassTable :: Orville.TableDefinition (Orville.HasKey LibPQ.Oid) PgClass PgClass+pgClassTable =+  Orville.setTableSchema "pg_catalog" $+    Orville.mkTableDefinition+      "pg_class"+      (Orville.primaryKey oidField)+      pgClassMarshaller++pgClassMarshaller :: Orville.SqlMarshaller PgClass PgClass+pgClassMarshaller =+  PgClass+    <$> Orville.marshallField pgClassOid oidField+    <*> Orville.marshallField pgClassNamespaceOid namespaceOidField+    <*> Orville.marshallField pgClassRelationName relationNameField+    <*> Orville.marshallField pgClassRelationKind relationKindField++{- |+  The @relnamespace@ column of the @pg_catalog.pg_class@ table.++@since 1.0.0.0+-}+namespaceOidField :: Orville.FieldDefinition Orville.NotNull LibPQ.Oid+namespaceOidField =+  oidTypeField "relnamespace"++{- |+  The @relname@ column of the @pg_catalog.pg_class@ table.++@since 1.0.0.0+-}+relationNameField :: Orville.FieldDefinition Orville.NotNull RelationName+relationNameField =+  Orville.coerceField $+    Orville.unboundedTextField "relname"++{- |+  The @relkind@ column of the @pg_catalog.pg_class@ table.++@since 1.0.0.0+-}+relationKindField :: Orville.FieldDefinition Orville.NotNull RelationKind+relationKindField =+  Orville.convertField+    (Orville.tryConvertSqlType relationKindToPgText pgTextToRelationKind)+    (Orville.unboundedTextField "relkind")++{- |+  Converts a 'RelationKind' to the corresponding single character text+  representation used by PostgreSQL.++  See also 'pgTextToRelationKind'++@since 1.0.0.0+-}+relationKindToPgText :: RelationKind -> T.Text+relationKindToPgText kind =+  T.pack $+    case kind of+      OrdinaryTable -> "r"+      Index -> "i"+      Sequence -> "S"+      ToastTable -> "t"+      View -> "v"+      MaterializedView -> "m"+      CompositeType -> "c"+      ForeignTable -> "f"+      PartitionedTable -> "p"+      PartitionedIndex -> "I"++{- |+  Attempts to parse a PostgreSQL single character textual value as a+  'RelationKind'.++  See also 'relationKindToPgText'++@since 1.0.0.0+-}+pgTextToRelationKind :: T.Text -> Either String RelationKind+pgTextToRelationKind text =+  case T.unpack text of+    "r" -> Right OrdinaryTable+    "i" -> Right Index+    "S" -> Right Sequence+    "t" -> Right ToastTable+    "v" -> Right View+    "m" -> Right MaterializedView+    "c" -> Right CompositeType+    "f" -> Right ForeignTable+    "p" -> Right PartitionedTable+    "I" -> Right PartitionedIndex+    kind -> Left ("Unrecognized PostgreSQL relation kind: " <> kind)
+ src/Orville/PostgreSQL/PgCatalog/PgConstraint.hs view
@@ -0,0 +1,326 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.PgCatalog.PgConstraint+  ( PgConstraint (..)+  , ConstraintType (..)+  , ConstraintName+  , constraintNameToString+  , pgConstraintTable+  , constraintRelationOidField+  )+where++import qualified Data.Attoparsec.Text as AttoText+import qualified Data.List as List+import qualified Data.String as String+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.Builder as LTB+import qualified Database.PostgreSQL.LibPQ as LibPQ++import qualified Orville.PostgreSQL as Orville+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@+  table. Rows in this table correspond to check, primary key, unique, foreign+  key and exclusion constraints on tables.++@since 1.0.0.0+-}+data PgConstraint = PgConstraint+  { pgConstraintOid :: LibPQ.Oid+  -- ^ The PostgreSQL @oid@ for the constraint.+  , pgConstraintName :: ConstraintName+  -- ^ The constraint name (which may not be unique).+  , pgConstraintNamespaceOid :: LibPQ.Oid+  -- ^ The oid of the namespace that contains the constraint.+  , pgConstraintType :: ConstraintType+  -- ^ The type of constraint.+  , pgConstraintRelationOid :: LibPQ.Oid+  -- ^ The PostgreSQL @oid@ of the table that the constraint is on+  -- (or @0@ if not a table constraint).+  , pgConstraintIndexOid :: LibPQ.Oid+  -- ^ The PostgreSQL @oid@ ef the index supporting this constraint, if it's a+  -- unique, primary key, foreign key or exclusion constraint. Otherwise @0@.+  , pgConstraintKey :: Maybe [AttributeNumber]+  -- ^ For table constraints, the attribute numbers of the constrained columns.+  -- These correspond to the 'Orville.PostgreSQL.PGCatalog.pgAttributeNumber'+  -- field of 'Orville.PostgreSQL.PGCatalog.PgAttribute'.+  , pgConstraintForeignRelationOid :: LibPQ.Oid+  -- ^ For foreign key constraints, the PostgreSQL @oid@ of the table the+  -- foreign key references.+  , pgConstraintForeignKey :: Maybe [AttributeNumber]+  -- ^ For foreign key constraints, the attribute numbers of the referenced+  -- columns. These correspond to the+  -- 'Orville.PostgreSQL.PGCatalog.pgAttributeNumber' field of+  -- 'Orville.PostgreSQL.PGCatalog.PgAttribute'.+  , pgConstraintForeignKeyOnUpdateType :: Maybe Orville.ForeignKeyAction+  -- ^ For foreign key constraints, the on update action type.+  , pgConstraintForeignKeyOnDeleteType :: Maybe Orville.ForeignKeyAction+  -- ^ For foreign key constraints, the on delete action type.+  }++{- |+  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)++{- |+  Converts a 'ConstraintName' to a plain 'String'.++@since 1.0.0.0+-}+constraintNameToString :: ConstraintName -> String+constraintNameToString (ConstraintName txt) =+  T.unpack txt++{- |+  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+-}+data ConstraintType+  = CheckConstraint+  | ForeignKeyConstraint+  | PrimaryKeyConstraint+  | UniqueConstraint+  | ConstraintTrigger+  | ExclusionConstraint+  deriving (Show, Eq)++{- |+  Converts a 'ConstraintType' to the corresponding single character text+  representation used by PostgreSQL.++  See also 'pgTextToConstraintType'++@since 1.0.0.0+-}+constraintTypeToPgText :: ConstraintType -> T.Text+constraintTypeToPgText conType =+  T.pack $+    case conType of+      CheckConstraint -> "c"+      ForeignKeyConstraint -> "f"+      PrimaryKeyConstraint -> "p"+      UniqueConstraint -> "u"+      ConstraintTrigger -> "t"+      ExclusionConstraint -> "x"++{- |+  Attempts to parse a PostgreSQL single character textual value as a+  'ConstraintType'++  See also 'constraintTypeToPgText'++@since 1.0.0.0+-}+pgTextToConstraintType :: T.Text -> Either String ConstraintType+pgTextToConstraintType text =+  case T.unpack text of+    "c" -> Right CheckConstraint+    "f" -> Right ForeignKeyConstraint+    "p" -> Right PrimaryKeyConstraint+    "u" -> Right UniqueConstraint+    "t" -> Right ConstraintTrigger+    "x" -> Right ExclusionConstraint+    typ -> Left ("Unrecognized PostgreSQL constraint type: " <> typ)++{- |+  Converts a 'Maybe Orville.ForeignKeyAction' to the corresponding single character+  text representation used by PostgreSQL.++  See also 'pgTextToForeignKeyAction'++@since 1.0.0.0+-}+foreignKeyActionToPgText :: Maybe Orville.ForeignKeyAction -> T.Text+foreignKeyActionToPgText mbfkAction =+  T.pack $+    case mbfkAction of+      Just Orville.NoAction -> "a"+      Just Orville.Restrict -> "r"+      Just Orville.Cascade -> "c"+      Just Orville.SetNull -> "n"+      Just Orville.SetDefault -> "d"+      Nothing -> " "++{- |+  Attempts to parse a PostgreSQL single character textual value as a+  'Maybe Orville.ForeignKeyAction'++  See also 'foreignKeyActionToPgText'++@since 1.0.0.0+-}+pgTextToForeignKeyAction :: T.Text -> Either String (Maybe Orville.ForeignKeyAction)+pgTextToForeignKeyAction text =+  case T.unpack text of+    "a" -> Right $ Just Orville.NoAction+    "r" -> Right $ Just Orville.Restrict+    "c" -> Right $ Just Orville.Cascade+    "n" -> Right $ Just Orville.SetNull+    "d" -> Right $ Just Orville.SetDefault+    " " -> Right Nothing+    typ -> Left ("Unrecognized PostgreSQL foreign key action type: " <> typ)++{- |+  An Orville 'Orville.TableDefinition' for querying the+  @pg_catalog.pg_constraint@ table.++@since 1.0.0.0+-}+pgConstraintTable :: Orville.TableDefinition (Orville.HasKey LibPQ.Oid) PgConstraint PgConstraint+pgConstraintTable =+  Orville.setTableSchema "pg_catalog" $+    Orville.mkTableDefinition+      "pg_constraint"+      (Orville.primaryKey oidField)+      pgConstraintMarshaller++pgConstraintMarshaller :: Orville.SqlMarshaller PgConstraint PgConstraint+pgConstraintMarshaller =+  PgConstraint+    <$> Orville.marshallField pgConstraintOid oidField+    <*> Orville.marshallField pgConstraintName constraintNameField+    <*> Orville.marshallField pgConstraintNamespaceOid constraintNamespaceOidField+    <*> Orville.marshallField pgConstraintType constraintTypeField+    <*> Orville.marshallField pgConstraintRelationOid constraintRelationOidField+    <*> Orville.marshallField pgConstraintIndexOid constraintIndexOidField+    <*> Orville.marshallField pgConstraintKey constraintKeyField+    <*> Orville.marshallField pgConstraintForeignRelationOid constraintForeignRelationOidField+    <*> Orville.marshallField pgConstraintForeignKey constraintForeignKeyField+    <*> Orville.marshallField pgConstraintForeignKeyOnUpdateType constraintForeignKeyOnUpdateTypeField+    <*> Orville.marshallField pgConstraintForeignKeyOnDeleteType constraintForeignKeyOnDeleteTypeField++{- |+  The @conname@ column of the @pg_constraint@ table.++@since 1.0.0.0+-}+constraintNameField :: Orville.FieldDefinition Orville.NotNull ConstraintName+constraintNameField =+  Orville.coerceField $+    Orville.unboundedTextField "conname"++{- |+  The @connamespace@ column of the @pg_constraint@ table.++@since 1.0.0.0+-}+constraintNamespaceOidField :: Orville.FieldDefinition Orville.NotNull LibPQ.Oid+constraintNamespaceOidField =+  oidTypeField "connamespace"++{- |+  The @contype@ column of the @pg_constraint@ table.++@since 1.0.0.0+-}+constraintTypeField :: Orville.FieldDefinition Orville.NotNull ConstraintType+constraintTypeField =+  Orville.convertField+    (Orville.tryConvertSqlType constraintTypeToPgText pgTextToConstraintType)+    (Orville.unboundedTextField "contype")++{- |+  The @conrelid@ column of the @pg_constraint@ table.++@since 1.0.0.0+-}+constraintRelationOidField :: Orville.FieldDefinition Orville.NotNull LibPQ.Oid+constraintRelationOidField =+  oidTypeField "conrelid"++{- |+  The @conindid@ column of the @pg_constraint@ table.++@since 1.0.0.0+-}+constraintIndexOidField :: Orville.FieldDefinition Orville.NotNull LibPQ.Oid+constraintIndexOidField =+  oidTypeField "conindid"++{- |+  The @conkey@ column of the @pg_constraint@ table.++@since 1.0.0.0+-}+constraintKeyField :: Orville.FieldDefinition Orville.Nullable (Maybe [AttributeNumber])+constraintKeyField =+  Orville.nullableField $+    Orville.convertField+      (Orville.tryConvertSqlType attributeNumberListToPgArrayText pgArrayTextToAttributeNumberList)+      (Orville.unboundedTextField "conkey")++{- |+  The @confrelid@ column of the @pg_constraint@ table.++@since 1.0.0.0+-}+constraintForeignRelationOidField :: Orville.FieldDefinition Orville.NotNull LibPQ.Oid+constraintForeignRelationOidField =+  oidTypeField "confrelid"++{- |+  The @confkey@ column of the @pg_constraint@ table.++@since 1.0.0.0+-}+constraintForeignKeyField :: Orville.FieldDefinition Orville.Nullable (Maybe [AttributeNumber])+constraintForeignKeyField =+  Orville.nullableField $+    Orville.convertField+      (Orville.tryConvertSqlType attributeNumberListToPgArrayText pgArrayTextToAttributeNumberList)+      (Orville.unboundedTextField "confkey")++constraintForeignKeyOnUpdateTypeField :: Orville.FieldDefinition Orville.NotNull (Maybe Orville.ForeignKeyAction)+constraintForeignKeyOnUpdateTypeField =+  Orville.convertField+    (Orville.tryConvertSqlType foreignKeyActionToPgText pgTextToForeignKeyAction)+    (Orville.unboundedTextField "confupdtype")++constraintForeignKeyOnDeleteTypeField :: Orville.FieldDefinition Orville.NotNull (Maybe Orville.ForeignKeyAction)+constraintForeignKeyOnDeleteTypeField =+  Orville.convertField+    (Orville.tryConvertSqlType foreignKeyActionToPgText pgTextToForeignKeyAction)+    (Orville.unboundedTextField "confdeltype")++pgArrayTextToAttributeNumberList :: T.Text -> Either String [AttributeNumber]+pgArrayTextToAttributeNumberList text =+  let+    parser = do+      _ <- AttoText.char '{'+      attNums <- AttoText.sepBy attributeNumberParser (AttoText.char ',')+      _ <- AttoText.char '}'+      AttoText.endOfInput+      pure attNums+  in+    case AttoText.parseOnly parser text of+      Left err -> Left ("Unable to decode PostgreSQL Array as AttributeNumber list: " <> err)+      Right nums -> Right nums++attributeNumberListToPgArrayText :: [AttributeNumber] -> T.Text+attributeNumberListToPgArrayText attNums =+  let+    commaDelimitedAttributeNumbers =+      mconcat $+        List.intersperse (LTB.singleton ',') (map attributeNumberTextBuilder attNums)+  in+    LT.toStrict . LTB.toLazyText $+      LTB.singleton '{' <> commaDelimitedAttributeNumbers <> LTB.singleton '}'
+ src/Orville/PostgreSQL/PgCatalog/PgIndex.hs view
@@ -0,0 +1,156 @@+{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.PgCatalog.PgIndex+  ( PgIndex (..)+  , pgIndexTable+  , indexRelationOidField+  , indexIsLiveField+  )+where++import qualified Data.Attoparsec.Text as AttoText+import qualified Data.List as List+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.Builder as LTB+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, attributeNumberParser, attributeNumberTextBuilder)++{- |+  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.++@since 1.0.0.0+-}+data PgIndex = PgIndex+  { pgIndexPgClassOid :: LibPQ.Oid+  -- ^ The PostgreSQL @oid@ of the @pg_class@ entry for this index.+  , pgIndexRelationOid :: LibPQ.Oid+  -- ^ The PostgreSQL @oid@ of the @pg_class@ entry for the table that this+  -- index is for.+  , pgIndexAttributeNumbers :: [AttributeNumber]+  -- ^ An array of attribute number references for the columns of the table+  -- that are included in the index. An attribute number of @0@ indicates an+  -- expression over the table's columns rather than just a reference to a+  -- column.+  --+  -- In PostgreSQL 11+ this includes both key columns and non-key-included+  -- columns. Orville is currently not aware of this distinction, however.+  , pgIndexIsUnique :: Bool+  -- ^ Indicates whether this is a unique index.+  , pgIndexIsPrimary :: Bool+  -- ^ Indicates whether this is the primary key index for the table.+  , pgIndexIsLive :: Bool+  -- ^ When @False@, indicates that this index is in the process of being+  -- dropped and should be ignored.+  }++{- |+  An Orville 'Orville.TableDefinition' for querying the+  @pg_catalog.pg_index@ table.++@since 1.0.0.0+-}+pgIndexTable :: Orville.TableDefinition Orville.NoKey PgIndex PgIndex+pgIndexTable =+  Orville.setTableSchema "pg_catalog" $+    Orville.mkTableDefinitionWithoutKey+      "pg_index"+      pgIndexMarshaller++pgIndexMarshaller :: Orville.SqlMarshaller PgIndex PgIndex+pgIndexMarshaller =+  PgIndex+    <$> Orville.marshallField pgIndexPgClassOid indexPgClassOidField+    <*> Orville.marshallField pgIndexRelationOid indexRelationOidField+    <*> Orville.marshallField pgIndexAttributeNumbers indexAttributeNumbersField+    <*> Orville.marshallField pgIndexIsUnique indexIsUniqueField+    <*> Orville.marshallField pgIndexIsPrimary indexIsPrimaryField+    <*> Orville.marshallField pgIndexIsLive indexIsLiveField++{- |+  The @indexrelid@ column of the @pg_index@ table.++@since 1.0.0.0+-}+indexPgClassOidField :: Orville.FieldDefinition Orville.NotNull LibPQ.Oid+indexPgClassOidField =+  oidTypeField "indexrelid"++{- |+  The @indrelid@ column of the @pg_index@ table.++@since 1.0.0.0+-}+indexRelationOidField :: Orville.FieldDefinition Orville.NotNull LibPQ.Oid+indexRelationOidField =+  oidTypeField "indrelid"++{- |+  The @indkey@ column of the @pg_index@ table.++@since 1.0.0.0+-}+indexAttributeNumbersField :: Orville.FieldDefinition Orville.NotNull [AttributeNumber]+indexAttributeNumbersField =+  Orville.convertField+    (Orville.tryConvertSqlType attributeNumberListToPgVectorText pgVectorTextToAttributeNumberList)+    (Orville.unboundedTextField "indkey")++{- |+  The @indisunique@ column of the @pg_index@ table.++@since 1.0.0.0+-}+indexIsUniqueField :: Orville.FieldDefinition Orville.NotNull Bool+indexIsUniqueField =+  Orville.booleanField "indisunique"++{- |+  The @indisprimary@ column of the @pg_index@ table.++@since 1.0.0.0+-}+indexIsPrimaryField :: Orville.FieldDefinition Orville.NotNull Bool+indexIsPrimaryField =+  Orville.booleanField "indisprimary"++{- |+  The @indislive@ column of the @pg_index@ table.++@since 1.0.0.0+-}+indexIsLiveField :: Orville.FieldDefinition Orville.NotNull Bool+indexIsLiveField =+  Orville.booleanField "indislive"++pgVectorTextToAttributeNumberList :: T.Text -> Either String [AttributeNumber]+pgVectorTextToAttributeNumberList text =+  let+    parser = do+      attNums <- AttoText.sepBy attributeNumberParser (AttoText.char ' ')+      AttoText.endOfInput+      pure attNums+  in+    case AttoText.parseOnly parser text of+      Left err -> Left ("Unable to decode PostgreSQL Vector as AttributeNumber list: " <> err)+      Right nums -> Right nums++attributeNumberListToPgVectorText :: [AttributeNumber] -> T.Text+attributeNumberListToPgVectorText attNums =+  let+    spaceDelimitedAttributeNumbers =+      mconcat $+        List.intersperse (LTB.singleton ' ') (map attributeNumberTextBuilder attNums)+  in+    LT.toStrict . LTB.toLazyText $+      spaceDelimitedAttributeNumbers
+ src/Orville/PostgreSQL/PgCatalog/PgNamespace.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.PgCatalog.PgNamespace+  ( PgNamespace (..)+  , NamespaceName+  , namespaceNameToString+  , pgNamespaceTable+  , namespaceNameField+  )+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)++{- |+  The Haskell representation of data read from the @pg_catalog.pg_namespace@+  table. Namespaces in @pg_catalog@ correspond to "schema" concept in database+  organization.++@since 1.0.0.0+-}+data PgNamespace = PgNamespace+  { pgNamespaceOid :: LibPQ.Oid+  -- ^ The PostgreSQL @oid@ for the namespace. This is referenced from+  -- other tables, such as @pg_class@.+  , pgNamespaceName :: NamespaceName+  -- ^ The name of the 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)++{- |+  Convert a 'NamespaceName' to a plain 'String'.++@since 1.0.0.0+-}+namespaceNameToString :: NamespaceName -> String+namespaceNameToString (NamespaceName text) =+  T.unpack text++{- |+  An Orville 'Orville.TableDefinition' for querying the+  @pg_catalog.pg_namespace@ table.++@since 1.0.0.0+-}+pgNamespaceTable :: Orville.TableDefinition (Orville.HasKey LibPQ.Oid) PgNamespace PgNamespace+pgNamespaceTable =+  Orville.setTableSchema "pg_catalog" $+    Orville.mkTableDefinition+      "pg_namespace"+      (Orville.primaryKey oidField)+      pgNamespaceMarshaller++pgNamespaceMarshaller :: Orville.SqlMarshaller PgNamespace PgNamespace+pgNamespaceMarshaller =+  PgNamespace+    <$> Orville.marshallField pgNamespaceOid oidField+    <*> Orville.marshallField pgNamespaceName namespaceNameField++{- |+  The @nspname@ column of the @pg_catalog.pg_namespace@ table.++@since 1.0.0.0+-}+namespaceNameField :: Orville.FieldDefinition Orville.NotNull NamespaceName+namespaceNameField =+  Orville.coerceField $+    Orville.unboundedTextField "nspname"
+ src/Orville/PostgreSQL/PgCatalog/PgSequence.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.PgCatalog.PgSequence+  ( PgSequence (..)+  , pgSequenceTable+  , sequencePgClassOidField+  )+where++import Data.Int (Int64)+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_sequence@+  table. Rows in this table are sequences in PostgreSQL.++@since 1.0.0.0+-}+data PgSequence = PgSequence+  { pgSequenceClassOid :: LibPQ.Oid+  -- ^ The PostgreSQL @oid@ of the @pg_class@ for this sequence.+  , pgSequenceTypeOid :: LibPQ.Oid+  -- ^ The PostgreSQL @oid@ of the data type of the sequence. References+  -- @pg_type.oid@.+  , pgSequenceStart :: Int64+  -- ^ The start value of the sequence.+  , pgSequenceIncrement :: Int64+  -- ^ The increment value of the sequence.+  , pgSequenceMax :: Int64+  -- ^ The max value of the sequence.+  , pgSequenceMin :: Int64+  -- ^ The min value of the sequence.+  , pgSequenceCache :: Int64+  -- ^ The cache size of the sequence.+  , pgSequenceCycle :: Bool+  -- ^ Whether the sequence cycles.+  }++{- |+  An Orville 'Orville.TableDefinition' for querying the+  @pg_catalog.pg_sequence@ table.++@since 1.0.0.0+-}+pgSequenceTable :: Orville.TableDefinition (Orville.HasKey LibPQ.Oid) PgSequence PgSequence+pgSequenceTable =+  Orville.setTableSchema "pg_catalog" $+    Orville.mkTableDefinition+      "pg_sequence"+      (Orville.primaryKey oidField)+      pgSequenceMarshaller++pgSequenceMarshaller :: Orville.SqlMarshaller PgSequence PgSequence+pgSequenceMarshaller =+  PgSequence+    <$> Orville.marshallField pgSequenceClassOid sequencePgClassOidField+    <*> Orville.marshallField pgSequenceTypeOid sequenceTypeOidField+    <*> Orville.marshallField pgSequenceStart sequenceStartField+    <*> Orville.marshallField pgSequenceIncrement sequenceIncrementField+    <*> Orville.marshallField pgSequenceMax sequenceMaxField+    <*> Orville.marshallField pgSequenceMin sequenceMinField+    <*> Orville.marshallField pgSequenceCache sequenceCacheField+    <*> Orville.marshallField pgSequenceCycle sequenceCycleField++{- |+  The @seqrelid@ column of the @pg_cataglog.pg_sequence@ table.++@since 1.0.0.0+-}+sequencePgClassOidField :: Orville.FieldDefinition Orville.NotNull LibPQ.Oid+sequencePgClassOidField =+  oidTypeField "seqrelid"++{- |+  The @seqtypid@ column of the @pg_catalog.pg_sequence@ table.++@since 1.0.0.0+-}+sequenceTypeOidField :: Orville.FieldDefinition Orville.NotNull LibPQ.Oid+sequenceTypeOidField =+  oidTypeField "seqtypid"++{- |+  The @seqstart@ column of the @pg_catalog.pg_sequence@ table.++@since 1.0.0.0+-}+sequenceStartField :: Orville.FieldDefinition Orville.NotNull Int64+sequenceStartField =+  Orville.bigIntegerField "seqstart"++{- |+  The @seqincrement@ column of the @pg_catalog.pg_sequence@ table.++@since 1.0.0.0+-}+sequenceIncrementField :: Orville.FieldDefinition Orville.NotNull Int64+sequenceIncrementField =+  Orville.bigIntegerField "seqincrement"++{- |+  The @seqmax@ column of the @pg_catalog.pg_sequence@ table.++@since 1.0.0.0+-}+sequenceMaxField :: Orville.FieldDefinition Orville.NotNull Int64+sequenceMaxField =+  Orville.bigIntegerField "seqmax"++{- |+  The @seqmin@ column of the @pg_catalog.pg_sequence@ table.++@since 1.0.0.0+-}+sequenceMinField :: Orville.FieldDefinition Orville.NotNull Int64+sequenceMinField =+  Orville.bigIntegerField "seqmin"++{- |+  The @seqcache@ column of the @pg_catalog.pg_sequence@ table.++@since 1.0.0.0+-}+sequenceCacheField :: Orville.FieldDefinition Orville.NotNull Int64+sequenceCacheField =+  Orville.bigIntegerField "seqcache"++{- |+  The @seqcycle@ column of the @pg_catalog.pg_sequence@ table.++@since 1.0.0.0+-}+sequenceCycleField :: Orville.FieldDefinition Orville.NotNull Bool+sequenceCycleField =+  Orville.booleanField "seqcycle"
+ src/Orville/PostgreSQL/Plan.hs view
@@ -0,0 +1,796 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Plan+  ( Plan+  , Planned+  , Execute+  , Explain+  , askParam++    -- * Using a Plan after it is constructed+  , execute+  , explain++    -- * Making a Plan to find rows in the database+  , findMaybeOne+  , findMaybeOneWhere+  , findOne+  , findOneShowVia+  , findOneWhere+  , findOneWhereShowVia+  , findAll+  , findAllWhere++    -- * Creating a multi-step Plan from other Plan values+  , bind+  , use+  , using+  , chain+  , chainMaybe+  , apply+  , planMany+  , planList+  , focusParam+  , planEither+  , planMaybe++    -- * Bridges from other types into Plan+  , Op.AssertionFailed+  , assert+  , planSelect+  , planOperation+  )+where++import Control.Exception (throwIO)+import Control.Monad (join)+import qualified Control.Monad.IO.Class as MIO+import Data.Either (partitionEithers)+import qualified Data.List.NonEmpty as NEL++import Orville.PostgreSQL.Execution (Select)+import qualified Orville.PostgreSQL.Expr as Expr+import qualified Orville.PostgreSQL.Marshall as Marshall+import qualified Orville.PostgreSQL.Monad as Monad+import qualified Orville.PostgreSQL.Plan.Explanation as Exp+import Orville.PostgreSQL.Plan.Many (Many)+import qualified Orville.PostgreSQL.Plan.Many as Many+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.++  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 @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'.++@since 1.0.0.0+-}+data Plan scope param result where+  PlanOp :: Op.Operation param result -> Plan scope param result+  PlanMany ::+    (forall manyScope. Plan manyScope param result) ->+    Plan scope [param] (Many param result)+  PlanEither ::+    Plan scope leftParam leftResult ->+    Plan scope rightParam rightResult ->+    Plan scope (Either leftParam rightParam) (Either leftResult rightResult)+  Bind ::+    Plan scope param a ->+    (Planned scope param a -> Plan scope param result) ->+    Plan scope param result+  Use :: Planned scope param a -> Plan scope param a+  Pure :: a -> Plan scope param a+  Apply ::+    Plan scope param (a -> b) ->+    Plan scope param a ->+    Plan scope param b+  Chain ::+    Plan scope a b ->+    Plan scope b c ->+    Plan scope a c++instance Functor (Plan scope param) where+  fmap f = Apply (Pure f)++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.++@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.++@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.++  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+-}+data Planned scope param a where+  PlannedOne :: a -> Planned Execute param a+  PlannedMany :: Many k a -> Planned ExecuteMany k a+  PlannedExplain :: Planned Explain param a++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'.++@since 1.0.0.0+-}+mapPlanned :: (a -> b) -> Planned scope param a -> Planned scope param b+mapPlanned f planned =+  case planned of+    PlannedOne a ->+      PlannedOne (f a)+    PlannedMany manyAs ->+      PlannedMany (fmap f manyAs)+    PlannedExplain ->+      PlannedExplain++{- |+  '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.++@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.++@since 1.0.0.0+-}+planOperation ::+  Op.Operation param result ->+  Plan scope param result+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.++@since 1.0.0.0+-}+planSelect :: Select row -> Plan scope () [row]+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.++@since 1.0.0.0+-}+askParam :: Plan scope param param+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.++@since 1.0.0.0+-}+findMaybeOne ::+  Ord fieldValue =>+  Schema.TableDefinition key writeEntity readEntity ->+  Marshall.FieldDefinition nullability fieldValue ->+  Plan scope fieldValue (Maybe readEntity)+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.++@since 1.0.0.0+-}+findMaybeOneWhere ::+  Ord fieldValue =>+  Schema.TableDefinition key writeEntity readEntity ->+  Marshall.FieldDefinition nullability fieldValue ->+  Expr.BooleanExpr ->+  Plan scope fieldValue (Maybe readEntity)+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.++@since 1.0.0.0+-}+findOneShowVia ::+  Ord fieldValue =>+  (fieldValue -> String) ->+  Schema.TableDefinition key writeEntity readEntity ->+  Marshall.FieldDefinition nullability fieldValue ->+  Plan scope fieldValue readEntity+findOneShowVia showParam tableDef fieldDef =+  assert+    (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.++@since 1.0.0.0+-}+findOne ::+  (Show fieldValue, Ord fieldValue) =>+  Schema.TableDefinition key writeEntity readEntity ->+  Marshall.FieldDefinition nullability fieldValue ->+  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.++@since 1.0.0.0+-}+findOneWhereShowVia ::+  Ord fieldValue =>+  (fieldValue -> String) ->+  Schema.TableDefinition key writeEntity readEntity ->+  Marshall.FieldDefinition nullability fieldValue ->+  Expr.BooleanExpr ->+  Plan scope fieldValue readEntity+findOneWhereShowVia showParam tableDef fieldDef cond =+  assert+    (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.++@since 1.0.0.0+-}+findOneWhere ::+  (Show fieldValue, Ord fieldValue) =>+  Schema.TableDefinition key writeEntity readEntity ->+  Marshall.FieldDefinition nullability fieldValue ->+  Expr.BooleanExpr ->+  Plan scope fieldValue readEntity+findOneWhere = findOneWhereShowVia show++{- |+  'assertFound' is an internal helper that checks that row was found where+  one was expected.++@since 1.0.0.0+-}+assertFound ::+  (fieldValue -> String) ->+  Schema.TableDefinition key writeEntity readEntity ->+  Marshall.FieldDefinition nullability fieldValue ->+  fieldValue ->+  Maybe result ->+  Either String result+assertFound showParam tableDef fieldDef param maybeRecord =+  case maybeRecord of+    Just a ->+      Right a+    Nothing ->+      Left $+        unwords+          [ "Failed to find record in table "+          , Schema.tableIdToString $ Schema.tableIdentifier tableDef+          , " where "+          , Marshall.fieldNameToString $ Marshall.fieldName fieldDef+          , " = "+          , 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 ::+  Ord fieldValue =>+  Schema.TableDefinition key writeEntity readEntity ->+  Marshall.FieldDefinition nullability fieldValue ->+  Plan scope fieldValue [readEntity]+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.++@since 1.0.0.0+-}+findAllWhere ::+  Ord fieldValue =>+  Schema.TableDefinition key writeEntity readEntity ->+  Marshall.FieldDefinition nullability fieldValue ->+  Expr.BooleanExpr ->+  Plan scope fieldValue [readEntity]+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.++@since 1.0.0.0+-}+planMany ::+  (forall manyScope. Plan manyScope param result) ->+  Plan scope [param] (Many param result)+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.++  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+-}+planList ::+  (forall scope. Plan scope param result) ->+  Plan listScope [param] [result]+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.++@since 1.0.0.0+-}+focusParam ::+  (a -> b) ->+  Plan scope b result ->+  Plan scope a result+focusParam focuser plan =+  chain (focuser <$> askParam) plan++{- |+  '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+-}+planEither ::+  Plan scope leftParam leftResult ->+  Plan scope rightParam rightResult ->+  Plan scope (Either leftParam rightParam) (Either leftResult rightResult)+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.++@since 1.0.0.0+-}+planMaybe :: Plan scope a b -> Plan scope (Maybe a) (Maybe b)+planMaybe plan =+  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).++  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'.++@since 1.0.0.0+-}+bind ::+  Plan scope param a ->+  (Planned scope param a -> Plan scope param result) ->+  Plan scope param result+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.++@since 1.0.0.0+-}+use :: Planned scope param a -> Plan scope param a+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.++@since 1.0.0.0+-}+using ::+  Planned scope param a ->+  Plan scope a b ->+  Plan scope param b+using planned plan =+  chain (use planned) 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+-}+apply ::+  Plan scope param (a -> b) ->+  Plan scope param a ->+  Plan scope param b+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.++@since 1.0.0.0+-}+chain ::+  Plan scope a b ->+  Plan scope b c ->+  Plan scope a c+chain =+  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+-}+chainMaybe ::+  Plan scope a (Maybe b) ->+  Plan scope b (Maybe c) ->+  Plan scope a (Maybe c)+chainMaybe a b =+  let+    optionalInput ::+      Plan scope a (Maybe b) ->+      Plan scope (Maybe a) (Maybe b)+    optionalInput =+      fmap join . planMaybe+  in+    Chain a (optionalInput b)++{- |+  '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+-}+assert ::+  (param -> a -> Either String b) ->+  Plan scope param a ->+  Plan scope param b+assert assertion aPlan =+  let+    eitherPlan =+      assertion+        <$> askParam+        <*> aPlan+  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.++  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+-}+execute ::+  Monad.MonadOrville m =>+  Plan Execute param result ->+  param ->+  m result+execute plan param =+  executeOne plan param++{- |+  '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+-}+executeOne ::+  Monad.MonadOrville m =>+  Plan Execute param result ->+  param ->+  m result+executeOne plan param =+  case plan of+    PlanOp operation -> do+      opResult <- Op.executeOperationOne operation param++      case opResult of+        Left err ->+          MIO.liftIO (throwIO err)+        Right result ->+          pure result+    PlanMany manyPlan ->+      executeMany manyPlan param+    PlanEither leftPlan rightPlan ->+      case param of+        Left leftParam ->+          Left <$> executeOne leftPlan leftParam+        Right rightParam ->+          Right <$> executeOne rightPlan rightParam+    Bind intermPlan continue -> do+      interm <- executeOne intermPlan param+      executeOne+        (continue (PlannedOne interm))+        param+    Use planned ->+      pure . resolveOne $ planned+    Pure a ->+      pure a+    Apply planF planA ->+      executeOne planF param <*> executeOne planA param+    Chain planAB planBC -> do+      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'.++@since 1.0.0.0+-}+executeMany ::+  Monad.MonadOrville m =>+  Plan ExecuteMany param result ->+  [param] ->+  m (Many.Many param result)+executeMany plan params =+  case plan of+    PlanOp operation -> do+      case NEL.nonEmpty params of+        Nothing ->+          pure $ Many.fromKeys params (const $ Left Many.NotAKey)+        Just nonEmptyParams -> do+          opResult <- Op.executeOperationMany operation nonEmptyParams++          case opResult of+            Left err ->+              MIO.liftIO (throwIO err)+            Right results ->+              pure results+    PlanMany manyPlan -> do+      let+        flatParams = concat params++      allResults <- executeMany manyPlan flatParams++      let+        restrictResults subParams =+          Many.fromKeys subParams (\k -> Many.lookup k allResults)++      pure $ Many.fromKeys params (Right . restrictResults)+    PlanEither leftPlan rightPlan -> do+      let+        (leftParams, rightParams) = partitionEithers params++      leftResults <- executeMany leftPlan leftParams+      rightResults <- executeMany rightPlan rightParams++      let+        eitherResult eitherK =+          case eitherK of+            Left k ->+              Left <$> Many.lookup k leftResults+            Right k ->+              Right <$> Many.lookup k rightResults++      pure $ Many.fromKeys params eitherResult+    Bind intermPlan continue -> do+      interms <- executeMany intermPlan params+      executeMany+        (continue (PlannedMany interms))+        params+    Use planned ->+      pure . resolveMany $ planned+    Pure a ->+      pure $ Many.fromKeys params (const (Right a))+    Apply planF planA -> do+      manyFs <- executeMany planF params+      manyAs <- executeMany planA params++      pure (Many.apply manyFs manyAs)+    Chain planAB planBC -> do+      bs <- executeMany planAB params+      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.++@since 1.0.0.0+-}+data Explain+  = 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'.++@since 1.0.0.0+-}+explain :: Plan Explain param result -> [String]+explain plan =+  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.++@since 1.0.0.0+-}+explainPlan ::+  Explain ->+  Plan Explain param result ->+  Exp.Explanation+explainPlan mult plan =+  case plan of+    PlanOp operation -> do+      case mult of+        ExplainOne ->+          Op.explainOperationOne operation+        ExplainMany ->+          Op.explainOperationMany operation+    PlanMany manyPlan -> do+      explainPlan ExplainMany manyPlan+    PlanEither leftPlan rightPlan ->+      explainPlan mult leftPlan <> explainPlan mult rightPlan+    Bind intermPlan continue ->+      let+        nextPlan = continue PlannedExplain+      in+        explainPlan mult intermPlan <> explainPlan mult nextPlan+    Use _ ->+      Exp.noExplanation+    Pure _ ->+      Exp.noExplanation+    Apply planF planA -> do+      explainPlan mult planF <> explainPlan mult planA+    Chain planAB planBC -> do+      explainPlan mult planAB <> explainPlan mult planBC
+ src/Orville/PostgreSQL/Plan/Explanation.hs view
@@ -0,0 +1,66 @@+{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Plan.Explanation+  ( Explanation+  , noExplanation+  , explainStep+  , explanationSteps+  )+where++{- |+ 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+-}+newtype Explanation+  = Explanation ([String] -> [String])++instance Semigroup Explanation where+  (<>) = appendExplanation++instance Monoid Explanation where+  mempty = noExplanation++{- |+Appends two 'Explanation's with the steps from the first argument being shown+first.++@since 1.0.0.0+-}+appendExplanation :: Explanation -> Explanation -> Explanation+appendExplanation (Explanation front) (Explanation back) =+  Explanation (front . back)++{- |+Constructs an empty 'Explanation'.++@since 1.0.0.0+-}+noExplanation :: Explanation+noExplanation =+  Explanation id++{- |+Constructs an 'Explanation' with a single step.++@since 1.0.0.0+-}+explainStep :: String -> Explanation+explainStep str =+  Explanation (str :)++{- |+Retrieves the steps contained in the 'Explanation'.++@since 1.0.0.0+-}+explanationSteps :: Explanation -> [String]+explanationSteps (Explanation prependTo) =+  prependTo []
+ src/Orville/PostgreSQL/Plan/Many.hs view
@@ -0,0 +1,167 @@+{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Plan.Many+  ( Many+  , NotAKey (NotAKey)+  , fromKeys+  , lookup+  , keys+  , elems+  , map+  , toMap+  , apply+  , compose+  )+where++import Prelude (Either (Left, Right), Functor (fmap), Maybe (Just, Nothing), Ord, ($), (.), (<*>))++import qualified Data.Either as Either+import qualified Data.Map as Map+import qualified Data.Maybe as Maybe++{- |+  '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.++@since 1.0.0.0+-}+data NotAKey+  = NotAKey++{- |+  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+  don't care about the association with particular inputs, you can simply+  use 'elems' to get a list of all the results.++@since 1.0.0.0+-}+data Many k a+  = Many [k] (k -> Either NotAKey a)++instance Functor (Many k) where+  fmap = map++{- |+  '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+  runtime error. If it is not possible to map every @k@ (even those not in the+  input list provided to 'fromKeys'), the values should be wrapped in an+  appropriate type such as 'Maybe' so that an empty or default value can be+  returned.++@since 1.0.0.0+-}+fromKeys :: [k] -> (k -> Either NotAKey a) -> Many k a+fromKeys =+  Many++{- |+   'map' calls a function on all the values found in a 'Many' collection.++@since 1.0.0.0+-}+map :: (a -> b) -> Many k a -> Many k b+map f (Many ks keyToValue) =+  Many ks (fmap f . keyToValue)++{- |+   '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.++   (If you're looking for 'Prelude.pure' or an 'Prelude.Applicative' instance+   for 'Many', this is as good as it gets. 'Many' cannot be an+   'Prelude.Applicative' because there is no correct implementation of+   'Prelude.pure' that we can reasonably provide).++@since 1.0.0.0+-}+apply ::+  (Many param (a -> 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+  create a 'Many' mapping from the original keys to the final values.++@since 1.0.0.0+-}+compose :: Many b c -> Many a b -> Many a c+compose manyBC manyAB =+  fromKeys (keys manyAB) aToC+ where+  aToC a = do+    b <- lookup a manyAB+    lookup b manyBC++{- |+  '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.++@since 1.0.0.0+-}+keys :: Many k a -> [k]+keys (Many ks _) =+  ks++{- |+  '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.++@since 1.0.0.0+-}+elems :: Many k a -> [a]+elems (Many ks keyToValue) =+  Either.rights $ fmap keyToValue ks++{- |+  '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.++@since 1.0.0.0+-}+toMap :: Ord k => Many k a -> Map.Map k a+toMap (Many ks keyToValue) =+  Map.fromList (Maybe.mapMaybe mkPair ks)+ where+  mkPair k =+    case keyToValue k of+      Left NotAKey ->+        Nothing+      Right value ->+        Just (k, value)++{- |+  '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+  the type @a@ is.++@since 1.0.0.0+-}+lookup :: k -> Many k a -> Either NotAKey a+lookup k (Many _ keyToValue) =+  keyToValue k
+ src/Orville/PostgreSQL/Plan/Operation.hs view
@@ -0,0 +1,634 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Plan.Operation+  ( Operation (..)+  , AssertionFailed+  , mkAssertionFailed+  , WherePlanner (..)+  , byField+  , byFieldTuple+  , findOne+  , findOneWhere+  , findAll+  , findAllWhere+  , findSelect+  , askParam+  , assertRight+  , SelectOperation (..)+  , selectOperation+  )+where++import Control.Exception (Exception)+import qualified Data.ByteString.Char8 as BS8+import qualified Data.Foldable as Fold+import Data.List.NonEmpty (NonEmpty ((:|)))+import qualified Data.Map.Strict as Map+import qualified Data.Maybe as Maybe+import qualified Data.Sequence as Seq+import qualified Data.Set as Set+import qualified Data.Text as T++import qualified Orville.PostgreSQL.Execution as Exec+import qualified Orville.PostgreSQL.Expr as Expr+import qualified Orville.PostgreSQL.Marshall as Marshall+import qualified Orville.PostgreSQL.Monad as Monad+import qualified Orville.PostgreSQL.Plan.Explanation as Exp+import Orville.PostgreSQL.Plan.Many (Many)+import qualified Orville.PostgreSQL.Plan.Many as Many+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+  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+  operations to include in a 'Database.Orville.PostgreSQL.Plan.Plan' beyond+  those already provided in the 'Database.Orville.PostgreSQL.Plan.Plan'+  API.++  You can build your own custom 'Operation' values either directly, or using+  the function and types in this module, such as 'WherePlanner' (via 'findAll',+  etc), or 'SelectOperation' (via 'selectOperation').++@since 1.0.0.0+-}+data Operation param result = Operation+  { executeOperationOne ::+      forall m.+      Monad.MonadOrville m =>+      param ->+      m (Either AssertionFailed result)+  -- ^ 'executeOperationOne' will be called when a plan is+  -- executed with a single input parameter.+  , executeOperationMany ::+      forall m.+      Monad.MonadOrville m =>+      NonEmpty param ->+      m (Either AssertionFailed (Many param result))+  -- ^ 'executeOperationMany' will be called when a plan is executed with+  -- multiple input parameters (via 'Orville.PostgreSQL.Plan.planMany').+  , explainOperationOne :: Exp.Explanation+  -- ^ 'explainOperationOne' will be called when producing an explanation+  -- of what the plan will do when given one input parameter. Plans that do+  -- not perform any interesting IO interactions should generally return an+  -- empty explanation.+  , explainOperationMany :: Exp.Explanation+  -- ^ 'explainOperationMany' will be called when producing an explanation of+  -- what the plan will do when given multiple input parameters (via+  -- 'Orville.PostgreSQL.Plan.planMany'). Plans that do not perform any+  -- interesting IO interactions should generally return an empty explanation.+  }++{- |+  '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+  plan execution, the error is thrown as an exception using the+  'Control.Monad.Catch.MonadThrow' instance for whatever monad the plan is+  executing in.++@since 1.0.0.0+-}+newtype AssertionFailed+  = AssertionFailed String+  deriving (Show)++{- |+  'mkAssertionFailed' builds an 'AssertionFailed' error from an error message.++@since 1.0.0.0+-}+mkAssertionFailed :: String -> AssertionFailed+mkAssertionFailed =+  AssertionFailed++instance Exception AssertionFailed++{- |+  'askParam' simply returns the parameter given from the plan.++@since 1.0.0.0+-}+askParam :: Operation param param+askParam =+  Operation+    { executeOperationOne = pure . Right+    , executeOperationMany = \params -> pure . Right $ Many.fromKeys (Fold.toList params) Right+    , explainOperationOne = Exp.noExplanation+    , explainOperationMany = Exp.noExplanation+    }++{- |+  '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'.++@since 1.0.0.0+-}+assertRight :: Operation (Either String a) a+assertRight =+  Operation+    { executeOperationOne = \eitherA ->+        pure $+          case eitherA of+            Left err ->+              Left (AssertionFailed $ "Assertion failed: " <> err)+            Right b ->+              Right b+    , executeOperationMany = \eitherAs ->+        pure $+          case sequence eitherAs of+            Left err ->+              Left (AssertionFailed $ "Assertion failed: " <> err)+            Right _ ->+              let+                errorOnLeft :: forall a b. Either a b -> Either Many.NotAKey b+                errorOnLeft eitherA =+                  case eitherA of+                    Left _ ->+                      -- We proved all the values above didn't have any lefts in+                      -- then, so if we get a left here it must not be one of the+                      -- keys from the Many.+                      Left Many.NotAKey+                    Right a ->+                      Right a+              in+                Right $ Many.fromKeys (Fold.toList eitherAs) errorOnLeft+    , explainOperationOne = Exp.noExplanation+    , explainOperationMany = Exp.noExplanation+    }++{- |+  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.++  For simple queries, you can use the functions such as 'byField' that are+  provided here to build a 'WherePlanner', but you may also build your own+  custom 'WherePlanner' for more advanced use cases.++  If you need to execute a custom query that cannot be built by providing a+  custom where clause via 'WherePlanner', you may want to use more+  direct 'selectOperation' functions.++@since 1.0.0.0+-}+data WherePlanner param = WherePlanner+  { paramMarshaller :: forall entity. (entity -> param) -> Marshall.SqlMarshaller entity param+  -- ^ The 'paramMarshaller' function provided here will be used to decode+  -- the parameter field from the result set so that the row can be properly+  -- associated with the input parameter that matched it.+  , executeOneWhereCondition :: param -> Expr.BooleanExpr+  -- ^ 'executeOneWhereCondition' must build a where condition that will+  -- match only those rows that match the input paramater.+  , executeManyWhereCondition :: NonEmpty param -> Expr.BooleanExpr+  -- ^ 'executeManyWhereCondition' must build a where condition that will+  -- match only those rows that match any (not all!) of the input parameters.+  , explainOneWhereCondition :: Expr.BooleanExpr+  -- ^ 'explainOneWhereCondition' must build a where condition that is suitable+  -- to be used as an example of what 'executeManyWhereCondition' would return+  -- when given a parameter. This where condition will be used when producing+  -- explanations of plans. For example, this could fill in either an example+  -- or dummy value.+  , explainManyWhereCondition :: Expr.BooleanExpr+  -- ^ 'explainManyWhereCondition' must build a where condition that is+  -- suitable to be used as an example of what 'executeOneWhereCondition' would+  -- return when given a list of parameters. This where condition will be+  -- used when producing explanations of plans. For example, this could fill in+  -- either an example or dummy value.+  }++{- |+  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'.++@since 1.0.0.0+-}+byField ::+  Ord fieldValue =>+  Marshall.FieldDefinition nullability fieldValue ->+  WherePlanner fieldValue+byField fieldDef =+  let+    stringyField =+      stringifyField fieldDef+  in+    WherePlanner+      { paramMarshaller = flip Marshall.marshallField fieldDef+      , executeOneWhereCondition = \fieldValue -> Marshall.fieldEquals fieldDef fieldValue+      , executeManyWhereCondition = \fieldValues -> Marshall.fieldIn fieldDef (dedupeFieldValues fieldValues)+      , 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+  'FieldDefinition.FieldDefinition's.  The resulting 'WherePlanner' can be used+  with functions such as 'findOne' and 'findAll' to construct an 'Operation'.++@since 1.0.0.0+-}+byFieldTuple ::+  forall nullabilityA fieldValueA nullabilityB fieldValueB.+  (Ord fieldValueA, Ord fieldValueB) =>+  Marshall.FieldDefinition nullabilityA fieldValueA ->+  Marshall.FieldDefinition nullabilityB fieldValueB ->+  WherePlanner (fieldValueA, fieldValueB)+byFieldTuple fieldDefA fieldDefB =+  let+    stringyFieldA =+      stringifyField fieldDefA++    stringyFieldB =+      stringifyField fieldDefB++    marshaller ::+      (a -> (fieldValueA, fieldValueB)) ->+      Marshall.SqlMarshaller a (fieldValueA, fieldValueB)+    marshaller accessor =+      (,)+        <$> Marshall.marshallField (fst . accessor) fieldDefA+        <*> Marshall.marshallField (snd . accessor) fieldDefB++    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)+      , explainOneWhereCondition =+          Marshall.fieldTupleIn+            stringyFieldA+            stringyFieldB+            (packAll $ ("EXAMPLE VALUE A", "EXAMPLE VALUE B") :| [])+      , explainManyWhereCondition =+          Marshall.fieldTupleIn+            stringyFieldA+            stringyFieldB+            (packAll $ (("EXAMPLE VALUE A 1", "EXAMPLE VALUE B 1") :| [("EXAMPLE VALUE A 2", "EXAMPLE VALUE B 2")]))+      }++dedupeFieldValues :: Ord a => NonEmpty a -> NonEmpty a+dedupeFieldValues (first :| rest) =+  let+    dedupedWithoutFirst =+      Set.toList+        . Set.delete first+        . Set.fromList+        $ rest+  in+    first :| dedupedWithoutFirst++{- |+  '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+  most one of those rows to use as the result for each input.++@since 1.0.0.0+-}+findOne ::+  Ord param =>+  Schema.TableDefinition key writeEntity readEntity ->+  WherePlanner param ->+  Operation param (Maybe readEntity)+findOne tableDef wherePlanner =+  findOneWithOpts tableDef wherePlanner mempty++{- |+  '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.++@since 1.0.0.0+-}+findOneWhere ::+  Ord param =>+  Schema.TableDefinition key writeEntity readEntity ->+  WherePlanner param ->+  Expr.BooleanExpr ->+  Operation param (Maybe readEntity)+findOneWhere tableDef wherePlanner cond =+  findOneWithOpts tableDef wherePlanner (Exec.where_ cond)++{- |+  'findOneWithOpts' is a internal helper used by 'findOne' and 'findOneWhere'.++@since 1.0.0.0+-}+findOneWithOpts ::+  Ord param =>+  Schema.TableDefinition key writeEntity readEntity ->+  WherePlanner param ->+  Exec.SelectOptions ->+  Operation param (Maybe readEntity)+findOneWithOpts tableDef wherePlanner opts =+  selectOperation selectOp+ where+  selectOp =+    SelectOperation+      { selectOne = \param ->+          select (opts <> Exec.where_ (executeOneWhereCondition wherePlanner param) <> Exec.limit 1)+      , selectMany = \params ->+          select (opts <> Exec.where_ (executeManyWhereCondition wherePlanner params))+      , explainSelectOne =+          select (opts <> Exec.where_ (explainOneWhereCondition wherePlanner))+      , explainSelectMany =+          select (opts <> Exec.where_ (explainManyWhereCondition wherePlanner))+      , categorizeRow = fst+      , produceResult = fmap snd . Maybe.listToMaybe+      }++  select =+    Exec.selectMarshalledColumns+      marshaller+      (Schema.tableName tableDef)++  marshaller =+    Marshall.mapSqlMarshaller+      ( \m ->+          (,)+            <$> paramMarshaller wherePlanner fst+            <*> Marshall.marshallNested snd m+      )+      (Schema.tableMarshaller tableDef)++{- |+  '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+  fetched.++@since 1.0.0.0+-}+findAll ::+  Ord param =>+  Schema.TableDefinition key writeEntity readEntity ->+  WherePlanner param ->+  Operation param [readEntity]+findAll tableDef wherePlanner =+  findAllWithOpts tableDef wherePlanner mempty++{- |+  '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.++@since 1.0.0.0+-}+findAllWhere ::+  Ord param =>+  Schema.TableDefinition key writeEntity readEntity ->+  WherePlanner param ->+  Expr.BooleanExpr ->+  Operation param [readEntity]+findAllWhere tableDef wherePlanner cond =+  findAllWithOpts tableDef wherePlanner (Exec.where_ cond)++{- |+  'findAllWithOpts' is an internal helper used by 'findAll' and 'findAllWhere'.++@since 1.0.0.0+-}+findAllWithOpts ::+  Ord param =>+  Schema.TableDefinition key writeEntity readEntity ->+  WherePlanner param ->+  Exec.SelectOptions ->+  Operation param [readEntity]+findAllWithOpts tableDef wherePlanner opts =+  selectOperation selectOp+ where+  selectOp =+    SelectOperation+      { selectOne = \param ->+          select (opts <> Exec.where_ (executeOneWhereCondition wherePlanner param))+      , selectMany = \params ->+          select (opts <> Exec.where_ (executeManyWhereCondition wherePlanner params))+      , explainSelectOne =+          select (opts <> Exec.where_ (explainOneWhereCondition wherePlanner))+      , explainSelectMany =+          select (opts <> Exec.where_ (explainManyWhereCondition wherePlanner))+      , categorizeRow = fst+      , produceResult = map snd+      }++  select =+    Exec.selectMarshalledColumns+      marshaller+      (Schema.tableName tableDef)++  marshaller =+    Marshall.mapSqlMarshaller+      ( \m ->+          (,)+            <$> paramMarshaller wherePlanner fst+            <*> Marshall.marshallNested snd m+      )+      (Schema.tableMarshaller tableDef)++{- |+  '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+  text values as example inputs in the queries when for explaining plans.++@since 1.0.0.0+-}+stringifyField ::+  Marshall.FieldDefinition nullability a ->+  Marshall.FieldDefinition nullability T.Text+stringifyField =+  Marshall.convertField (const Marshall.unboundedText)++{- |+  '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+  by the 'Operation' type.++  Note: If you only need to build a custom where clause based on the+  'Operation' parameter, you may want to use a custom 'WherePlanner' with one+  of the existing 'findOne' or 'findAll' functions.++  If you cannot respresent your custom operation using 'SelectOperation' then+  you need to build the 'Operation' value directly yourself.++@since 1.0.0.0+-}+data SelectOperation param row result = SelectOperation+  { selectOne :: param -> Exec.Select row+  -- ^ 'selectOne' will be called to build the 'Exec.Select' query that should+  -- be run when there is a single input parameter while executing a plan.+  -- Note that the "One-ness" here refers to the single input parameter+  -- rather than the result. See 'produceResult' below for more information+  -- about returning one value vs. many from a 'SelectOperation'.+  , selectMany :: NonEmpty param -> Exec.Select row+  -- ^ 'selectMany' will be called to build the 'Exec.Select' query that should+  -- be run when there are multiple parameters while executing a plan.+  -- Note that the "Many-ness" here refers to the multiple input parameters+  -- rather than the result. See 'produceResult' below for more information+  -- about returning one value vs. many from a 'SelectOperation'.+  , explainSelectOne :: Exec.Select row+  -- ^ 'explainSelectOne' should show a representative query of what will+  -- be returned when 'selectOne' is used. No input parameter is available+  -- here to build the query, however, because this value is used to+  -- explain a plan without actually running it.+  , explainSelectMany :: Exec.Select row+  -- ^ 'explainSelectMany' should show a representative query of what will+  -- be returned when 'selectMany is used. No input parameters are available+  -- here to build the query, however, because this value is used to+  -- explain a plan without actually running it.+  , categorizeRow :: row -> param+  -- ^ 'categorizeRow' will be used when a plan is executed with multiple+  -- parameters to determine which input parameter the row should be+  -- associated with.+  , produceResult :: [row] -> result+  -- ^ 'produceResult' will be used to convert the @row@ type returned by the+  -- 'Exec.Select' queries for the operation input to the @result@ type that is+  -- present as the output of the operation. The input rows will be all the+  -- inputs associated with a single parameter. The @result@ type constructed+  -- here need not be a single value. For instance, 'findAll' uses the list+  -- type as the @result@ type and 'findOne' uses 'Maybe'.+  }++{- |+  '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.++@since 1.0.0.0+-}+selectOperation ::+  Ord param =>+  SelectOperation param row result ->+  Operation param result+selectOperation selectOp =+  Operation+    { executeOperationOne = executeSelectOne selectOp+    , executeOperationMany = executeSelectMany selectOp+    , explainOperationOne = explainSelect $ explainSelectOne selectOp+    , explainOperationMany = explainSelect $ explainSelectMany selectOp+    }++explainSelect :: Exec.Select row -> Exp.Explanation+explainSelect =+  Exp.explainStep . BS8.unpack . RawSql.toExampleBytes . Exec.selectToQueryExpr++{- |+  'executeSelectOne' is an internal helper function that executes a+  'SelectOperation' on a single input parameter.++@since 1.0.0.0+-}+executeSelectOne ::+  Monad.MonadOrville m =>+  SelectOperation param row result ->+  param ->+  m (Either AssertionFailed result)+executeSelectOne selectOp param =+  Right . produceResult selectOp+    <$> (Exec.executeSelect . selectOne selectOp $ param)++{- |+  'executeSelectMany' is an internal helper function that executes a+  'SelectOperation' on multiple input parameters.++@since 1.0.0.0+-}+executeSelectMany ::+  forall param row result m.+  (Ord param, Monad.MonadOrville m) =>+  SelectOperation param row result ->+  NonEmpty param ->+  m (Either AssertionFailed (Many param result))+executeSelectMany selectOp params = do+  rows <- Exec.executeSelect . selectMany selectOp $ params++  let+    paramList :: [param]+    paramList = Fold.toList params++    -- Seed add initial map with an empty seq for every input parameter+    -- to guarantee that each param is a key in the map even if no rows+    -- where returned from the select query for that param.+    emptyRowsMap :: Map.Map param (Seq.Seq a)+    emptyRowsMap =+      Map.fromList+        . map (\param -> (param, Seq.empty))+        $ paramList++    insertRow results row =+      Map.alter+        (\mbRows -> Just (Maybe.fromMaybe Seq.empty mbRows Seq.|> row))+        (categorizeRow selectOp row)+        results++    rowMap =+      produceResult selectOp . Fold.toList <$> Fold.foldl' insertRow emptyRowsMap rows++    manyRows =+      Many.fromKeys paramList $ \param ->+        case Map.lookup param rowMap of+          Nothing ->+            -- Because we seeded the map above with all the input parameters we+            -- can be sure that if we don't find a value in the map here it is+            -- because the function parameter is not one of the original inputs+            -- rather than just an input for which no rows were returned by the+            -- select query.+            Left Many.NotAKey+          Just row ->+            Right row++  pure . Right $ manyRows++{- |+  '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.++@since 1.0.0.0+-}+findSelect :: forall param row. Exec.Select row -> Operation param [row]+findSelect select =+  let+    executeOne :: Monad.MonadOrville m => param -> m (Either a [row])+    executeOne _ =+      Right <$> Exec.executeSelect select++    executeMany :: Monad.MonadOrville m => NonEmpty param -> m (Either a (Many param [row]))+    executeMany params = do+      rows <- Exec.executeSelect select+      pure . Right $ Many.fromKeys (Fold.toList params) (const (Right rows))++    selectToSqlString :: Exec.Select readEntity -> String+    selectToSqlString =+      BS8.unpack+        . RawSql.toExampleBytes+        . Exec.selectToQueryExpr+  in+    Operation+      { executeOperationOne = executeOne+      , executeOperationMany = executeMany+      , explainOperationOne = Exp.explainStep (selectToSqlString select)+      , explainOperationMany = Exp.explainStep (selectToSqlString select)+      }
+ src/Orville/PostgreSQL/Plan/Syntax.hs view
@@ -0,0 +1,66 @@+{- ORMOLU_DISABLE -}+{-+  Disable formatting this comment so that fourmolu doesn't complain about+  qualified do in the example code.+-}+{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT++This module exports the 'Plan.bind' function as '>>=' so that it can be used in+conjuction with the @QualifiedDo@ language extension to write plans using do+syntax like so:++@+{-# LANGUAGE QualifiedDo #-}+module MyModule where++import qualified Orville.PostgreSQL.Plan.Syntax as PlanSyntax++data FooFamily =+  FooFamily+    { foo :: Foo+    , children :: [FooChildren]+    , pets :: [FooPets]+    }++findFooFamily = PlanSyntax.do $+  fooHeader <- Plan.findOne fooTable fooIdField+  fooChildren <- Plan.findAll fooChildTable fooIdField+  fooPets <- Plan.findAll fooPetTable fooIdField++  FooFamily+    \<$\> Plan.use fooHeader+    \<*\> Plan.use fooChildren+    \<*\> Plan.use fooPets+@++@since 1.0.0.0+-}+{- ORMOLU_ENABLE -}+{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Plan.Syntax+  ( (>>=)+  )+where++import Prelude ()++import qualified Orville.PostgreSQL.Plan as Plan++{- |+  An operator alias of 'Plan.bind' so that it can be used with @QualifiedDo@.++@since 1.0.0.0+-}+(>>=) ::+  Plan.Plan scope param a ->+  (Plan.Planned scope param a -> Plan.Plan scope param result) ->+  Plan.Plan scope param result+(>>=) = Plan.bind
+ src/Orville/PostgreSQL/Raw/Connection.hs view
@@ -0,0 +1,549 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Raw.Connection+  ( ConnectionOptions+      ( ConnectionOptions+      , connectionString+      , connectionNoticeReporting+      , connectionPoolStripes+      , connectionPoolLingerTime+      , connectionPoolMaxConnections+      )+  , NoticeReporting (EnableNoticeReporting, DisableNoticeReporting)+  , MaxConnections (MaxConnectionsTotal, MaxConnectionsPerStripe)+  , StripeOption (OneStripePerCapability, StripeCount)+  , ConnectionPool+  , createConnectionPool+  , Connection+  , withPoolConnection+  , executeRaw+  , quoteStringLiteral+  , quoteIdentifier+  , ConnectionUsedAfterCloseError+  , ConnectionError+  , SqlExecutionError (..)+  )+where++import Control.Concurrent (getNumCapabilities, threadWaitRead, threadWaitWrite)+import Control.Concurrent.MVar (MVar, newMVar, tryReadMVar, tryTakeMVar)+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.Maybe (fromMaybe)+#if MIN_VERSION_resource_pool(0,4,0)+import Data.Pool (Pool, newPool, defaultPoolConfig, setNumStripes, withResource)+#else+import Data.Pool (Pool, createPool, withResource)+#endif+import qualified Data.Text as T+import qualified Data.Text.Encoding as Enc+import Data.Time (NominalDiffTime)+import qualified Database.PostgreSQL.LibPQ as LibPQ++import Orville.PostgreSQL.Raw.PgTextFormatValue (NULByteFoundError (NULByteFoundError), PgTextFormatValue, toBytesForLibPQ)++{- |+  An option for 'createConnectionPool' that indicates whether LibPQ should+  print notice reports for warnings to the console.++@since 1.0.0.0+-}+data NoticeReporting+  = EnableNoticeReporting+  | DisableNoticeReporting++{- |+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'.++@since 1.0.0.0+-}+newtype ConnectionPool+  = ConnectionPool (Pool Connection)++{- |+ 'createConnectionPool' allocates a pool of connections to a PostgreSQL server.++@since 1.0.0.0+-}+createConnectionPool :: ConnectionOptions -> IO ConnectionPool+createConnectionPool options = do+  let+    open =+      connect+        (connectionNoticeReporting options)+        (B8.pack $ connectionString options)++    linger =+      connectionPoolLingerTime options++    maxConns =+      connectionPoolMaxConnections options++  stripes <- determineStripeCount (connectionPoolStripes options)++  connPerStripe <-+    case determineConnectionsPerStripe stripes maxConns of+      Right conns -> pure conns+      Left err ->+        throwIO $+          ConnectionError+            { connectionErrorMessage = err+            , connectionErrorLibPQMessage = Nothing+            }++#if MIN_VERSION_resource_pool(0,4,0)+  fmap ConnectionPool . newPool . setNumStripes (Just stripes) $+    defaultPoolConfig+      open+      close+      (realToFrac linger)+      (stripes * connPerStripe)+#else+  ConnectionPool <$>+    createPool+      open+      close+      stripes+      linger+      connPerStripe+#endif++{- |+Values for the 'connectionPoolStripes' field of 'ConnectionOptions'.++@since 1.0.0.0+-}+data StripeOption+  = -- | 'OneStripePerCapability' will cause the connection pool to be set up+    -- with one stripe for each capability (processor thread) available to the+    -- runtime. This is the best option for multi-threaded connection pool+    -- performance.+    OneStripePerCapability+  | -- | 'StripeCount' will cause the connection pool to be set up with+    -- the specified number of stripes, regardless of how many capabilities+    -- the runtime has.+    StripeCount Int++{- |+Values for the 'connectionMaxConnections' field of 'ConnectionOptions'.++@since 1.0.0.0+-}+data MaxConnections+  = -- | 'MaxConnectionsTotal' creates a connection pool that will never+    -- allocate more than the specified number of connections. The total count+    -- of connections will be spread evenly across the all the stripes in the+    -- pool. If the number of stripes does not divide the total count evenly,+    -- any remainder will be unused.+    MaxConnectionsTotal Int+  | -- | 'MaxConnectionsPerStripe' creates a connection pool that will+    -- allocate up to the specified number of connections in each stripe.+    -- In this case the total possible number of simultaneous connections will+    -- be this value multiplied by the number of stripes.+    MaxConnectionsPerStripe Int++{- |+Configuration options to pass to 'createConnectionPool' to specify the+parameters for the pool and the connections that it creates.++@since 1.0.0.0+-}+data ConnectionOptions = ConnectionOptions+  { connectionString :: String+  -- ^ A PostgreSQL connection string.+  , connectionNoticeReporting :: NoticeReporting+  -- ^ Whether or not notice reporting from LibPQ should be enabled.+  , connectionPoolStripes :: StripeOption+  -- ^ Number of stripes in the connection pool.+  , connectionPoolLingerTime :: NominalDiffTime+  -- ^ Linger time before closing an idle connection.+  , connectionPoolMaxConnections :: MaxConnections+  -- ^ Controls the number of connections available in the 'ConnectionPool'.+  }++{- |+  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+  to use per stripe.+-}+determineConnectionsPerStripe :: Int -> MaxConnections -> Either String Int+determineConnectionsPerStripe stripes maxConnections =+  case maxConnections of+    MaxConnectionsPerStripe n ->+      Right n+    MaxConnectionsTotal n ->+      if n >= stripes+        then Right (n `div` stripes)+        else+          Left $+            "Invalid connection pool options. There must be at least "+              <> " 1 connection per stripe, but MaxConnectionsTotal was "+              <> show n+              <> " for "+              <> show stripes+              <> " stripes."++{- |+  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++{- |+  '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.+ Use with caution.++@since 1.0.0.0+-}+executeRaw ::+  Connection ->+  BS.ByteString ->+  [Maybe PgTextFormatValue] ->+  IO LibPQ.Result+executeRaw connection bs params =+  case traverse (traverse toBytesForLibPQ) params of+    Left NULByteFoundError ->+      throwIO NULByteFoundError+    Right paramBytes ->+      underlyingExecute bs paramBytes connection++{- |+  An Orville handler for a LibPQ connection.++@since 1.0.0.0+-}+newtype Connection = Connection (MVar LibPQ.Connection)++{- |+  'connect' is the internal, primitive connection function.++ This should not be exposed to end users, but instead wrapped in something to create a pool.++ Note that handling the LibPQ connection with the polling is described at+ <https://hackage.haskell.org/package/postgresql-libpq-0.9.4.2/docs/Database-PostgreSQL-LibPQ.html>.++@since 1.0.0.0+-}+connect :: NoticeReporting -> BS.ByteString -> IO Connection+connect noticeReporting connString =+  let+    checkSocketAndThreadWait conn threadWaitFn = do+      fd <- LibPQ.socket conn+      case fd of+        Nothing -> do+          throwConnectionError "connect: failed to get file descriptor for socket" conn+        Just fd' -> do+          threadWaitFn fd'+          poll conn++    poll conn = do+      pollStatus <- LibPQ.connectPoll conn+      case pollStatus of+        LibPQ.PollingFailed -> do+          throwConnectionError "connect: polling failed while connecting to database server" conn+        LibPQ.PollingReading ->+          checkSocketAndThreadWait conn threadWaitRead+        LibPQ.PollingWriting ->+          checkSocketAndThreadWait conn threadWaitWrite+        LibPQ.PollingOk -> do+          connectionHandle <- newMVar conn+          pure (Connection connectionHandle)+  in+    do+      connection <- LibPQ.connectStart connString+      case noticeReporting of+        DisableNoticeReporting -> LibPQ.disableNoticeReporting connection+        EnableNoticeReporting -> LibPQ.enableNoticeReporting connection+      poll connection++{- |+  'close' has many subtleties to it.++  First note that async exceptions are masked.  'mask' though, only works for+  things that are not interruptible+  <https://www.stackage.org/haddock/lts-16.15/base-4.13.0.0/Control-Exception.html#g:13>++  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.++@since 1.0.0.0+-}+close :: Connection -> IO ()+close (Connection handle) =+  let+    underlyingFinish :: (forall a. IO a -> IO a) -> IO (Maybe ())+    underlyingFinish restore = do+      underlyingConnection <- tryTakeMVar handle+      restore (traverse LibPQ.finish underlyingConnection)+  in+    void $ mask underlyingFinish++{- |+ '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).++@since 1.0.0.0+-}+underlyingExecute ::+  BS.ByteString ->+  [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++  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++{- |+  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+  literal with quotes, this function does for the sake of symmetry with+  'quoteIdentifier'.++  This function returns a `BSB.Builder` so that the result can be included in+  a builder being constructed for the surrounding SQL command without making+  an additional copy of the `BS.ByteString` returned by LibPQ for the sake of+  adding the surrounding quotes.++@since 1.0.0.0+-}+quoteStringLiteral :: Connection -> BS.ByteString -> IO BSB.Builder+quoteStringLiteral connection unquotedString = do+  libPQConn <- readLibPQConnectionOrFailIfClosed connection+  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)++{- |+  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.++  Although this function does not need to copy the `BS.ByteString` returned by+  LibPQ to add the quotes (since LibPQ already added them), it returns a+  `BSB.Builder` nonetheless to maintain symmetry with `quoteStringLiteral`.++@since 1.0.0.0+-}+quoteIdentifier :: Connection -> BS.ByteString -> IO BSB.Builder+quoteIdentifier connection unquotedString = do+  libPQConn <- readLibPQConnectionOrFailIfClosed connection+  mbEscapedString <- LibPQ.escapeIdentifier libPQConn unquotedString++  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++  case mbConn of+    Nothing ->+      throwIO ConnectionUsedAfterCloseError+    Just conn ->+      pure conn++throwConnectionError :: String -> LibPQ.Connection -> IO a+throwConnectionError message conn = do+  mbLibPQError <- LibPQ.errorMessage conn++  throwIO $+    ConnectionError+      { connectionErrorMessage = message+      , connectionErrorLibPQMessage = mbLibPQError+      }++throwExecutionErrorWithoutResult ::+  LibPQ.Connection ->+  BS.ByteString ->+  IO a+throwExecutionErrorWithoutResult conn queryBS = do+  mbLibPQError <- LibPQ.errorMessage conn++  throwIO $+    SqlExecutionError+      { sqlExecutionErrorExecStatus = Nothing+      , sqlExecutionErrorMessage = fromMaybe (B8.pack "No error message available from LibPQ") mbLibPQError+      , sqlExecutionErrorSqlState = Nothing+      , sqlExecutionErrorSqlQuery = queryBS+      }++throwExecutionErrorWithResult ::+  LibPQ.Result ->+  LibPQ.ExecStatus ->+  BS.ByteString ->+  IO a+throwExecutionErrorWithResult result execStatus queryBS = do+  mbLibPQError <- LibPQ.resultErrorMessage result+  mbSqlState <- LibPQ.resultErrorField result LibPQ.DiagSqlstate++  throwIO $+    SqlExecutionError+      { sqlExecutionErrorExecStatus = Just execStatus+      , sqlExecutionErrorMessage = fromMaybe (B8.pack "No error message available from LibPQ") mbLibPQError+      , sqlExecutionErrorSqlState = mbSqlState+      , sqlExecutionErrorSqlQuery = queryBS+      }++isRowReadableStatus :: LibPQ.ExecStatus -> Bool+isRowReadableStatus status =+  case status of+    LibPQ.CommandOk -> True -- ??+    LibPQ.TuplesOk -> True -- Returned on successful query, even if there are 0 rows.+    LibPQ.SingleTuple -> True -- Only returned when a query is executed is single row mode+    LibPQ.EmptyQuery -> False+    LibPQ.CopyOut -> False+    LibPQ.CopyIn -> False+    LibPQ.CopyBoth -> False -- CopyBoth is only used for streaming replication, so should not occur in ordinary applications+    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++{- |+  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.++@since 1.0.0.0+-}+mkInferredTextParam :: Maybe BS.ByteString -> Maybe (LibPQ.Oid, BS.ByteString, LibPQ.Format)+mkInferredTextParam mbValue =+  case mbValue of+    Nothing ->+      Nothing+    Just value ->+      Just (LibPQ.Oid 0, value, LibPQ.Text)++{- |+  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+  identifier.++@since 1.0.0.0+-}+data ConnectionError = ConnectionError+  { connectionErrorMessage :: String+  , connectionErrorLibPQMessage :: Maybe BS.ByteString+  }++instance Show ConnectionError where+  show err =+    let+      libPQErrorMsg =+        case connectionErrorLibPQMessage err of+          Nothing ->+            "<no underying error available>"+          Just libPQMsg ->+            case Enc.decodeUtf8' libPQMsg of+              Right decoded ->+                T.unpack decoded+              Left decodingErr ->+                "Error decoding libPQ messages as utf8: " <> show decodingErr+    in+      connectionErrorMessage err <> ": " <> libPQErrorMsg++instance Exception ConnectionError++{- |+  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+-}+data SqlExecutionError = SqlExecutionError+  { sqlExecutionErrorExecStatus :: Maybe LibPQ.ExecStatus+  -- ^ The underlying LibPQ execution status.+  , sqlExecutionErrorMessage :: BS.ByteString+  -- ^ Error message reported by PostgreSQL.+  , sqlExecutionErrorSqlState :: Maybe BS.ByteString+  -- ^ Any SQL state value reported by PostgreSQL. This can be used to+  -- determine what kind of error happened without needing to parse the error+  -- message. See+  -- https://www.postgresql.org/docs/current/errcodes-appendix.html.+  , sqlExecutionErrorSqlQuery :: BS.ByteString+  -- ^ The SQL query that was being run when the error occurred.+  }+  deriving (Show)++instance Exception SqlExecutionError++{- |+  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.++@since 1.0.0.0+-}+data ConnectionUsedAfterCloseError+  = ConnectionUsedAfterCloseError+  deriving (Show)++instance Exception ConnectionUsedAfterCloseError
+ src/Orville/PostgreSQL/Raw/PgTextFormatValue.hs view
@@ -0,0 +1,112 @@+{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Raw.PgTextFormatValue+  ( PgTextFormatValue+  , NULByteFoundError (NULByteFoundError)+  , unsafeFromByteString+  , fromByteString+  , toByteString+  , toBytesForLibPQ+  )+where++import Control.Exception (Exception)+import qualified Data.ByteString as BS++{- |+  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.++  Note that PostgreSQL does not allow NUL bytes in text values, and the LibPQ C+  library expects text values to be given as NULL-terminated C Strings, so+  '\NUL' bytes cannot be included in a 'PgTextFormatValue'. If 'fromByteString'+  is used to construct the 'PgTextFormatValue' (normally what you should do),+  an error will be raised before LibPQ is called to execute the query. If+  'unsafeFromByteString' is used, the caller is expected to ensure that no+  '\NUL' bytes are present. If a '\NUL' byte is included with+  'unsafeFromByteString', the value passed to the database will be truncated at+  the '\NUL' byte because it will be interpreted as the end of the C String by+  LibPQ.++@since 1.0.0.0+-}+data PgTextFormatValue+  = NoAssumptionsMade BS.ByteString+  | AssumedToHaveNoNULValues BS.ByteString+  deriving (Show)++instance Eq PgTextFormatValue where+  left == right =+    toBytesForLibPQ left == toBytesForLibPQ right++data NULByteFoundError+  = NULByteFoundError+  deriving (Show, Eq)++instance Exception NULByteFoundError++{- |+  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.++  This function is only safe to use when you have generated the bytestring+  in a way that guarantees no '\NUL' bytes are present, such as when serializing+  an integer value to its decimal representation.++@since 1.0.0.0+-}+unsafeFromByteString :: BS.ByteString -> PgTextFormatValue+unsafeFromByteString =+  AssumedToHaveNoNULValues++{- |+  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.++@since 1.0.0.0+-}+fromByteString :: BS.ByteString -> PgTextFormatValue+fromByteString =+  NoAssumptionsMade++{- |+  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).++@since 1.0.0.0+-}+toBytesForLibPQ :: PgTextFormatValue -> Either NULByteFoundError BS.ByteString+toBytesForLibPQ value =+  case value of+    AssumedToHaveNoNULValues noNULBytes ->+      Right noNULBytes+    NoAssumptionsMade anyBytes ->+      if BS.elem 0 anyBytes+        then Left NULByteFoundError+        else Right anyBytes++{- |+  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.++@since 1.0.0.0+-}+toByteString :: PgTextFormatValue -> BS.ByteString+toByteString value =+  case value of+    AssumedToHaveNoNULValues bytes ->+      bytes+    NoAssumptionsMade bytes ->+      bytes
+ src/Orville/PostgreSQL/Raw/PgTime.hs view
@@ -0,0 +1,159 @@+{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Raw.PgTime+  ( dayToPostgreSQL+  , day+  , utcTimeToPostgreSQL+  , utcTime+  , localTimeToPostgreSQL+  , localTime+  )+where++import qualified Data.Attoparsec.ByteString as AttoBS+import qualified Data.Attoparsec.ByteString.Char8 as AttoB8+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as B8+import qualified Data.Char as Char+import qualified Data.Fixed as Fixed+import qualified Data.Time as Time+import qualified Data.Word as Word++{- |+  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++{- |+  An Attoparsec parser for parsing 'Time.Day' from YYYY-MM-DD 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++fromChar :: Integral a => Char -> a+fromChar c = fromIntegral $ Char.ord c - Char.ord '0'++{- |+  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"++{- |+  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.++@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++{- |+  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"++{- |+  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\'@.++@since 1.0.0.0+-}+localTime :: AttoB8.Parser Time.LocalTime+localTime = do+  Time.LocalTime <$> day <* AttoB8.char ' ' <*> timeOfDay++{- |+  An Attoparsec parser for parsing 'Time.TimeOfDay' from an ISO-8601 style time.++@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++{- |+  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+-}+decimalWithCount :: Integral a => AttoB8.Parser (a, a)+decimalWithCount = do+  wrds <- AttoBS.takeWhile1 AttoB8.isDigit_w8+  pure (BS.foldl' appendDigit 0 wrds, fromIntegral $ BS.length wrds)++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.++@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))
+ src/Orville/PostgreSQL/Raw/RawSql.hs view
@@ -0,0 +1,531 @@+{- |++Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++The functions in this module are named with the intent that it is imported+qualified as 'RawSql'.++@since 1.0.0.0+-}+module Orville.PostgreSQL.Raw.RawSql+  ( RawSql+  , parameter+  , fromString+  , fromText+  , fromBytes+  , intercalate+  , execute+  , executeVoid+  , connectionQuoting++    -- * Fragments provided for convenience+  , space+  , comma+  , commaSpace+  , leftParen+  , rightParen+  , dot+  , doubleQuote+  , doubleColon+  , stringLiteral+  , identifier+  , parenthesized++    -- * Integer values as literals+  , intDecLiteral+  , int8DecLiteral+  , int16DecLiteral+  , int32DecLiteral+  , int64DecLiteral++    -- * Generic interface for generating SQL+  , SqlExpression (toRawSql, unsafeFromRawSql)+  , unsafeSqlExpression+  , toBytesAndParams+  , toExampleBytes+  , Quoting (Quoting, quoteStringLiteral, quoteIdentifier)+  , exampleQuoting+  )+where++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 qualified Data.ByteString.Lazy as LBS+import Data.DList (DList)+import qualified Data.DList as DList+import qualified Data.Foldable as Fold+import Data.Functor.Identity (Identity (Identity, runIdentity))+import qualified Data.Int as Int+import qualified Data.List as List+import qualified Data.Text as T+import qualified Data.Text.Encoding as TextEnc+import qualified Database.PostgreSQL.LibPQ as LibPQ++import qualified Orville.PostgreSQL.Raw.Connection as Conn+import Orville.PostgreSQL.Raw.PgTextFormatValue (PgTextFormatValue)+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+  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.++@since 1.0.0.0+-}+data RawSql+  = SqlSection BSB.Builder+  | Parameter SqlValue+  | StringLiteral BS.ByteString+  | Identifier BS.ByteString+  | Append RawSql RawSql++instance Semigroup RawSql where+  (SqlSection builderA) <> (SqlSection builderB) =+    SqlSection (builderA <> builderB)+  otherA <> otherB =+    Append otherA otherB++instance Monoid RawSql where+  mempty = SqlSection mempty++{- |+ '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+ construct them safely. These functions can be found in+ 'Orville.PostgreSQL.Expr'. These types all provide 'SqlExpression' instances+ as an escape hatch to allow you to pass any SQL you wish in place of what+ Orville directly supports. This should be used with great care as Orville+ cannot guarantee that the SQL you pass can be used to generate valid SQL in+ conjunction with the rest of the 'Orville.PostgreSQL.Expr' API.++@since 1.0.0.0+-}+class SqlExpression a where+  toRawSql :: a -> RawSql+  unsafeFromRawSql :: RawSql -> a++instance SqlExpression RawSql where+  toRawSql = id+  unsafeFromRawSql = id++{- |+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.++For example, if one wanted build a boolean expression not supported by Orville,+you can do it like so:++> import qualified Orville.PostgreSQL.Expr as Expr+>+> a :: Expr.BooleanExpr+> a RawSql.unsafeSqlExpression "foo BETWEEN 1 AND 3"+@since 1.0.0.0+-}+unsafeSqlExpression :: SqlExpression a => String -> a+unsafeSqlExpression =+  unsafeFromRawSql . fromString++{- |+  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.++  See 'connectionQuoting' and 'exampleQuoting'.++@since 1.0.0.0+-}+data Quoting m = Quoting+  { quoteStringLiteral :: BS.ByteString -> m BSB.Builder+  , quoteIdentifier :: BS.ByteString -> m BSB.Builder+  }++{- |+  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'.++@since 1.0.0.0+-}+exampleQuoting :: Quoting Identity+exampleQuoting =+  Quoting+    { quoteStringLiteral = Identity . exampleQuoteString '\''+    , quoteIdentifier = Identity . exampleQuoteString '"'+    }++exampleQuoteString :: Char -> BS.ByteString -> BSB.Builder+exampleQuoteString quoteChar =+  let+    quote (Right bs) =+      case B8.uncons bs of+        Nothing ->+          Nothing+        Just (char, rest) ->+          Just $+            if char == quoteChar+              then (char, Left (char, rest))+              else (char, Right rest)+    quote (Left (char, rest)) =+      Just (char, Right rest)++    quoteBytes =+      BSB.char8 quoteChar+  in+    \unquoted ->+      quoteBytes+        <> BSB.byteString (B8.unfoldr quote (Right unquoted))+        <> quoteBytes++{- |+  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+  SQL for explanatory or example purposes, see 'exampleQuoting'.++@since 1.0.0.0+-}+connectionQuoting :: Conn.Connection -> Quoting IO+connectionQuoting connection =+  Quoting+    { quoteStringLiteral = Conn.quoteStringLiteral connection+    , quoteIdentifier = Conn.quoteIdentifier connection+    }++{- |+  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.++@since 1.0.0.0+-}+toBytesAndParams ::+  (SqlExpression sql, Monad m) =>+  Quoting m ->+  sql ->+  m (BS.ByteString, [Maybe PgTextFormatValue])+toBytesAndParams quoting sql = do+  (byteBuilder, finalProgress) <-+    buildSqlWithProgress quoting startingProgress (toRawSql sql)+  pure+    ( LBS.toStrict (BSB.toLazyByteString byteBuilder)+    , DList.toList (paramValues finalProgress)+    )++{- |+  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.++@since 1.0.0.0+-}+toExampleBytes :: SqlExpression sql => sql -> BS.ByteString+toExampleBytes =+  fst . runIdentity . toBytesAndParams exampleQuoting++{- |+  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.++@since 1.0.0.0+-}+data ParamsProgress = ParamsProgress+  { paramCount :: Int+  , paramValues :: DList (Maybe PgTextFormatValue)+  }++{- |+  An initial value for 'ParamsProgress' that indicates no params have been been+  encountered yet.++@since 1.0.0.0+-}+startingProgress :: ParamsProgress+startingProgress =+  ParamsProgress+    { paramCount = 0+    , paramValues = DList.empty+    }++{- |+  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+-}+snocParam :: ParamsProgress -> Maybe PgTextFormatValue -> ParamsProgress+snocParam (ParamsProgress count values) newValue =+  ParamsProgress+    { paramCount = count + 1+    , paramValues = DList.snoc values newValue+    }++{- |+  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.++@since 1.0.0.0+-}+buildSqlWithProgress ::+  Monad m =>+  Quoting m ->+  ParamsProgress ->+  RawSql ->+  m (BSB.Builder, ParamsProgress)+buildSqlWithProgress quoting progress rawSql =+  case rawSql of+    SqlSection builder ->+      pure (builder, progress)+    StringLiteral unquotedString -> do+      quotedString <- quoteStringLiteral quoting unquotedString+      pure (quotedString, progress)+    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)+    Append first second -> do+      (firstBuilder, nextProgress) <- buildSqlWithProgress quoting progress first+      (secondBuilder, finalProgress) <- buildSqlWithProgress quoting nextProgress second+      pure (firstBuilder <> secondBuilder, finalProgress)++{- |+  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.++@since 1.0.0.0+-}+fromString :: String -> RawSql+fromString =+  SqlSection . BSB.stringUtf8++{- |+  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.+  Never use this function with input read from an untrusted source.++@since 1.0.0.0+-}+fromText :: T.Text -> RawSql+fromText =+  SqlSection . TextEnc.encodeUtf8Builder++{- |+  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+  the caller to protected againt SQL-injection attacks when using this+  function. Never use this function with input read from an untrusted source.++@since 1.0.0.0+-}+fromBytes :: BS.ByteString -> RawSql+fromBytes =+  SqlSection . BSB.byteString++{- |+  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+  representation, which the database will interpret. The database type for the+  value will be inferred by the database based on its usage in the query.++@since 1.0.0.0+-}+parameter :: SqlValue -> RawSql+parameter =+  Parameter++{- |+  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.++  Note: It's better to use the 'parameter' function where possible to pass+  values to be used as input to a SQL statement. There are some situations+  where PostgreSQL does not allow this, however (for instance, in some DDL+  statements). This function is provided for those situations.++@since 1.0.0.0+-}+stringLiteral :: BS.ByteString -> RawSql+stringLiteral =+  StringLiteral++{- |+  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.++@since 1.0.0.0+-}+identifier :: BS.ByteString -> RawSql+identifier =+  Identifier++{- |+  Concatenates a list of 'RawSql' values using another 'RawSql' value as the+  separator between the items.++@since 1.0.0.0+-}+intercalate :: (SqlExpression sql, Foldable f) => RawSql -> f sql -> RawSql+intercalate separator =+  mconcat+    . List.intersperse separator+    . map toRawSql+    . Fold.toList++{- |+  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.++  Note that because this is done in 'IO', no callback functions are available+  to be called.++@since 1.0.0.0+-}+execute :: SqlExpression sql => Conn.Connection -> sql -> IO LibPQ.Result+execute connection sql = do+  (sqlBytes, params) <- toBytesAndParams (connectionQuoting connection) sql+  Conn.executeRaw connection sqlBytes params++{- |+  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.++  Note that because this is done in 'IO', no callback functions are available+  to be called.++@since 1.0.0.0+-}+executeVoid :: SqlExpression sql => Conn.Connection -> sql -> IO ()+executeVoid connection sql = do+  void $ execute connection sql++-- | Just a plain old space, provided for convenience.+space :: RawSql+space = fromString " "++-- | Just a plain old comma, provided for convenience.+comma :: RawSql+comma = fromString ","++-- | Comma space separator, provided for convenience.+commaSpace :: RawSql+commaSpace = fromString ", "++-- | Just a plain old left paren, provided for convenience.+leftParen :: RawSql+leftParen = fromString "("++-- | Just a plain old right paren, provided for convenience.+rightParen :: RawSql+rightParen = fromString ")"++-- | Just a plain period, provided for convenience.+dot :: RawSql+dot = fromString "."++-- | Just a plain double quote, provided for convenience.+doubleQuote :: RawSql+doubleQuote = fromString "\""++-- | Just two colons, provided for convenience.+doubleColon :: RawSql+doubleColon = fromString "::"++{- |+  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.++@since 1.0.0.0+-}+int8DecLiteral :: Int.Int8 -> RawSql+int8DecLiteral =+  SqlSection . BSB.int8Dec++{- |+  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.++@since 1.0.0.0+-}+int16DecLiteral :: Int.Int16 -> RawSql+int16DecLiteral =+  SqlSection . BSB.int16Dec++{- |+  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.++@since 1.0.0.0+-}+int32DecLiteral :: Int.Int32 -> RawSql+int32DecLiteral =+  SqlSection . BSB.int32Dec++{- |+  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.++@since 1.0.0.0+-}+int64DecLiteral :: Int.Int64 -> RawSql+int64DecLiteral =+  SqlSection . BSB.int64Dec++{- |+  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.++@since 1.0.0.0+-}+intDecLiteral :: Int -> RawSql+intDecLiteral =+  SqlSection . BSB.intDec++{- |+  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.++@since 1.0.0.0+-}+parenthesized :: SqlExpression sql => sql -> RawSql+parenthesized expr =+  leftParen <> toRawSql expr <> rightParen
+ src/Orville/PostgreSQL/Raw/SqlCommenter.hs view
@@ -0,0 +1,97 @@+{- |++Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++This module provides the very basics for [sqlcommenter](https://google.github.io/sqlcommenter)+support.++@since 1.0.0.0+-}+module Orville.PostgreSQL.Raw.SqlCommenter+  ( SqlCommenterAttributes+  , addSqlCommenterAttributes+  )+where++import qualified Data.List as List+import qualified Data.Map.Strict as Map+import qualified Data.Text as T+import qualified Network.URI as URI++import qualified Orville.PostgreSQL.Raw.RawSql as RawSql++{- | The representation of 'T.Text' key/value pairs for supporting the sqlcommenter specification.+  This allows you to attach key/values of 'T.Text' that supporting systems can use for advanced+  metrics. See [sqlcommenter](https://google.github.io/sqlcommenter) for details of the+  specification.++@since 1.0.0.0+-}+type SqlCommenterAttributes = Map.Map T.Text T.Text++{- | Adds a given @SqlCommenter@ set of key/value 'T.Text' pairs to a 'RawSql.SqlExpression'. This+  performs all of the required serialization for the given values. Note that no values are+  automatically added here, so any that you may wish to add can be freely set without a name clash+  of any kind from this function itself.++@since 1.0.0.0+-}+addSqlCommenterAttributes :: RawSql.SqlExpression a => SqlCommenterAttributes -> a -> a+addSqlCommenterAttributes commenter a =+  RawSql.unsafeFromRawSql $+    RawSql.toRawSql a+      <> keyValueSerializationToRawSql commenter++keyValueSerializationToRawSql :: SqlCommenterAttributes -> RawSql.RawSql+keyValueSerializationToRawSql =+  RawSql.fromText . keyValueSerialization++{- | Perform the sqlcommenter serialization on for the whole @SqlCommenter@ map of key/value pairs.+     The spec can be found+     [here](https://google.github.io/sqlcommenter/spec/#key-value-serialization)++@since 1.0.0.0+-}+keyValueSerialization :: SqlCommenterAttributes -> T.Text+keyValueSerialization =+  wrapInSqlComment . addCommasAndConcat . List.sort . fmap concatWithEquals . Map.toList . valueSerialization . keySerialization++addCommasAndConcat :: [T.Text] -> T.Text+addCommasAndConcat [] = T.pack "''"+addCommasAndConcat txts = T.concat $ List.intersperse (T.pack ",") txts++concatWithEquals :: (T.Text, T.Text) -> T.Text+concatWithEquals (k, v) =+  k <> T.pack "=" <> v++-- | The spec can be found [here](https://google.github.io/sqlcommenter/spec/#key-serialization)+keySerialization :: SqlCommenterAttributes -> SqlCommenterAttributes+keySerialization =+  Map.mapKeys escapeText++-- | The spec can be found [here](https://google.github.io/sqlcommenter/spec/#value-serialization)+valueSerialization :: SqlCommenterAttributes -> SqlCommenterAttributes+valueSerialization =+  fmap (wrapInSingleQuote . escapeQuote . escapeText)++-- Here we ensure there is a space before the comment+wrapInSqlComment :: T.Text -> T.Text+wrapInSqlComment txt =+  T.pack " /*" <> txt <> T.pack "*/"++wrapInSingleQuote :: T.Text -> T.Text+wrapInSingleQuote txt =+  T.pack "'" <> txt <> T.pack "'"++escapeQuote :: T.Text -> T.Text+escapeQuote =+  T.replace (T.pack "'") (T.pack "\'")++escapeText :: T.Text -> T.Text+escapeText =+  T.pack . escapeStr . T.unpack++escapeStr :: String -> String+escapeStr = URI.escapeURIString URI.isUnescapedInURIComponent
+ src/Orville/PostgreSQL/Raw/SqlValue.hs view
@@ -0,0 +1,528 @@+{- |++Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++The functions in this module are named with the intent that it is imported+qualified as 'SqlValue'.++@since 1.0.0.0+-}+module Orville.PostgreSQL.Raw.SqlValue+  ( SqlValue+  , isSqlNull+  , sqlNull+  , fromInt8+  , toInt8+  , fromInt16+  , toInt16+  , fromInt32+  , toInt32+  , fromInt64+  , toInt64+  , fromInt+  , toInt+  , fromWord8+  , toWord8+  , fromWord16+  , toWord16+  , fromWord32+  , toWord32+  , fromWord64+  , toWord64+  , fromWord+  , toWord+  , fromDouble+  , toDouble+  , fromBool+  , toBool+  , fromText+  , toText+  , fromDay+  , toDay+  , fromUTCTime+  , toUTCTime+  , fromLocalTime+  , toLocalTime+  , fromRawBytes+  , fromRawBytesNullable+  , toPgValue+  )+where++import qualified Control.Exception as Exc+import qualified Data.Attoparsec.ByteString as AttoBS+import qualified Data.Attoparsec.ByteString.Char8 as AttoB8+import qualified Data.ByteString as BS+import qualified Data.ByteString.Builder as BSB+import qualified Data.ByteString.Lazy as LBS+import Data.Int (Int16, Int32, Int64, Int8)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TextEnc+import qualified Data.Time as Time+import qualified Data.Typeable as Typeable+import Data.Word (Word16, Word32, Word64, Word8)++import Orville.PostgreSQL.Raw.PgTextFormatValue (PgTextFormatValue)+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.+  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.++@since 1.0.0.0+-}+data SqlValue+  = SqlValue PgTextFormatValue+  | SqlNull+  deriving (Eq)++{- |+  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+    SqlNull -> True++{- |+  A value of 'SqlValue' that will be interpreted as a SQL NULL value when+  passed to the database.++@since 1.0.0.0+-}+sqlNull :: SqlValue+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+  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.++  Note: A value to represent a SQL NULL cannot be constructed using this+  function. See 'fromRawBytesNullable' for how to represent a nullable+  raw value.++@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+  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'.++@since 1.0.0.0+-}+fromRawBytesNullable :: Maybe BS.ByteString -> SqlValue+fromRawBytesNullable =+  maybe sqlNull fromRawBytes++{- |+  Encodes an 'Int8' value for use with the database.++@since 1.0.0.0+-}+fromInt8 :: Int8 -> SqlValue+fromInt8 =+  fromBSBuilderWithNoNULs BSB.int8Dec++{- |+  Attempts to decode a 'SqlValue' as a Haskell 'Int8' value. If decoding fails,+  'Nothing' is returned.++@since 1.0.0.0+-}+toInt8 :: SqlValue -> Either String Int8+toInt8 =+  toParsedValue (AttoB8.signed AttoB8.decimal)++{- |+  Encodes an 'Int16' value for use with the database.++@since 1.0.0.0+-}+fromInt16 :: Int16 -> SqlValue+fromInt16 =+  fromBSBuilderWithNoNULs BSB.int16Dec++{- |+  Attempts to decode a 'SqlValue' as a Haskell 'Int16' value. If decoding+  fails, 'Nothing' is returned.++@since 1.0.0.0+-}+toInt16 :: SqlValue -> Either String Int16+toInt16 =+  toParsedValue (AttoB8.signed AttoB8.decimal)++{- |+  Encodes an 'Int32' value for use with the database.++@since 1.0.0.0+-}+fromInt32 :: Int32 -> SqlValue+fromInt32 =+  fromBSBuilderWithNoNULs BSB.int32Dec++{- |+  Attempts to decode a 'SqlValue' as a Haskell 'Int32' value. If decoding+  fails, 'Nothing' is returned.++@since 1.0.0.0+-}+toInt32 :: SqlValue -> Either String Int32+toInt32 =+  toParsedValue (AttoB8.signed AttoB8.decimal)++{- |+  Encodes an 'Int64' value for use with the database.++@since 1.0.0.0+-}+fromInt64 :: Int64 -> SqlValue+fromInt64 =+  fromBSBuilderWithNoNULs BSB.int64Dec++{- |+  Attempts to decode a 'SqlValue' as a Haskell 'Int' value. If decoding fails,+  'Nothing' is returned.++@since 1.0.0.0+-}+toInt64 :: SqlValue -> Either String Int64+toInt64 =+  toParsedValue (AttoB8.signed AttoB8.decimal)++{- |+  Encodes an 'Int' value for use with the database.++@since 1.0.0.0+-}+fromInt :: Int -> SqlValue+fromInt =+  fromBSBuilderWithNoNULs BSB.intDec++{- |+  Attempts to decode a 'SqlValue' as a Haskell 'Int' value. If decoding fails,+  'Nothing' is returned.++@since 1.0.0.0+-}+toInt :: SqlValue -> Either String Int+toInt =+  toParsedValue (AttoB8.signed AttoB8.decimal)++{- |+  Encodes a 'Word8' value for use with the database.++@since 1.0.0.0+-}+fromWord8 :: Word8 -> SqlValue+fromWord8 =+  fromBSBuilderWithNoNULs BSB.word8Dec++{- |+  Attempts to decode a 'SqlValue' as a Haskell 'Word8' value. If decoding+  fails, 'Nothing' is returned.++@since 1.0.0.0+-}+toWord8 :: SqlValue -> Either String Word8+toWord8 =+  toParsedValue (AttoB8.signed AttoB8.decimal)++{- |+  Encodes a 'Word16' value for use with the database.++@since 1.0.0.0+-}+fromWord16 :: Word16 -> SqlValue+fromWord16 =+  fromBSBuilderWithNoNULs BSB.word16Dec++{- |+  Attempts to decode a 'SqlValue' as a Haskell 'Word16' value. If decoding+  fails, 'Nothing' is returned.++@since 1.0.0.0+-}+toWord16 :: SqlValue -> Either String Word16+toWord16 =+  toParsedValue (AttoB8.signed AttoB8.decimal)++{- |+  Encodes a 'Word32' value for use with the database.++@since 1.0.0.0+-}+fromWord32 :: Word32 -> SqlValue+fromWord32 =+  fromBSBuilderWithNoNULs BSB.word32Dec++{- |+  Attempts to decode a 'SqlValue' as a Haskell 'Word32' value. If decoding+  fails, 'Nothing' is returned.++@since 1.0.0.0+-}+toWord32 :: SqlValue -> Either String Word32+toWord32 =+  toParsedValue (AttoB8.signed AttoB8.decimal)++{- |+  Encodes a 'Word64' value for use with the database.++@since 1.0.0.0+-}+fromWord64 :: Word64 -> SqlValue+fromWord64 =+  fromBSBuilderWithNoNULs BSB.word64Dec++{- |+  Attempts to decode a 'SqlValue' as a Haskell 'Word64' value. If decoding+  fails, 'Nothing' is returned.++@since 1.0.0.0+-}+toWord64 :: SqlValue -> Either String Word64+toWord64 =+  toParsedValue (AttoB8.signed AttoB8.decimal)++{- |+  Encodes a 'Word' value for use with the database.++@since 1.0.0.0+-}+fromWord :: Word -> SqlValue+fromWord =+  fromBSBuilderWithNoNULs BSB.wordDec++{- |+  Attempts to decode a 'SqlValue' as a Haskell 'Word' value. If decoding fails,+  'Nothing' is returned.++@since 1.0.0.0+-}+toWord :: SqlValue -> Either String Word+toWord =+  toParsedValue (AttoB8.signed AttoB8.decimal)++{- |+  Encodes a 'Double' value for use with the database.++@since 1.0.0.0+-}+fromDouble :: Double -> SqlValue+fromDouble =+  fromBSBuilderWithNoNULs BSB.doubleDec++{- |+  Attempts to decode a 'SqlValue' as a Haskell 'Double' value. If decoding+  fails, 'Nothing' is returned.++@since 1.0.0.0+-}+toDouble :: SqlValue -> Either String Double+toDouble =+  toParsedValue (AttoB8.signed AttoB8.double)++{- |+  Encodes a 'Bool' value for use with the database.++@since 1.0.0.0+-}+fromBool :: Bool -> SqlValue+fromBool =+  fromBSBuilderWithNoNULs $ \bool ->+    case bool of+      True -> BSB.char8 't'+      False -> BSB.char8 'f'++{- |+  Attempts to decode a 'SqlValue' as a Haskell 'Bool' value. If decoding fails,+  'Nothing' is returned.++@since 1.0.0.0+-}+toBool :: SqlValue -> Either String Bool+toBool =+  toParsedValue $ do+    char <- AttoB8.anyChar+    case char of+      't' -> pure True+      '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.++@since 1.0.0.0+-}+fromText :: T.Text -> SqlValue+fromText =+  SqlValue . PgTextFormatValue.fromByteString . TextEnc.encodeUtf8++{- |+  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+  are not a valid UTF-8 sequence of bytes. Otherwise it always succeeds.++@since 1.0.0.0+-}+toText :: SqlValue -> Either String T.Text+toText =+  toBytesValue $ \bytes ->+    case TextEnc.decodeUtf8' bytes of+      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+  used with the database.++@since 1.0.0.0+-}+fromDay :: Time.Day -> SqlValue+fromDay =+  SqlValue . PgTextFormatValue.unsafeFromByteString . PgTime.dayToPostgreSQL++{- |+  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+-}+toDay :: SqlValue -> Either String Time.Day+toDay =+  toParsedValue PgTime.day++{- |+  Encodes a 'Time.UTCTime' in ISO-8601 format for use with the database.++@since 1.0.0.0+-}+fromUTCTime :: Time.UTCTime -> SqlValue+fromUTCTime =+  SqlValue+    . PgTextFormatValue.unsafeFromByteString+    . PgTime.utcTimeToPostgreSQL++{- |+  Encodes a 'Time.LocalTime' in ISO-8601 format for use with the database.++@since 1.0.0.0+-}+fromLocalTime :: Time.LocalTime -> SqlValue+fromLocalTime =+  SqlValue+    . PgTextFormatValue.unsafeFromByteString+    . PgTime.localTimeToPostgreSQL++{- |+  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+-}+toLocalTime :: SqlValue -> Either String Time.LocalTime+toLocalTime =+  toParsedValue PgTime.localTime++{- |+  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+-}+toUTCTime :: SqlValue -> Either String Time.UTCTime+toUTCTime =+  toParsedValue PgTime.utcTime++{- |+  An internal helper function that constructs a 'SqlValue' via a bytestring+  'BS8.Builder'.++@since 1.0.0.0+-}+fromBSBuilderWithNoNULs :: (a -> BSB.Builder) -> a -> SqlValue+fromBSBuilderWithNoNULs builder =+  SqlValue+    . PgTextFormatValue.unsafeFromByteString+    . LBS.toStrict+    . BSB.toLazyByteString+    . builder++{- |+  An internal helper function that parses 'SqlValue' via an Attoparsec parser.++@since 1.0.0.0+-}+toParsedValue ::+  Typeable.Typeable a =>+  AttoB8.Parser a ->+  SqlValue ->+  Either String a+toParsedValue parser =+  toBytesValue (AttoBS.parseOnly parser)++{- |+  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.++@since 1.0.0.0+-}+toBytesValue ::+  Typeable.Typeable a =>+  (BS.ByteString -> Either String a) ->+  SqlValue ->+  Either String a+toBytesValue byteParser sqlValue =+  let+    result =+      case sqlValue of+        SqlNull ->+          Left "Unexpected SQL NULL value"+        SqlValue bytes ->+          byteParser (PgTextFormatValue.toByteString bytes)++    typeRepOfA =+      -- result is the 'proxy a' for typeRep+      Typeable.typeRep result+  in+    case result of+      Right _ ->+        result+      Left err ->+        Left $ "Failed to decode PostgreSQL value as " <> Typeable.showsTypeRep typeRepOfA (": " <> err)
+ src/Orville/PostgreSQL/Schema.hs view
@@ -0,0 +1,38 @@+{-# OPTIONS_GHC -Wno-missing-import-lists #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++You can import "Orville.PostgreSQL.Schema" to get access to all the functions+related to representing a SQL schema. This includes a number of lower-level+items not exported by "Orville.PostgreSQL" that give you more control (and+therefore responsibility) over the definition of the schema.++@since 1.0.0.0+-}+module Orville.PostgreSQL.Schema+  ( -- * Defining Tables+      module Orville.PostgreSQL.Schema.TableDefinition+  , module Orville.PostgreSQL.Schema.TableIdentifier+  , module Orville.PostgreSQL.Schema.PrimaryKey+  , module Orville.PostgreSQL.Schema.IndexDefinition+  , module Orville.PostgreSQL.Schema.ConstraintDefinition++    -- * Defining Sequences+  , module Orville.PostgreSQL.Schema.SequenceDefinition+  , module Orville.PostgreSQL.Schema.SequenceIdentifier+  )+where++-- Note: we list the re-exports explicity above to control the order that they+-- appear in the generated haddock documentation.++import Orville.PostgreSQL.Schema.ConstraintDefinition+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
+ src/Orville/PostgreSQL/Schema/ConstraintDefinition.hs view
@@ -0,0 +1,323 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Schema.ConstraintDefinition+  ( ConstraintDefinition+  , uniqueConstraint+  , foreignKeyConstraint+  , foreignKeyConstraintWithOptions+  , ForeignReference (ForeignReference, localFieldName, foreignFieldName)+  , foreignReference+  , ConstraintMigrationKey (ConstraintMigrationKey, constraintKeyType, constraintKeyColumns, constraintKeyForeignTable, constraintKeyForeignColumns, constraintKeyForeignKeyOnUpdateAction, constraintKeyForeignKeyOnDeleteAction)+  , ConstraintKeyType (UniqueConstraint, ForeignKeyConstraint)+  , constraintMigrationKey+  , constraintSqlExpr+  , ForeignKeyAction (..)+  , ForeignKeyOptions (foreignKeyOptionsOnDelete, foreignKeyOptionsOnUpdate)+  , defaultForeignKeyOptions+  , TableConstraints+  , emptyTableConstraints+  , addConstraint+  , tableConstraintDefinitions+  , tableConstraintKeys+  )+where++import Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NEL+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set++import qualified Orville.PostgreSQL.Expr as Expr+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+  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.++@since 1.0.0.0+-}+newtype TableConstraints+  = TableConstraints (Map.Map ConstraintMigrationKey ConstraintDefinition)+  deriving (Semigroup, Monoid)++{- |+  Constructs an empty 'TableConstraints'.++@since 1.0.0.0+-}+emptyTableConstraints :: TableConstraints+emptyTableConstraints = TableConstraints Map.empty++{- |+  Adds a 'ConstraintDefinition' to an existing 'TableConstraints'. If a+  constraint already exists with the same 'ConstraintMigrationKey', it is+  replaced with the new constraint.++@since 1.0.0.0+-}+addConstraint :: ConstraintDefinition -> TableConstraints -> TableConstraints+addConstraint constraint (TableConstraints constraintMap) =+  TableConstraints $+    Map.insert+      (constraintMigrationKey constraint)+      constraint+      constraintMap++{- |+  Gets the list of 'ConstraintDefinition's that have been added to the+  'TableConstraints'.++@since 1.0.0.0+-}+tableConstraintKeys :: TableConstraints -> Set.Set ConstraintMigrationKey+tableConstraintKeys (TableConstraints constraints) =+  Map.keysSet constraints++{- |+  Gets the list of 'ConstraintDefinition's that have been added to the+  'TableConstraints'.++@since 1.0.0.0+-}+tableConstraintDefinitions :: TableConstraints -> [ConstraintDefinition]+tableConstraintDefinitions (TableConstraints constraints) =+  Map.elems constraints++{- |+  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+  them to your table definition. Orville will then add the constraint next time+  you run auto-migrations.++@since 1.0.0.0+-}+data ConstraintDefinition = ConstraintDefinition+  { _constraintSqlExpr :: Expr.TableConstraint+  , _constraintMigrationKey :: ConstraintMigrationKey+  }++{- |+  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.++@since 1.0.0.0+-}+data ConstraintMigrationKey = ConstraintMigrationKey+  { constraintKeyType :: ConstraintKeyType+  , constraintKeyColumns :: Maybe [FieldName.FieldName]+  , constraintKeyForeignTable :: Maybe TableIdentifier.TableIdentifier+  , constraintKeyForeignColumns :: Maybe [FieldName.FieldName]+  , constraintKeyForeignKeyOnUpdateAction :: Maybe ForeignKeyAction+  , constraintKeyForeignKeyOnDeleteAction :: Maybe ForeignKeyAction+  }+  deriving (Eq, Ord, Show)++{- |+  The kind of constraint that is described by a 'ConstraintMigrationKey' (e.g.+  unique, foreign key).++@since 1.0.0.0+-}+data ConstraintKeyType+  = UniqueConstraint+  | ForeignKeyConstraint+  deriving (Eq, Ord, Show)++{- |+  Gets the 'ConstraintMigrationKey' for the 'ConstraintDefinition'.++@since 1.0.0.0+-}+constraintMigrationKey :: ConstraintDefinition -> ConstraintMigrationKey+constraintMigrationKey = _constraintMigrationKey++{- |+  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++{- |+  Constructs a 'ConstraintDefinition' for a @UNIQUE@ constraint on the given+  columns.++@since 1.0.0.0+-}+uniqueConstraint :: NonEmpty FieldName.FieldName -> ConstraintDefinition+uniqueConstraint fieldNames =+  let+    expr =+      Expr.uniqueConstraint . fmap FieldName.fieldNameToColumnName $ fieldNames++    migrationKey =+      ConstraintMigrationKey+        { constraintKeyType = UniqueConstraint+        , constraintKeyColumns = Just (NEL.toList fieldNames)+        , constraintKeyForeignTable = Nothing+        , constraintKeyForeignColumns = Nothing+        , constraintKeyForeignKeyOnUpdateAction = Nothing+        , constraintKeyForeignKeyOnDeleteAction = Nothing+        }+  in+    ConstraintDefinition+      { _constraintSqlExpr = expr+      , _constraintMigrationKey = migrationKey+      }++{- |+  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.++@since 1.0.0.0+-}+data ForeignReference = ForeignReference+  { localFieldName :: FieldName.FieldName+  , foreignFieldName :: FieldName.FieldName+  }++{- |+  Constructs a 'ForeignReference'.++@since 1.0.0.0+-}+foreignReference ::+  -- | The name of the field in the table with the constraint.+  FieldName.FieldName ->+  -- | The name of the field in the foreign table that the local field references.+  FieldName.FieldName ->+  ForeignReference+foreignReference localName foreignName =+  ForeignReference+    { localFieldName = localName+    , foreignFieldName = foreignName+    }++{- |+  Defines the options for a foreign key constraint. To construct+  'ForeignKeyOptions', perform a record update on 'defaultForeignKeyOptions'.++@since 1.0.0.0+-}+data ForeignKeyOptions = ForeignKeyOptions+  { foreignKeyOptionsOnUpdate :: ForeignKeyAction+  -- ^ The @ON UPDATE@ action for the foreign key.+  , foreignKeyOptionsOnDelete :: ForeignKeyAction+  -- ^ The @ON DELETE@ action for the foreign key.+  }++{- |+  The default 'ForeignKeyOptions', containing 'NoAction' for both+  'foreignKeyOptionsOnUpdate' and 'foreignKeyOptionsOnDelete'.++@since 1.0.0.0+-}+defaultForeignKeyOptions :: ForeignKeyOptions+defaultForeignKeyOptions =+  ForeignKeyOptions+    { foreignKeyOptionsOnUpdate = NoAction+    , foreignKeyOptionsOnDelete = NoAction+    }++{- |+  The actions that can be set on 'ForeignKeyOptions'.++@since 1.0.0.0+-}+data ForeignKeyAction+  = NoAction+  | Restrict+  | Cascade+  | SetNull+  | SetDefault+  deriving (Show, Eq, Ord)++foreignKeyActionToExpr :: ForeignKeyAction -> Maybe Expr.ForeignKeyActionExpr+foreignKeyActionToExpr action = case action of+  NoAction -> Nothing+  Restrict -> Just Expr.restrictExpr+  Cascade -> Just Expr.cascadeExpr+  SetNull -> Just Expr.setNullExpr+  SetDefault -> Just Expr.setDefaultExpr++{- |+  Builds a 'ConstraintDefinition' for a @FOREIGN KEY@ constraint.++@since 1.0.0.0+-}+foreignKeyConstraint ::+  -- | Identifier of the table referenced by the foreign key.+  TableIdentifier.TableIdentifier ->+  -- | The columns constrained by the foreign key and those that they reference in the foreign table.+  NonEmpty ForeignReference ->+  ConstraintDefinition+foreignKeyConstraint foreignTableId foreignReferences =+  foreignKeyConstraintWithOptions foreignTableId foreignReferences defaultForeignKeyOptions++{- |+  Builds a 'ConstraintDefinition' for a @FOREIGN KEY@ constraint, with+  ON UPDATE and ON DELETE actions.++@since 1.0.0.0+-}+foreignKeyConstraintWithOptions ::+  -- | Identifier of the table referenced by the foreign key.+  TableIdentifier.TableIdentifier ->+  -- | The columns constrained by the foreign key and those that they reference in the foreign table.+  NonEmpty ForeignReference ->+  ForeignKeyOptions ->+  ConstraintDefinition+foreignKeyConstraintWithOptions foreignTableId foreignReferences options =+  let+    localFieldNames =+      localFieldName <$> foreignReferences++    foreignFieldNames =+      foreignFieldName <$> foreignReferences++    updateAction = foreignKeyOptionsOnUpdate options++    deleteAction = foreignKeyOptionsOnDelete options++    onUpdateExpr = fmap Expr.foreignKeyUpdateActionExpr $ foreignKeyActionToExpr updateAction++    onDeleteExpr = fmap Expr.foreignKeyDeleteActionExpr $ foreignKeyActionToExpr deleteAction++    expr =+      Expr.foreignKeyConstraint+        (fmap FieldName.fieldNameToColumnName localFieldNames)+        (TableIdentifier.tableIdQualifiedName foreignTableId)+        (fmap FieldName.fieldNameToColumnName foreignFieldNames)+        onUpdateExpr+        onDeleteExpr++    migrationKey =+      ConstraintMigrationKey+        { constraintKeyType = ForeignKeyConstraint+        , constraintKeyColumns = Just (NEL.toList localFieldNames)+        , constraintKeyForeignTable = Just foreignTableId+        , constraintKeyForeignColumns = Just (NEL.toList foreignFieldNames)+        , constraintKeyForeignKeyOnUpdateAction = Just updateAction+        , constraintKeyForeignKeyOnDeleteAction = Just deleteAction+        }+  in+    ConstraintDefinition+      { _constraintSqlExpr = expr+      , _constraintMigrationKey = migrationKey+      }
+ src/Orville/PostgreSQL/Schema/IndexDefinition.hs view
@@ -0,0 +1,25 @@+{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Schema.IndexDefinition+  ( IndexDefinition.IndexDefinition+  , IndexDefinition.indexCreationStrategy+  , IndexDefinition.setIndexCreationStrategy+  , IndexDefinition.uniqueIndex+  , IndexDefinition.uniqueNamedIndex+  , IndexDefinition.nonUniqueIndex+  , IndexDefinition.nonUniqueNamedIndex+  , IndexDefinition.mkIndexDefinition+  , IndexDefinition.mkNamedIndexDefinition+  , Expr.IndexUniqueness (UniqueIndex, NonUniqueIndex)+  , IndexDefinition.indexCreateExpr+  , IndexDefinition.IndexCreationStrategy (Transactional, Concurrent)+  )+where++import qualified Orville.PostgreSQL.Expr as Expr+import qualified Orville.PostgreSQL.Internal.IndexDefinition as IndexDefinition
+ src/Orville/PostgreSQL/Schema/PrimaryKey.hs view
@@ -0,0 +1,227 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Schema.PrimaryKey+  ( PrimaryKey+  , primaryKeyDescription+  , primaryKeyFieldNames+  , primaryKeyToSql+  , primaryKey+  , PrimaryKeyPart+  , compositePrimaryKey+  , primaryKeyPart+  , mapPrimaryKeyParts+  , mkPrimaryKeyExpr+  , primaryKeyEquals+  , primaryKeyIn+  )+where++import qualified Data.List as List+import Data.List.NonEmpty (NonEmpty ((:|)), toList)++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 qualified Orville.PostgreSQL.Raw.SqlValue as SqlValue++{- |+  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.++@since 1.0.0.0+-}+data PrimaryKey key+  = PrimaryKey (PrimaryKeyPart key) [PrimaryKeyPart key]++{- |+  A 'PrimaryKeyPart' describes one field of a composite primary key. Values+  are built using 'primaryKeyPart' and then used with 'compositePrimaryKey'+  to build a 'PrimaryKey'.++@since 1.0.0.0+-}+data PrimaryKeyPart key+  = forall part. PrimaryKeyPart (key -> part) (FieldDefinition NotNull part)++{- |+  '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.++@since 1.0.0.0+-}+primaryKeyDescription :: PrimaryKey key -> String+primaryKeyDescription =+  List.intercalate ", "+    . map fieldNameToString+    . toList+    . primaryKeyFieldNames++{- |+  Retrieves the names of the fields that are part of the primary key.++@since 1.0.0.0+-}+primaryKeyFieldNames :: PrimaryKey key -> NonEmpty FieldName+primaryKeyFieldNames =+  let+    partName :: (part -> key) -> FieldDefinition NotNull a -> FieldName+    partName _ field =+      fieldName field+  in+    mapPrimaryKeyParts partName++{- |+  'primaryKeyToSql' converts a Haskell value for a primary key into the+  (possibly multiple) SQL values that represent the primary key in the+  database.++@since 1.0.0.0+-}+primaryKeyToSql :: PrimaryKey key -> key -> NonEmpty SqlValue.SqlValue+primaryKeyToSql keyDef key =+  mapPrimaryKeyParts (partSqlValue key) keyDef++{- |+  '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+-}+partSqlValue :: key -> (key -> part) -> FieldDefinition NotNull part -> SqlValue.SqlValue+partSqlValue key getPart partField =+  fieldValueToSqlValue partField (getPart key)++{- |+  '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'.++@since 1.0.0.0+-}+primaryKey :: FieldDefinition NotNull key -> PrimaryKey key+primaryKey fieldDef =+  PrimaryKey (PrimaryKeyPart id fieldDef) []++{- |+  '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+  how to build the parts to be passed as parameters. Note: there is no special+  significance to the first argument other than requiring that there is at+  least one field in the primary key.++@since 1.0.0.0+-}+compositePrimaryKey ::+  PrimaryKeyPart key ->+  [PrimaryKeyPart key] ->+  PrimaryKey key+compositePrimaryKey =+  PrimaryKey++{- |+  '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+  passed in a list to 'compositePrimaryKey' to build a 'PrimaryKey'.++@since 1.0.0.0+-}+primaryKeyPart ::+  (key -> part) ->+  FieldDefinition NotNull part ->+  PrimaryKeyPart key+primaryKeyPart =+  PrimaryKeyPart++{- |+  '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+  this function, with the single-field case simply behaving as a composite key+  with just one part.++@since 1.0.0.0+-}+mapPrimaryKeyParts ::+  ( forall part.+    (key -> part) ->+    FieldDefinition NotNull part ->+    a+  ) ->+  PrimaryKey key ->+  NonEmpty a+mapPrimaryKeyParts f (PrimaryKey first rest) =+  let+    doPart (PrimaryKeyPart getPart field) =+      f getPart field+  in+    fmap doPart (first :| rest)++{- |+  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+-}+mkPrimaryKeyExpr :: PrimaryKey key -> Expr.PrimaryKeyExpr+mkPrimaryKeyExpr keyDef =+  let+    names =+      mapPrimaryKeyParts (\_ field -> fieldColumnName field) keyDef+  in+    Expr.primaryKeyExpr names++{- |+  '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.++@since 1.0.0.0+-}+primaryKeyEquals :: PrimaryKey key -> key -> Expr.BooleanExpr+primaryKeyEquals keyDef key =+  ExtraNonEmpty.foldl1'+    Expr.andExpr+    (mapPrimaryKeyParts (partEquals key) keyDef)++{- |+  '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.++@since 1.0.0.0+-}+primaryKeyIn :: PrimaryKey key -> NonEmpty key -> Expr.BooleanExpr+primaryKeyIn keyDef keys =+  case keyDef of+    PrimaryKey (PrimaryKeyPart getPart field) [] ->+      fieldIn field (fmap getPart keys)+    _ ->+      ExtraNonEmpty.foldl1'+        Expr.orExpr+        (fmap (primaryKeyEquals keyDef) keys)++{- |+  INTERNAL: builds the where condition for a single part of the key++@since 1.0.0.0+-}+partEquals :: key -> (key -> a) -> FieldDefinition nullability a -> Expr.BooleanExpr+partEquals key getPart partField =+  fieldEquals partField (getPart key)
+ src/Orville/PostgreSQL/Schema/SequenceDefinition.hs view
@@ -0,0 +1,264 @@+{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Schema.SequenceDefinition+  ( SequenceDefinition+  , mkSequenceDefinition+  , setSequenceSchema+  , sequenceIdentifier+  , sequenceName+  , sequenceIncrement+  , setSequenceIncrement+  , sequenceMinValue+  , setSequenceMinValue+  , sequenceMaxValue+  , setSequenceMaxValue+  , sequenceStart+  , setSequenceStart+  , sequenceCache+  , setSequenceCache+  , sequenceCycle+  , setSequenceCycle+  , mkCreateSequenceExpr+  )+where++import Data.Int (Int64)++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+  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+  attributes on the sequence.++@since 1.0.0.0+-}+data SequenceDefinition = SequenceDefinition+  { i_sequenceIdentifier :: SequenceIdentifier+  , i_sequenceIncrement :: Int64+  , i_sequenceMinValue :: Maybe Int64+  , i_sequenceMaxValue :: Maybe Int64+  , i_sequenceStart :: Maybe Int64+  , i_sequenceCache :: Int64+  , i_sequenceCycle :: Bool+  }+  deriving (Eq, Show)++{- |+  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.++@since 1.0.0.0+-}+mkSequenceDefinition :: String -> SequenceDefinition+mkSequenceDefinition name =+  SequenceDefinition+    { i_sequenceIdentifier = unqualifiedNameToSequenceId name+    , i_sequenceIncrement = 1+    , i_sequenceMinValue = Nothing+    , i_sequenceMaxValue = Nothing+    , i_sequenceStart = Nothing+    , i_sequenceCache = 1+    , i_sequenceCycle = False+    }++{- |+  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.++@since 1.0.0.0+-}+setSequenceSchema ::+  String ->+  SequenceDefinition ->+  SequenceDefinition+setSequenceSchema schemaName sequenceDef =+  sequenceDef+    { i_sequenceIdentifier = setSequenceIdSchema schemaName (i_sequenceIdentifier sequenceDef)+    }++{- |+  Retrieves the 'SequenceIdentifier' for this sequence, which is set by the+  name provided to 'mkSequenceDefinition' and any calls made to+  'setSequenceSchema' thereafter.++@since 1.0.0.0+-}+sequenceIdentifier :: SequenceDefinition -> SequenceIdentifier+sequenceIdentifier = i_sequenceIdentifier++{- |+  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 =+  sequenceIdQualifiedName . i_sequenceIdentifier++{- |+  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+  @0@ (PostgreSQL will raise an error when trying to create or modify the+  sequence in this case).++  If the increment is negative, the sequence will be descending. When no+  explicit start is set, a descending sequence begins at the max value.++@since 1.0.0.0+-}+setSequenceIncrement :: Int64 -> SequenceDefinition -> SequenceDefinition+setSequenceIncrement n sequenceDef =+  sequenceDef {i_sequenceIncrement = n}++{- |+  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.++@since 1.0.0.0+-}+sequenceMinValue :: SequenceDefinition -> Int64+sequenceMinValue sequenceDef =+  case i_sequenceMinValue sequenceDef of+    Just minValue -> minValue+    Nothing ->+      if sequenceIncrement sequenceDef >= 0+        then 1+        else minBound++{- |+  Sets the min value for the sequence.++@since 1.0.0.0+-}+setSequenceMinValue :: Int64 -> SequenceDefinition -> SequenceDefinition+setSequenceMinValue n sequenceDef =+  sequenceDef {i_sequenceMinValue = Just n}++{- |+  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.++@since 1.0.0.0+-}+sequenceMaxValue :: SequenceDefinition -> Int64+sequenceMaxValue sequenceDef =+  case i_sequenceMaxValue sequenceDef of+    Just maxValue -> maxValue+    Nothing ->+      if sequenceIncrement sequenceDef >= 0+        then maxBound+        else -1++{- |+  Sets the max value for the sequence.++@since 1.0.0.0+-}+setSequenceMaxValue :: Int64 -> SequenceDefinition -> SequenceDefinition+setSequenceMaxValue n sequenceDef =+  sequenceDef {i_sequenceMaxValue = Just n}++{- |+  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.++@since 1.0.0.0+-}+sequenceStart :: SequenceDefinition -> Int64+sequenceStart sequenceDef =+  case i_sequenceStart sequenceDef of+    Just start -> start+    Nothing ->+      if sequenceIncrement sequenceDef >= 0+        then sequenceMinValue sequenceDef+        else sequenceMaxValue sequenceDef++{- |+  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+-}+setSequenceStart :: Int64 -> SequenceDefinition -> SequenceDefinition+setSequenceStart n sequenceDef =+  sequenceDef {i_sequenceStart = Just n}++{- |+  Retrieves the number of sequence values that will be pre-allocated by+  PostgreSQL.++@since 1.0.0.0+-}+sequenceCache :: SequenceDefinition -> Int64+sequenceCache = i_sequenceCache++{- |+  Sets the number of sequence values that will be pre-allocated by PostgreSQL.++@since 1.0.0.0+-}+setSequenceCache :: Int64 -> SequenceDefinition -> SequenceDefinition+setSequenceCache n sequenceDef =+  sequenceDef {i_sequenceCache = n}++{- |+  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.++@since 1.0.0.0+-}+sequenceCycle :: SequenceDefinition -> Bool+sequenceCycle = i_sequenceCycle++{- |+  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.++@since 1.0.0.0+-}+setSequenceCycle :: Bool -> SequenceDefinition -> SequenceDefinition+setSequenceCycle b sequenceDef =+  sequenceDef {i_sequenceCycle = b}++{- |+  Builds a 'Expr.CreateSequenceExpr' that will create a SQL sequence matching+  the given 'SequenceDefinition' when it is executed.++@since 1.0.0.0+-}+mkCreateSequenceExpr :: SequenceDefinition -> Expr.CreateSequenceExpr+mkCreateSequenceExpr sequenceDef =+  Expr.createSequenceExpr+    (sequenceName sequenceDef)+    (Just . Expr.incrementBy . sequenceIncrement $ sequenceDef)+    (Just . Expr.minValue . sequenceMinValue $ sequenceDef)+    (Just . Expr.maxValue . sequenceMaxValue $ sequenceDef)+    (Just . Expr.startWith . sequenceStart $ sequenceDef)+    (Just . Expr.cache . sequenceCache $ sequenceDef)+    (Just . Expr.cycleIfTrue . sequenceCycle $ sequenceDef)
+ src/Orville/PostgreSQL/Schema/SequenceIdentifier.hs view
@@ -0,0 +1,125 @@+{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Schema.SequenceIdentifier+  ( SequenceIdentifier+  , unqualifiedNameToSequenceId+  , setSequenceIdSchema+  , sequenceIdQualifiedName+  , sequenceIdUnqualifiedName+  , sequenceIdSchemaName+  , sequenceIdToString+  , sequenceIdUnqualifiedNameString+  , sequenceIdSchemaNameString+  )+where++import qualified Orville.PostgreSQL.Expr as Expr++{- |+  An identifier used by Orville to identify a particular sequence in a particular+  schema.++@since 1.0.0.0+-}+data SequenceIdentifier = SequenceIdentifier+  { i_sequenceIdName :: String+  , i_sequenceIdSchema :: Maybe String+  }+  deriving (Eq, Ord, Show)++{- |+  Constructs a 'SequenceIdentifier' where the sequence's name will not be qualified+  by a particular schema.++@since 1.0.0.0+-}+unqualifiedNameToSequenceId :: String -> SequenceIdentifier+unqualifiedNameToSequenceId name =+  SequenceIdentifier+    { i_sequenceIdName = name+    , i_sequenceIdSchema = Nothing+    }++{- |+  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+-}+setSequenceIdSchema :: String -> SequenceIdentifier -> SequenceIdentifier+setSequenceIdSchema schema sequenceId =+  sequenceId+    { i_sequenceIdSchema = Just schema+    }++{- |+  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 sequenceId =+  Expr.qualifySequence+    (sequenceIdSchemaName sequenceId)+    (sequenceIdUnqualifiedName sequenceId)++{- |+  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+-}+sequenceIdUnqualifiedName :: SequenceIdentifier -> Expr.SequenceName+sequenceIdUnqualifiedName =+  Expr.sequenceName . i_sequenceIdName++{- |+  Returns the 'Expr.SchemaName' (if any) that should be used to qualify+  references to the sequence in SQL queries.++@since 1.0.0.0+-}+sequenceIdSchemaName :: SequenceIdentifier -> Maybe Expr.SchemaName+sequenceIdSchemaName =+  fmap Expr.schemaName . i_sequenceIdSchema++{- |+  Retrieves the unqualified name of the sequence as a 'String'.++@since 1.0.0.0+-}+sequenceIdUnqualifiedNameString :: SequenceIdentifier -> String+sequenceIdUnqualifiedNameString =+  i_sequenceIdName++{- |+  Retrieves the schema name of the sequence as a 'String'.++@since 1.0.0.0+-}+sequenceIdSchemaNameString :: SequenceIdentifier -> Maybe String+sequenceIdSchemaNameString =+  i_sequenceIdSchema++{- |+  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+  'sequenceIdQualifiedName' instead for that.++@since 1.0.0.0+-}+sequenceIdToString :: SequenceIdentifier -> String+sequenceIdToString sequenceId =+  case i_sequenceIdSchema sequenceId of+    Nothing ->+      i_sequenceIdName sequenceId+    Just schema ->+      schema <> "." <> i_sequenceIdName sequenceId
+ src/Orville/PostgreSQL/Schema/TableDefinition.hs view
@@ -0,0 +1,525 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Schema.TableDefinition+  ( TableDefinition+  , HasKey+  , NoKey+  , mkTableDefinition+  , mkTableDefinitionWithoutKey+  , dropColumns+  , columnsToDrop+  , tableIdentifier+  , tableName+  , setTableSchema+  , tableConstraints+  , addTableConstraints+  , tableIndexes+  , addTableIndexes+  , tablePrimaryKey+  , tableMarshaller+  , mapTableMarshaller+  , mkInsertExpr+  , mkCreateTableExpr+  , mkTableColumnDefinitions+  , mkTablePrimaryKeyExpr+  , mkInsertColumnList+  , mkInsertSource+  , mkTableReturningClause+  )+where++import Data.List.NonEmpty (NonEmpty, toList)+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set++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.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)++{- |+  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+    key and what the type of the key is if so. See 'HasKey' and 'NoKey' for+    values to be used in this parameter.++  * @writeEntity@ is the Haskell type for values that Orville will write+    to the database for you (i.e. both inserts and updates).++  * @readEntity@ is the Haskell type for values that Orville will decode+    from the result set when entities are queried from this table.++@since 1.0.0.0+-}+data TableDefinition key writeEntity readEntity = TableDefinition+  { i_tableIdentifier :: TableIdentifier+  , i_tablePrimaryKey :: TablePrimaryKey key+  , i_tableMarshaller :: AnnotatedSqlMarshaller writeEntity readEntity+  , i_tableColumnsToDrop :: Set.Set String+  , i_tableConstraintsFromTable :: TableConstraints+  , i_tableIndexes :: Map.Map IndexMigrationKey IndexDefinition+  }++{- |+  '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.++@since 1.0.0.0+-}+data HasKey key++{- |+  '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.++@since 1.0.0.0+-}+data NoKey++{- |+  INTERNAL: Use at the value level to track whether the 'TableDefinition' has a+  primary key. The @key@ parameter matches the @key@ parameter of+  'TableDefinition'++@since 1.0.0.0+-}+data TablePrimaryKey key where+  TableHasKey :: PrimaryKey keyType -> TablePrimaryKey (HasKey keyType)+  TableHasNoKey :: TablePrimaryKey NoKey++{- |+  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'.++@since 1.0.0.0+-}+mkTableDefinition ::+  -- | The name of the table+  String ->+  -- | Definition of the table's primary key+  PrimaryKey key ->+  -- | A 'SqlMarshaller' to marshall table entities to and from the database+  SqlMarshaller writeEntity readEntity ->+  TableDefinition (HasKey key) writeEntity readEntity+mkTableDefinition name primaryKey marshaller =+  TableDefinition+    { i_tableIdentifier = unqualifiedNameToTableId name+    , i_tablePrimaryKey = TableHasKey primaryKey+    , i_tableMarshaller = annotateSqlMarshaller (toList $ primaryKeyFieldNames primaryKey) marshaller+    , i_tableColumnsToDrop = Set.empty+    , i_tableConstraintsFromTable = emptyTableConstraints+    , i_tableIndexes = Map.empty+    }++{- |+  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+  that has no key.++@since 1.0.0.0+-}+mkTableDefinitionWithoutKey ::+  -- | The name of the table+  String ->+  -- | A 'SqlMarshaller' to marshall table entities to and from the database+  SqlMarshaller writeEntity readEntity ->+  TableDefinition NoKey writeEntity readEntity+mkTableDefinitionWithoutKey name marshaller =+  TableDefinition+    { i_tableIdentifier = unqualifiedNameToTableId name+    , i_tablePrimaryKey = TableHasNoKey+    , i_tableMarshaller = annotateSqlMarshallerEmptyAnnotation marshaller+    , i_tableColumnsToDrop = Set.empty+    , i_tableConstraintsFromTable = emptyTableConstraints+    , i_tableIndexes = Map.empty+    }++{- |+  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'.++  If you remove a reference to a column from the table's 'SqlMarshaller'+  without adding the column's name to 'dropColumns', Orville will operate as if+  the column does not exist without actually dropping the column. This is often+  useful if you're not sure you want to lose the data in the column, or if you+  have zero down-time deployments, which requires the column not be referenced+  by deployed code before it can be dropped.++@since 1.0.0.0+-}+dropColumns ::+  -- | Columns that should be dropped from the table+  [String] ->+  TableDefinition key writeEntity readEntity ->+  TableDefinition key writeEntity readEntity+dropColumns columns tableDef =+  tableDef+    { i_tableColumnsToDrop = i_tableColumnsToDrop tableDef <> Set.fromList columns+    }++{- |+  Returns the set of columns that have been marked as dropped by 'dropColumns'.++@since 1.0.0.0+-}+columnsToDrop :: TableDefinition key writeEntity readEntity -> Set.Set String+columnsToDrop =+  i_tableColumnsToDrop++{- |+  Returns the table's 'TableIdentifier'.++@since 1.0.0.0+-}+tableIdentifier :: TableDefinition key writeEntity readEntity -> TableIdentifier+tableIdentifier =+  i_tableIdentifier++{- |+  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 =+  tableIdQualifiedName . i_tableIdentifier++{- |+  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.++@since 1.0.0.0+-}+setTableSchema ::+  String ->+  TableDefinition key writeEntity readEntity ->+  TableDefinition key writeEntity readEntity+setTableSchema schemaName tableDef =+  tableDef+    { i_tableIdentifier = setTableIdSchema schemaName (i_tableIdentifier tableDef)+    }++{- |+  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'.++@since 1.0.0.0+-}+tableConstraints ::+  TableDefinition key writeEntity readEntity ->+  TableConstraints+tableConstraints =+  tableConstraintsFromMarshaller+    <> tableConstraintsFromTable++{- |+  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'.++@since 1.0.0.0+-}+tableConstraintsFromTable ::+  TableDefinition key writeEntity readEntity ->+  TableConstraints+tableConstraintsFromTable =+  i_tableConstraintsFromTable++{- |+  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'.++@since 1.0.0.0+-}+tableConstraintsFromMarshaller ::+  TableDefinition key writeEntity readEntity ->+  TableConstraints+tableConstraintsFromMarshaller =+  marshallerTableConstraints+    . unannotatedSqlMarshaller+    . i_tableMarshaller++{- |+  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'.++  If you wish to constrain multiple columns with a single constraint (e.g. a+  multi-column unique constraint), you must use 'addTableConstraints'.++  Note: If multiple constraints are added with the same+  'Orville.PostgreSQL.Schema.ConstraintMigrationKey', 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.++@since 1.0.0.0+-}+addTableConstraints ::+  [ConstraintDefinition] ->+  TableDefinition key writeEntity readEntity ->+  TableDefinition key writeEntity readEntity+addTableConstraints constraintDefs tableDef =+  tableDef+    { i_tableConstraintsFromTable =+        foldr+          addConstraint+          (i_tableConstraintsFromTable tableDef)+          constraintDefs+    }++{- |+  Retrieves all the table indexes that have been added to the table via+  'addTableIndexes'.++@since 1.0.0.0+-}+tableIndexes ::+  TableDefinition key writeEntity readEntity ->+  Map.Map IndexMigrationKey IndexDefinition+tableIndexes =+  i_tableIndexes++{- |+  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+  previously-added index with the same key is replaced by the new one.++@since 1.0.0.0+-}+addTableIndexes ::+  [IndexDefinition] ->+  TableDefinition key writeEntity readEntity ->+  TableDefinition key writeEntity readEntity+addTableIndexes indexDefs tableDef =+  let+    addIndex index indexMap =+      Map.insert (indexMigrationKey index) index indexMap+  in+    tableDef+      { i_tableIndexes = foldr addIndex (i_tableIndexes tableDef) indexDefs+      }++{- |+  Returns the primary key for the table, as defined at construction via+  'mkTableDefinition'.++@since 1.0.0.0+-}+tablePrimaryKey :: TableDefinition (HasKey key) writeEntity readEntity -> PrimaryKey key+tablePrimaryKey def =+  case i_tablePrimaryKey def of+    TableHasKey primaryKey -> primaryKey++{- |+  Returns the marshaller for the table, as defined at construction via+  'mkTableDefinition'.++@since 1.0.0.0+-}+tableMarshaller :: TableDefinition key writeEntity readEntity -> AnnotatedSqlMarshaller writeEntity readEntity+tableMarshaller = i_tableMarshaller++{- |+  Applies the provided function to the underlying 'SqlMarshaller' of the+  'TableDefinition'.++@since 1.0.0.0+-}+mapTableMarshaller ::+  (SqlMarshaller readEntityA writeEntityA -> SqlMarshaller readEntityB writeEntityB) ->+  TableDefinition key readEntityA writeEntityA ->+  TableDefinition key readEntityB writeEntityB+mapTableMarshaller f tableDef =+  tableDef {i_tableMarshaller = mapSqlMarshaller f $ i_tableMarshaller tableDef}++{- |+  Builds a 'Expr.CreateTableExpr' that will create a SQL table matching the+  given 'TableDefinition' when it is executed.++@since 1.0.0.0+-}+mkCreateTableExpr ::+  TableDefinition key writeEntity readEntity ->+  Expr.CreateTableExpr+mkCreateTableExpr tableDef =+  Expr.createTableExpr+    (tableName tableDef)+    (mkTableColumnDefinitions tableDef)+    (mkTablePrimaryKeyExpr tableDef)+    (map constraintSqlExpr . tableConstraintDefinitions . tableConstraints $ tableDef)++{- |+  Builds the 'Expr.ColumnDefinitions' for all the fields described by the+  table definition's 'SqlMarshaller'.++@since 1.0.0.0+-}+mkTableColumnDefinitions ::+  TableDefinition key writeEntity readEntity ->+  [Expr.ColumnDefinition]+mkTableColumnDefinitions tableDef =+  foldMarshallerFields+    (unannotatedSqlMarshaller $ tableMarshaller tableDef)+    []+    (collectFromField IncludeReadOnlyColumns fieldColumnDefinition)++{- |+  Builds the 'Expr.PrimaryKeyExpr' for this table, or none if this table has no+  primary key.++@since 1.0.0.0+-}+mkTablePrimaryKeyExpr ::+  TableDefinition key writeEntity readEntity ->+  Maybe Expr.PrimaryKeyExpr+mkTablePrimaryKeyExpr tableDef =+  case i_tablePrimaryKey tableDef of+    TableHasKey primaryKey ->+      Just $ mkPrimaryKeyExpr primaryKey+    TableHasNoKey ->+      Nothing++{- |+  When 'WithReturning' is given, builds a 'Expr.ReturningExpr' that will+  return all the columns in the given 'TableDefinition'.++@since 1.0.0.0+-}+mkTableReturningClause ::+  ReturningOption returningClause ->+  TableDefinition key writeEntity readEntty ->+  Maybe Expr.ReturningExpr+mkTableReturningClause returningOption tableDef =+  case returningOption of+    WithoutReturning ->+      Nothing+    WithReturning ->+      Just+        . Expr.returningExpr+        . Expr.selectDerivedColumns+        . marshallerDerivedColumns+        . unannotatedSqlMarshaller+        . tableMarshaller+        $ tableDef++{- |+  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.++@since 1.0.0.0+-}+mkInsertExpr ::+  ReturningOption returningClause ->+  TableDefinition key writeEntity readEntity ->+  NonEmpty writeEntity ->+  Expr.InsertExpr+mkInsertExpr returningOption tableDef entities =+  let+    marshaller =+      unannotatedSqlMarshaller $ tableMarshaller tableDef++    insertColumnList =+      mkInsertColumnList marshaller++    insertSource =+      mkInsertSource marshaller entities+  in+    Expr.insertExpr+      (tableName tableDef)+      (Just insertColumnList)+      insertSource+      (mkTableReturningClause returningOption tableDef)++{- |+  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+  via 'mkInsertExpr', but this is exported in case you are composing SQL+  yourself and need the column list of an insert as a fragment.++@since 1.0.0.0+-}+mkInsertColumnList ::+  SqlMarshaller writeEntity readEntity ->+  Expr.InsertColumnList+mkInsertColumnList marshaller =+  Expr.insertColumnList $+    foldMarshallerFields marshaller [] (collectFromField ExcludeReadOnlyColumns fieldColumnName)++{- |+  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').++  In normal circumstances you will want to build the complete insert statement+  via 'mkInsertExpr', but this is exported in case you are composing SQL+  yourself and need the column list of an insert as a fragment.++@since 1.0.0.0+-}+mkInsertSource ::+  SqlMarshaller writeEntity readEntity ->+  NonEmpty writeEntity ->+  Expr.InsertSource+mkInsertSource marshaller entities =+  let+    encodeRow =+      foldMarshallerFields marshaller (const []) collectSqlValue+  in+    Expr.insertSqlValues $ map encodeRow (toList entities)++{- |+  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.++@since 1.0.0.0+-}+collectSqlValue ::+  MarshallerField entity ->+  (entity -> [SqlValue]) ->+  entity ->+  [SqlValue]+collectSqlValue entry encodeRest entity =+  case entry of+    Natural fieldDef (Just accessor) ->+      fieldValueToSqlValue fieldDef (accessor entity) : (encodeRest entity)+    Natural _ Nothing ->+      encodeRest entity+    Synthetic _ ->+      encodeRest entity
+ src/Orville/PostgreSQL/Schema/TableIdentifier.hs view
@@ -0,0 +1,125 @@+{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++@since 1.0.0.0+-}+module Orville.PostgreSQL.Schema.TableIdentifier+  ( TableIdentifier+  , unqualifiedNameToTableId+  , setTableIdSchema+  , tableIdQualifiedName+  , tableIdUnqualifiedName+  , tableIdSchemaName+  , tableIdToString+  , tableIdUnqualifiedNameString+  , tableIdSchemaNameString+  )+where++import qualified Orville.PostgreSQL.Expr as Expr++{- |+  An identifier used by Orville to identify a particular table in a particular+  schema.++@since 1.0.0.0+-}+data TableIdentifier = TableIdentifier+  { i_tableIdName :: String+  , i_tableIdSchema :: Maybe String+  }+  deriving (Eq, Ord, Show)++{- |+  Constructs a 'TableIdentifier' where the table's name will not be qualified+  by a particular schema.++@since 1.0.0.0+-}+unqualifiedNameToTableId :: String -> TableIdentifier+unqualifiedNameToTableId name =+  TableIdentifier+    { i_tableIdName = name+    , i_tableIdSchema = Nothing+    }++{- |+  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+-}+setTableIdSchema :: String -> TableIdentifier -> TableIdentifier+setTableIdSchema schema tableId =+  tableId+    { i_tableIdSchema = Just schema+    }++{- |+  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 tableId =+  Expr.qualifyTable+    (tableIdSchemaName tableId)+    (tableIdUnqualifiedName tableId)++{- |+  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+-}+tableIdUnqualifiedName :: TableIdentifier -> Expr.TableName+tableIdUnqualifiedName =+  Expr.tableName . i_tableIdName++{- |+  Returns the 'Expr.SchemaName' (if any) that should be used to qualify+  references to the table in SQL queries.++@since 1.0.0.0+-}+tableIdSchemaName :: TableIdentifier -> Maybe Expr.SchemaName+tableIdSchemaName =+  fmap Expr.schemaName . i_tableIdSchema++{- |+  Retrieves the unqualified name of the table as a 'String'.++@since 1.0.0.0+-}+tableIdUnqualifiedNameString :: TableIdentifier -> String+tableIdUnqualifiedNameString =+  i_tableIdName++{- |+  Retrieves the schema name of the table as a 'String'.++@since 1.0.0.0+-}+tableIdSchemaNameString :: TableIdentifier -> Maybe String+tableIdSchemaNameString =+  i_tableIdSchema++{- |+  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+  'tableIdQualifiedName' instead for that.++@since 1.0.0.0+-}+tableIdToString :: TableIdentifier -> String+tableIdToString tableId =+  case i_tableIdSchema tableId of+    Nothing ->+      i_tableIdName tableId+    Just schema ->+      schema <> "." <> i_tableIdName tableId
+ src/Orville/PostgreSQL/UnliftIO.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE RankNTypes #-}++{- |+Copyright : Flipstone Technology Partners 2023+License   : MIT+Stability : Stable++This module provides functions that can be used to implement+'Orville.PostgreSQL.MonadOrvilleControl' for monads that implement+'UL.MonadUnliftIO'. For example:++@+module MyMonad+  ( MyMonad+  ) where++import qualified Control.Monad.IO.Unlift as UnliftIO+import qualified Orville.PostgreSQL as O+import qualified Orville.PostgreSQL.UnliftIO as OrvilleUnliftIO++newtype MyMonad =+  ...+  deriving (UnliftIO.MonadUnliftIO)++instance O.MonadOrvilleControl MyMonad where+  liftWithConnection = OrvilleUnliftIO.liftWithConnectionViaUnliftIO+  liftCatch = OrvilleUnliftIO.liftCatchViaUnliftIO+  liftMask = OrvilleUnliftIO.liftMaskViaUnliftIO+@++@since 1.0.0.0+-}+module Orville.PostgreSQL.UnliftIO+  ( liftWithConnectionViaUnliftIO+  , liftCatchViaUnliftIO+  , liftMaskViaUnliftIO+  )+where++import qualified Control.Monad.IO.Unlift as UL++{- |+  'liftWithConnectionViaUnliftIO' can be used as the implementation of+  'Orville.PostgreSQL.liftWithConnection' for+  'Orville.PostgreSQL.MonadOrvilleControl' when the 'Monad' implements+  'UL.MonadUnliftIO'.++  @since 1.0.0.0+-}+liftWithConnectionViaUnliftIO ::+  UL.MonadUnliftIO m =>+  (forall a. (conn -> IO a) -> IO a) ->+  (conn -> m b) ->+  m b+liftWithConnectionViaUnliftIO ioWithConn action =+  UL.withRunInIO $ \runInIO -> ioWithConn (runInIO . action)++{- |+  'liftCatchViaUnliftIO' can be used as the implementation of+  'Orville.PostgreSQL.liftCatch' for 'Orville.PostgreSQL.MonadOrvilleControl'+  when the 'Monad' implements 'UL.MonadUnliftIO'.++  @since 1.0.0.0+-}+liftCatchViaUnliftIO ::+  UL.MonadUnliftIO m =>+  (forall a. IO a -> (e -> IO a) -> IO a) ->+  m b ->+  (e -> m b) ->+  m b+liftCatchViaUnliftIO ioCatch action handler = do+  unlio <- UL.askUnliftIO+  UL.liftIO $+    ioCatch+      (UL.unliftIO unlio action)+      (\ex -> UL.unliftIO unlio (handler ex))++{- |+  'liftMaskViaUnliftIO' can be used as the implementation of+  'Orville.PostgreSQL.liftMask' for 'Orville.PostgreSQL.MonadOrvilleControl'+  when the 'Monad' implements 'UL.MonadUnliftIO'.++  @since 1.0.0.0+-}+liftMaskViaUnliftIO ::+  UL.MonadUnliftIO m =>+  (forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b) ->+  ((forall a. m a -> m a) -> m c) ->+  m c+liftMaskViaUnliftIO ioMask action = do+  unlio <- UL.askUnliftIO+  UL.liftIO $+    ioMask $ \restore ->+      UL.unliftIO+        unlio+        (action (UL.liftIO . restore . UL.unliftIO unlio))
+ test/Main.hs view
@@ -0,0 +1,114 @@+module Main+  ( main+  , recheckDBProperty+  )+where++import qualified Control.Monad as Monad+import qualified Hedgehog as HH+import qualified System.Environment as Env+import qualified System.Exit as SE++import qualified Orville.PostgreSQL as Orville++import qualified Test.AutoMigration as AutoMigration+import qualified Test.Connection as Connection+import qualified Test.Cursor as Cursor+import qualified Test.EntityOperations as EntityOperations+import qualified Test.Execution as Execution+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.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.Time as ExprTime+import qualified Test.Expr.Where as ExprWhere+import qualified Test.FieldDefinition as FieldDefinition+import qualified Test.MarshallError as MarshallError+import qualified Test.PgCatalog as PgCatalog+import qualified Test.PgTime as PgTime+import qualified Test.Plan as Plan+import qualified Test.PostgreSQLAxioms as PostgreSQLAxioms+import qualified Test.Property as Property+import qualified Test.RawSql as RawSql+import qualified Test.ReservedWords as ReservedWords+import qualified Test.SelectOptions as SelectOptions+import qualified Test.Sequence as Sequence+import qualified Test.SqlCommenter as SqlCommenter+import qualified Test.SqlMarshaller as SqlMarshaller+import qualified Test.SqlType as SqlType+import qualified Test.TableDefinition as TableDefinition+import qualified Test.Transaction as Transaction++main :: IO ()+main = do+  pool <- createTestConnectionPool++  summary <-+    Property.checkGroups+      [ Connection.connectionTests pool+      , RawSql.rawSqlTests pool+      , Execution.executionTests pool+      , SqlType.sqlTypeTests pool+      , PostgreSQLAxioms.postgreSQLAxiomTests pool+      , ExprInsertUpdateDelete.insertUpdateDeleteTests pool+      , ExprWhere.whereTests pool+      , ExprOrderBy.orderByTests pool+      , ExprGroupBy.groupByTests pool+      , ExprGroupByOrderBy.groupByOrderByTests pool+      , ExprTableDefinition.tableDefinitionTests pool+      , ExprSequenceDefinition.sequenceDefinitionTests pool+      , ExprCursor.cursorTests pool+      , ExprCount.countTests pool+      , ExprMath.mathTests pool+      , ExprTime.timeTests pool+      , FieldDefinition.fieldDefinitionTests pool+      , SqlMarshaller.sqlMarshallerTests+      , MarshallError.marshallErrorTests pool+      , TableDefinition.tableDefinitionTests pool+      , EntityOperations.entityOperationsTests pool+      , SelectOptions.selectOptionsTests+      , ReservedWords.reservedWordsTests pool+      , Transaction.transactionTests pool+      , Sequence.sequenceTests pool+      , Plan.planTests pool+      , PgCatalog.pgCatalogTests pool+      , AutoMigration.autoMigrationTests pool+      , Cursor.cursorTests pool+      , SqlCommenter.sqlCommenterTests pool+      , PgTime.pgTimeTests pool+      ]++  Monad.unless (Property.allPassed summary) SE.exitFailure++createTestConnectionPool :: IO Orville.ConnectionPool+createTestConnectionPool = do+  connStr <- lookupConnStr+  -- Some tests use more than one connection, so the pool size must be greater+  -- than 1+  Orville.createConnectionPool $+    Orville.ConnectionOptions+      { Orville.connectionString = connStr+      , Orville.connectionNoticeReporting = Orville.DisableNoticeReporting+      , Orville.connectionPoolStripes = Orville.OneStripePerCapability+      , Orville.connectionPoolLingerTime = 10+      , Orville.connectionPoolMaxConnections = Orville.MaxConnectionsPerStripe 2+      }++recheckDBProperty :: HH.Size -> HH.Seed -> Property.NamedDBProperty -> IO ()+recheckDBProperty size seed namedProperty = do+  pool <- createTestConnectionPool+  HH.recheck size seed (snd $ namedProperty pool)++lookupConnStr :: IO String+lookupConnStr = do+  mbConnHostStr <- Env.lookupEnv "TEST_CONN_HOST"+  let+    connStrUserPass = " user=orville_test password=orville"+  case mbConnHostStr of+    Nothing -> fail "TEST_CONN_HOST not set, so we don't know what database to connect to!"+    Just connHost -> pure $ connHost <> connStrUserPass
+ test/Test/AutoMigration.hs view
@@ -0,0 +1,1203 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Test.AutoMigration+  ( autoMigrationTests+  )+where++import qualified Control.Exception.Safe as ExSafe+import qualified Control.Monad.IO.Class as MIO+import qualified Data.ByteString.Char8 as B8+import qualified Data.Foldable as Fold+import qualified Data.Function as Function+import Data.Int (Int32)+import Data.List ((\\))+import qualified Data.List as List+import qualified Data.List.NonEmpty as NEL+import qualified Data.Maybe as Maybe+import qualified Data.String as String+import Hedgehog ((===))+import qualified Hedgehog as HH+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import qualified Orville.PostgreSQL as Orville+import qualified Orville.PostgreSQL.AutoMigration as AutoMigration+import qualified Orville.PostgreSQL.Expr as Expr+import qualified Orville.PostgreSQL.PgCatalog as PgCatalog+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 Test.Entities.Foo as Foo+import qualified Test.PgAssert as PgAssert+import qualified Test.PgGen as PgGen+import qualified Test.Property as Property+import qualified Test.TestTable as TestTable++autoMigrationTests :: Orville.ConnectionPool -> Property.Group+autoMigrationTests pool =+  Property.group+    "AutoMigration"+    [ prop_raisesErrorIfMigrationLockIsLocked pool+    , prop_releasesMigrationLockOnError pool+    , prop_createsMissingTables pool+    , prop_dropsRequestedTables pool+    , prop_addsAndRemovesColumns pool+    , prop_columnsWithSystemNameConflictsRaiseError pool+    , prop_altersColumnDataType pool+    , prop_altersColumnDefaultValue_TextNumeric pool+    , prop_altersColumnDefaultValue_Bool pool+    , prop_altersColumnDefaultValue_Timelike pool+    , prop_respectsImplicitDefaultOnSerialFields pool+    , prop_addAndRemovesUniqueConstraints pool+    , prop_addAndRemovesForeignKeyConstraints pool+    , prop_createsMissingSequences pool+    , prop_dropsRequestedSequences pool+    , prop_altersModifiedSequences pool+    , prop_addsAndRemovesMixedIndexes pool+    , prop_arbitrarySchemaInitialMigration pool+    ]++prop_raisesErrorIfMigrationLockIsLocked :: Property.NamedDBProperty+prop_raisesErrorIfMigrationLockIsLocked =+  Property.singletonNamedDBProperty "Raises an error when the migration lock is hold" $ \pool -> do+    errOrSuccess <-+      HH.evalIO $+        Orville.runOrville pool $+          AutoMigration.withMigrationLock AutoMigration.defaultLockId $+            MIO.liftIO $+              ExSafe.try $+                Orville.runOrville pool $+                  AutoMigration.withMigrationLock+                    AutoMigration.defaultLockId+                    (pure ())++    case errOrSuccess of+      Left (_err :: AutoMigration.MigrationLockError) -> pure ()+      Right () -> do+        HH.annotate "Expected MigrationLockError error to be thrown, but it was not"+        HH.failure++prop_releasesMigrationLockOnError :: Property.NamedDBProperty+prop_releasesMigrationLockOnError =+  Property.singletonNamedDBProperty "Releases the migration lock on error" $ \pool -> do+    HH.evalIO $+      Orville.runOrville pool $+        -- Acquire a connection before running a second orville context to+        -- ensure that each context will get a separate connection from the+        -- pool. Both connections must be open simultaneously for this test+        -- to be valid since the lock we are testing is held at a session+        -- level.+        Orville.withConnection_ $ do+          MIO.liftIO $+            Orville.runOrville pool $+              ExSafe.handle (\SimulatedError -> pure ()) $+                AutoMigration.withMigrationLock+                  AutoMigration.defaultLockId+                  (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+            (pure ())++data SimulatedError = SimulatedError+  deriving (Show)++instance ExSafe.Exception SimulatedError++prop_createsMissingTables :: Property.NamedDBProperty+prop_createsMissingTables =+  Property.singletonNamedDBProperty "Creates missing tables" $ \pool -> do+    let+      fooTableId =+        Orville.tableIdentifier Foo.table++    firstTimePlan <-+      HH.evalIO $+        Orville.runOrville pool $ do+          Orville.executeVoid Orville.DDLQuery $ TestTable.dropTableDefSql Foo.table+          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.assertTableExists+        pool+        (Orville.tableIdUnqualifiedNameString fooTableId)+    migrationPlanStepStrings secondTimePlan === []++prop_dropsRequestedTables :: Property.NamedDBProperty+prop_dropsRequestedTables =+  Property.singletonNamedDBProperty "Drops requested tables" $ \pool -> do+    let+      fooTableId =+        Orville.tableIdentifier Foo.table++    firstTimePlan <-+      HH.evalIO $+        Orville.runOrville pool $ do+          Orville.executeVoid Orville.DDLQuery $ TestTable.dropTableDefSql Foo.table+          Orville.executeVoid Orville.DDLQuery $ Orville.mkCreateTableExpr Foo.table+          AutoMigration.generateMigrationPlan AutoMigration.defaultOptions [AutoMigration.SchemaDropTable fooTableId]++    secondTimePlan <-+      HH.evalIO $+        Orville.runOrville pool $ do+          AutoMigration.executeMigrationPlan AutoMigration.defaultOptions firstTimePlan+          AutoMigration.generateMigrationPlan AutoMigration.defaultOptions [AutoMigration.SchemaDropTable fooTableId]++    length (AutoMigration.migrationPlanSteps firstTimePlan) === 1+    PgAssert.assertTableDoesNotExist pool (Orville.tableIdUnqualifiedNameString fooTableId)+    migrationPlanStepStrings secondTimePlan === []++prop_addsAndRemovesColumns :: Property.NamedDBProperty+prop_addsAndRemovesColumns =+  Property.namedDBProperty "Adds and removes columns columns" $ \pool -> do+    let+      genColumnList =+        Gen.subsequence ["foo", "bar", "baz", "bat", "bax"]++    originalColumns <- HH.forAll genColumnList+    newColumns <- HH.forAll genColumnList++    let+      columnsToDrop =+        originalColumns \\ newColumns++      originalTableDef =+        mkIntListTable "migration_test" originalColumns++      newTableDef =+        Orville.dropColumns columnsToDrop $+          mkIntListTable "migration_test" newColumns++    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]++    secondTimePlan <-+      HH.evalIO $+        Orville.runOrville pool $ do+          AutoMigration.executeMigrationPlan AutoMigration.defaultOptions firstTimePlan+          AutoMigration.generateMigrationPlan AutoMigration.defaultOptions [AutoMigration.SchemaTable newTableDef]++    migrationPlanStepStrings secondTimePlan === []+    tableDesc <- PgAssert.assertTableExists pool "migration_test"+    PgAssert.assertColumnNamesEqual tableDesc newColumns++prop_columnsWithSystemNameConflictsRaiseError :: Property.NamedDBProperty+prop_columnsWithSystemNameConflictsRaiseError =+  Property.singletonNamedDBProperty "An error is raised trying to add a column that conflicts with a system name" $ \pool -> do+    let+      tableWithSystemAttributeNames =+        Orville.mkTableDefinitionWithoutKey+          "table_with_system_attribute_names"+          (Orville.marshallField id (Orville.unboundedTextField "tableoid"))++    result <-+      HH.evalIO $+        Orville.runOrville pool $ do+          Orville.executeVoid Orville.DDLQuery $ TestTable.dropTableDefSql tableWithSystemAttributeNames++          -- Create the table with no columns first to ensure we go down the+          -- "add column" path+          Orville.executeVoid Orville.DDLQuery $+            Expr.createTableExpr+              (Orville.tableName tableWithSystemAttributeNames)+              []+              Nothing+              []++          ExSafe.try $+            AutoMigration.autoMigrateSchema+              AutoMigration.defaultOptions+              [AutoMigration.SchemaTable tableWithSystemAttributeNames]++    case result of+      Left err ->+        Conn.sqlExecutionErrorSqlState err === Just (B8.pack "42701")+      Right () -> do+        HH.annotate "Expected migration to fail, but it did not"+        HH.failure++{- |+  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.++@since 1.0.0.0+-}+data SomeField where+  SomeField :: Orville.FieldDefinition nullability a -> SomeField++describeField :: SomeField -> String+describeField (SomeField field) =+  B8.unpack (RawSql.toExampleBytes $ Orville.fieldColumnDefinition field)++prop_altersColumnDataType :: Property.NamedDBProperty+prop_altersColumnDataType =+  Property.namedDBProperty "Alters data type on existing column" $ \pool -> do+    let+      baseFieldDefs =+        -- Serial columns are omitted from this list currently because+        -- the are pseudo-types in postgresql, rather than real column types.+        -- We don't handle migrating "away" from them to regular integer type.+        --+        -- time-like and boolean columns are omitted because postgresql raises+        -- an unable-to-cast error when attempting to migrate between them and+        -- numeric columns.+        [ SomeField $ Orville.unboundedTextField "column"+        , SomeField $ Orville.boundedTextField "column" 1+        , SomeField $ Orville.boundedTextField "column" 255+        , SomeField $ Orville.fixedTextField "column" 1+        , SomeField $ Orville.fixedTextField "column" 255+        , SomeField $ Orville.integerField "column"+        , SomeField $ Orville.smallIntegerField "column"+        , SomeField $ Orville.bigIntegerField "column"+        , SomeField $ Orville.doubleField "column"+        ]++      mkNullable (SomeField field) =+        case Orville.fieldNullability field of+          Orville.NullableField nullable ->+            SomeField $ nullable+          Orville.NotNullField notNull ->+            SomeField $ Orville.nullableField notNull++      generateFieldDefinition =+        Gen.element (baseFieldDefs ++ fmap mkNullable baseFieldDefs)++    SomeField originalField <- HH.forAllWith describeField generateFieldDefinition+    SomeField newField <- HH.forAllWith describeField generateFieldDefinition++    let+      originalTableDef =+        Orville.mkTableDefinitionWithoutKey+          "migration_test"+          (Orville.marshallField id originalField)++      newTableDef =+        Orville.mkTableDefinitionWithoutKey+          "migration_test"+          (Orville.marshallField id newField)++      newSqlType =+        Orville.fieldType 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]++    secondTimePlan <-+      HH.evalIO $+        Orville.runOrville pool $ do+          AutoMigration.executeMigrationPlan AutoMigration.defaultOptions firstTimePlan+          AutoMigration.generateMigrationPlan AutoMigration.defaultOptions [AutoMigration.SchemaTable newTableDef]++    migrationPlanStepStrings secondTimePlan === []+    newTableDesc <- PgAssert.assertTableExists pool "migration_test"+    attr <- PgAssert.assertColumnExists newTableDesc "column"+    PgCatalog.pgAttributeTypeOid attr === Orville.sqlTypeOid newSqlType+    PgCatalog.pgAttributeMaxLength attr === Orville.sqlTypeMaximumLength newSqlType+    PgCatalog.pgAttributeIsNotNull attr === Orville.fieldIsNotNullable newField++genFieldWithMaybeDefault ::+  HH.Gen a ->+  (a -> Orville.DefaultValue a) ->+  Orville.FieldDefinition nullability a ->+  HH.Gen (Orville.FieldDefinition nullability a)+genFieldWithMaybeDefault defaultGen mkDefaultValue fieldDef = do+  maybeDefault <- Gen.maybe defaultGen+  pure $+    case maybeDefault of+      Nothing ->+        fieldDef+      Just def ->+        Orville.setDefaultValue (mkDefaultValue def) fieldDef++prop_altersColumnDefaultValue_TextNumeric :: Property.NamedDBProperty+prop_altersColumnDefaultValue_TextNumeric =+  Property.namedDBProperty "Alters default value on existing column (text/numeric)" $ \pool -> do+    let+      genDefaultText =+        PgGen.pgText (Range.linear 0 10)++      genDefaultIntegral :: Integral n => HH.Gen n+      genDefaultIntegral =+        Gen.integral (Range.linear (-10) 10)++      genDefaultDouble =+        PgGen.pgDouble++    assertDefaultValuesMigrateProperly pool $+      Gen.choice+        [ SomeField <$> genFieldWithMaybeDefault genDefaultText Orville.textDefault (Orville.unboundedTextField "column")+        , SomeField <$> genFieldWithMaybeDefault genDefaultText Orville.textDefault (Orville.boundedTextField "column" 10)+        , SomeField <$> genFieldWithMaybeDefault genDefaultText Orville.textDefault (Orville.fixedTextField "column" 10)+        , SomeField <$> genFieldWithMaybeDefault genDefaultIntegral Orville.integerDefault (Orville.integerField "column")+        , SomeField <$> genFieldWithMaybeDefault genDefaultIntegral Orville.smallIntegerDefault (Orville.smallIntegerField "column")+        , SomeField <$> genFieldWithMaybeDefault genDefaultIntegral Orville.bigIntegerDefault (Orville.bigIntegerField "column")+        , SomeField <$> genFieldWithMaybeDefault genDefaultDouble Orville.doubleDefault (Orville.doubleField "column")+        ]++prop_altersColumnDefaultValue_Bool :: Property.NamedDBProperty+prop_altersColumnDefaultValue_Bool =+  Property.namedDBProperty "Alters default value on existing column (boolean)" $ \pool -> do+    assertDefaultValuesMigrateProperly pool $+      Gen.choice+        [ SomeField <$> genFieldWithMaybeDefault Gen.bool Orville.booleanDefault (Orville.booleanField "column")+        ]++prop_altersColumnDefaultValue_Timelike :: Property.NamedDBProperty+prop_altersColumnDefaultValue_Timelike =+  Property.namedDBProperty "Alters default value on existing column (timelike)" $ \pool -> do+    assertDefaultValuesMigrateProperly pool $+      Gen.choice+        [ -- Fields without default, or with specific times for the default+          SomeField <$> genFieldWithMaybeDefault PgGen.pgUTCTime Orville.utcTimestampDefault (Orville.utcTimestampField "column")+        , SomeField <$> genFieldWithMaybeDefault PgGen.pgLocalTime Orville.localTimestampDefault (Orville.localTimestampField "column")+        , SomeField <$> genFieldWithMaybeDefault PgGen.pgDay Orville.dateDefault (Orville.dateField "column")+        , -- Fields with "now" for the default+          pure . SomeField $ Orville.setDefaultValue Orville.currentUTCTimestampDefault (Orville.utcTimestampField "column")+        , pure . SomeField $ Orville.setDefaultValue Orville.currentLocalTimestampDefault (Orville.localTimestampField "column")+        , pure . SomeField $ Orville.setDefaultValue Orville.currentDateDefault (Orville.dateField "column")+        ]++prop_respectsImplicitDefaultOnSerialFields :: Property.NamedDBProperty+prop_respectsImplicitDefaultOnSerialFields =+  Property.namedDBProperty "Respects implicit default on serial fields" $ \pool -> do+    SomeField fieldDef <-+      HH.forAllWith describeField $+        Gen.element+          [ SomeField $ Orville.serialField "column"+          , SomeField $ Orville.bigSerialField "column"+          ]++    let+      tableDef =+        Orville.mkTableDefinitionWithoutKey+          "migration_test"+          (Orville.marshallField id fieldDef)++    firstTimePlan <-+      HH.evalIO $+        Orville.runOrville pool $ do+          Orville.executeVoid Orville.DDLQuery $ TestTable.dropTableDefSql tableDef+          Orville.executeVoid Orville.DDLQuery $ Schema.mkCreateTableExpr tableDef+          AutoMigration.generateMigrationPlan AutoMigration.defaultOptions [AutoMigration.SchemaTable tableDef]++    originalTableDesc <- PgAssert.assertTableExists pool "migration_test"+    PgAssert.assertColumnDefaultExists originalTableDesc "column"++    secondTimePlan <-+      HH.evalIO $+        Orville.runOrville pool $ do+          AutoMigration.executeMigrationPlan AutoMigration.defaultOptions firstTimePlan+          AutoMigration.generateMigrationPlan AutoMigration.defaultOptions [AutoMigration.SchemaTable tableDef]++    newTableDesc <- PgAssert.assertTableExists pool "migration_test"+    PgAssert.assertColumnDefaultExists newTableDesc "column"+    migrationPlanStepStrings secondTimePlan === []++assertDefaultValuesMigrateProperly ::+  Orville.ConnectionPool ->+  HH.Gen SomeField ->+  HH.PropertyT IO ()+assertDefaultValuesMigrateProperly pool genSomeField = do+  SomeField originalField <- HH.forAllWith describeField genSomeField+  SomeField newField <- HH.forAllWith describeField genSomeField++  let+    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"+  PgAssert.assertColumnDefaultMatches originalTableDesc "column" (Orville.fieldDefaultValue originalField)++  secondTimePlan <-+    HH.evalIO $+      Orville.runOrville pool $ do+        AutoMigration.executeMigrationPlan AutoMigration.defaultOptions firstTimePlan+        AutoMigration.generateMigrationPlan AutoMigration.defaultOptions [AutoMigration.SchemaTable newTableDef]++  newTableDesc <- PgAssert.assertTableExists pool "migration_test"+  PgAssert.assertColumnDefaultMatches newTableDesc "column" (Orville.fieldDefaultValue newField)+  migrationPlanStepStrings secondTimePlan === []++prop_addAndRemovesUniqueConstraints :: Property.NamedDBProperty+prop_addAndRemovesUniqueConstraints =+  Property.namedDBProperty "Adds and removes unique constraints" $ \pool -> do+    let+      genColumnList =+        Gen.subsequence ["foo", "bar", "baz", "bat", "bax"]++      genConstraintColumns :: [String] -> HH.Gen [NEL.NonEmpty String]+      genConstraintColumns columns =+        fmap Maybe.catMaybes $+          Gen.list (Range.linear 0 10) $ do+            subcolumns <- Gen.subsequence columns+            NEL.nonEmpty <$> Gen.shuffle subcolumns++    originalColumns <- HH.forAll genColumnList+    originalConstraintColumns <- HH.forAll $ genConstraintColumns originalColumns+    newColumns <- HH.forAll genColumnList+    newConstraintColumns <- HH.forAll $ genConstraintColumns newColumns++    let+      columnsToDrop =+        originalColumns \\ newColumns++      originalConstraints =+        fmap mkUniqueConstraint originalConstraintColumns++      newConstraints =+        fmap mkUniqueConstraint newConstraintColumns++      originalTableDef =+        Orville.addTableConstraints originalConstraints $+          mkIntListTable "migration_test" originalColumns++      newTableDef =+        Orville.addTableConstraints newConstraints $+          Orville.dropColumns columnsToDrop $+            mkIntListTable "migration_test" newColumns++    HH.cover 5 (String.fromString "Adding Constraints") (not $ null (newConstraintColumns \\ originalConstraintColumns))+    HH.cover 5 (String.fromString "Dropping Constraints") (not $ null (originalConstraintColumns \\ newConstraintColumns))++    firstTimePlan <-+      HH.evalIO $+        Orville.runOrville pool $ do+          Orville.executeVoid Orville.DDLQuery $ TestTable.dropTableDefSql originalTableDef+          AutoMigration.autoMigrateSchema AutoMigration.defaultOptions [AutoMigration.SchemaTable originalTableDef]+          AutoMigration.generateMigrationPlan AutoMigration.defaultOptions [AutoMigration.SchemaTable newTableDef]++    HH.annotate ("First time migration steps: " <> show (migrationPlanStepStrings firstTimePlan))++    secondTimePlan <-+      HH.evalIO $+        Orville.runOrville pool $ do+          AutoMigration.executeMigrationPlan AutoMigration.defaultOptions firstTimePlan+          AutoMigration.generateMigrationPlan AutoMigration.defaultOptions [AutoMigration.SchemaTable newTableDef]++    migrationPlanStepStrings secondTimePlan === []+    tableDesc <- PgAssert.assertTableExists pool "migration_test"++    Fold.traverse_ (PgAssert.assertUniqueConstraintExists tableDesc) newConstraintColumns+    length (PgCatalog.relationConstraints tableDesc) === length (List.nub newConstraintColumns)++prop_addAndRemovesForeignKeyConstraints :: Property.NamedDBProperty+prop_addAndRemovesForeignKeyConstraints =+  Property.namedDBProperty "Adds and removes foreign key constraints" $ \pool -> do+    let+      genColumnList =+        Gen.subsequence ["foo", "bar", "baz", "bat", "bax"]++    localColumns <- HH.forAll genColumnList+    foreignColumns <- HH.forAll genColumnList++    let+      genForeignKeyInfos :: HH.Gen [PgAssert.ForeignKeyInfo]+      genForeignKeyInfos =+        fmap Maybe.catMaybes $+          Gen.list (Range.linear 0 10) $ do+            shuffledLocal <- Gen.shuffle localColumns+            shuffledForeign <- Gen.shuffle foreignColumns++            references <- Gen.subsequence (zip shuffledLocal shuffledForeign)+            onUpdateAction <- generateForeignKeyAction+            onDeleteAction <- generateForeignKeyAction++            pure $+              PgAssert.ForeignKeyInfo+                <$> NEL.nonEmpty references+                <*> Just onUpdateAction+                <*> Just onDeleteAction++    originalForeignKeyInfos <- HH.forAll genForeignKeyInfos+    newForeignKeyInfos <- HH.forAll genForeignKeyInfos++    -- We sort the columns in the unique constraints here to avoid edge cases+    -- with equivalent unique constraints in a different order. In these+    -- situations PostgreSQL can end up creating foreign keys that depending on+    -- indexes with a different ordering than the foreign key, which this test+    -- would then assume can be dropped even though it cannot. Standardizing+    -- the order of the columns in the unique constraints ensures this test+    -- will not try to drop a constraint that is used in both the original and+    -- new schemas while a foreign key is dropped and a new one added.+    let+      originalUniqueConstraints =+        fmap+          (mkUniqueConstraint . NEL.sort . fmap snd . PgAssert.foreignKeyInfoReferences)+          originalForeignKeyInfos++      newUniqueConstraints =+        fmap+          (mkUniqueConstraint . NEL.sort . fmap snd . PgAssert.foreignKeyInfoReferences)+          newForeignKeyInfos++      originalForeignKeyConstraints =+        fmap (mkForeignKeyConstraint "migration_test_foreign") originalForeignKeyInfos++      newForeignKeyConstraints =+        fmap (mkForeignKeyConstraint "migration_test_foreign") newForeignKeyInfos++      originalLocalTableDef =+        Orville.addTableConstraints originalForeignKeyConstraints $+          mkIntListTable "migration_test" localColumns++      newLocalTableDef =+        Orville.addTableConstraints newForeignKeyConstraints $+          mkIntListTable "migration_test" localColumns++      originalForeignTableDef =+        Orville.addTableConstraints originalUniqueConstraints $+          mkIntListTable "migration_test_foreign" foreignColumns++      newForeignTableDef =+        Orville.addTableConstraints newUniqueConstraints $+          mkIntListTable "migration_test_foreign" foreignColumns++    originalSchema <-+      HH.forAllWith (show . map AutoMigration.schemaItemSummary) $+        Gen.shuffle+          [ AutoMigration.SchemaTable originalForeignTableDef+          , AutoMigration.SchemaTable originalLocalTableDef+          ]++    newSchema <-+      HH.forAllWith (show . map AutoMigration.schemaItemSummary) $+        Gen.shuffle+          [ AutoMigration.SchemaTable newForeignTableDef+          , AutoMigration.SchemaTable newLocalTableDef+          ]++    HH.cover 5 (String.fromString "Adding Constraints") (not $ null (newForeignKeyInfos \\ originalForeignKeyInfos))+    HH.cover 5 (String.fromString "Dropping Constraints") (not $ null (originalForeignKeyInfos \\ newForeignKeyInfos))++    firstTimePlan <-+      HH.evalIO $+        Orville.runOrville pool $ do+          Orville.executeVoid Orville.DDLQuery $ TestTable.dropTableDefSql originalLocalTableDef+          Orville.executeVoid Orville.DDLQuery $ TestTable.dropTableDefSql originalForeignTableDef+          AutoMigration.autoMigrateSchema AutoMigration.defaultOptions originalSchema+          AutoMigration.generateMigrationPlan AutoMigration.defaultOptions newSchema++    HH.annotate ("First time migration steps: " <> show (migrationPlanStepStrings firstTimePlan))++    secondTimePlan <-+      HH.evalIO $+        Orville.runOrville pool $ do+          AutoMigration.executeMigrationPlan AutoMigration.defaultOptions firstTimePlan+          AutoMigration.generateMigrationPlan AutoMigration.defaultOptions newSchema++    HH.annotate ("Second time migration steps: " <> show (migrationPlanStepStrings secondTimePlan))++    migrationPlanStepStrings secondTimePlan === []+    tableDesc <- PgAssert.assertTableExists pool "migration_test"+    Fold.traverse_ (PgAssert.assertForeignKeyConstraintExists tableDesc) newForeignKeyInfos+    length (PgCatalog.relationConstraints tableDesc) === length (List.nub newForeignKeyInfos)++prop_addsAndRemovesMixedIndexes :: Property.NamedDBProperty+prop_addsAndRemovesMixedIndexes =+  Property.namedDBProperty "Adds and removes named indexes" $ \pool -> do+    let+      genColumnList =+        Gen.subsequence ["foo", "bar", "baz", "bat", "bax"]++    originalColumns <- HH.forAll genColumnList+    originalTestIndexes <- HH.forAll $ generateTestIndexes originalColumns "migration_test"+    newColumns <- HH.forAll genColumnList+    newTestIndexes <- HH.forAll $ generateTestIndexes newColumns "migration_test"++    let+      columnsToDrop =+        originalColumns \\ newColumns++      originalIndexes =+        fmap mkIndexDefinition originalTestIndexes++      newIndexes =+        fmap mkIndexDefinition newTestIndexes++      originalTableDef =+        Orville.addTableIndexes originalIndexes $+          mkIntListTable "migration_test" originalColumns++      newTableDef =+        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+      5+      (String.fromString "Concurrent Indexes")+      ( any+          (\i -> testIndexCreationStrategy i == Orville.Concurrent)+          (originalTestIndexes <> newTestIndexes)+      )++    firstTimePlan <-+      HH.evalIO $+        Orville.runOrville pool $ do+          Orville.executeVoid Orville.DDLQuery $ TestTable.dropTableDefSql originalTableDef+          AutoMigration.autoMigrateSchema AutoMigration.defaultOptions [AutoMigration.SchemaTable originalTableDef]+          AutoMigration.generateMigrationPlan AutoMigration.defaultOptions [AutoMigration.SchemaTable newTableDef]++    HH.annotate ("First time migration steps: " <> show (migrationPlanStepStrings firstTimePlan))++    originalTableDesc <- PgAssert.assertTableExists pool "migration_test"+    Fold.traverse_+      (PgAssert.assertIndexExists originalTableDesc <$> testIndexUniqueness <*> testIndexColumns)+      originalTestIndexes++    secondTimePlan <-+      HH.evalIO $+        Orville.runOrville pool $ do+          AutoMigration.executeMigrationPlan AutoMigration.defaultOptions firstTimePlan+          AutoMigration.generateMigrationPlan AutoMigration.defaultOptions [AutoMigration.SchemaTable newTableDef]++    migrationPlanStepStrings secondTimePlan === []+    newTableDesc <- PgAssert.assertTableExists pool "migration_test"++    Fold.traverse_+      (PgAssert.assertIndexExists newTableDesc <$> testIndexUniqueness <*> testIndexColumns)+      newTestIndexes+    length (PgCatalog.relationIndexes newTableDesc) === length (List.nub newTestIndexes)++prop_createsMissingSequences :: Property.NamedDBProperty+prop_createsMissingSequences =+  Property.singletonNamedDBProperty "Creates missing sequences" $ \pool -> do+    let+      sequenceDef =+        Orville.mkSequenceDefinition "migration_test_sequence"+      sequenceId =+        Orville.sequenceIdentifier sequenceDef++    firstTimePlan <-+      HH.evalIO $+        Orville.runOrville pool $ do+          Orville.executeVoid Orville.DDLQuery $ Expr.dropSequenceExpr (Just Expr.ifExists) (Orville.sequenceName sequenceDef)+          AutoMigration.generateMigrationPlan AutoMigration.defaultOptions [AutoMigration.SchemaSequence sequenceDef]++    secondTimePlan <-+      HH.evalIO $+        Orville.runOrville pool $ do+          AutoMigration.executeMigrationPlan AutoMigration.defaultOptions firstTimePlan+          AutoMigration.generateMigrationPlan AutoMigration.defaultOptions [AutoMigration.SchemaSequence sequenceDef]++    length (AutoMigration.migrationPlanSteps firstTimePlan) === 1+    _ <-+      PgAssert.assertSequenceExists+        pool+        (Orville.sequenceIdUnqualifiedNameString sequenceId)+    migrationPlanStepStrings secondTimePlan === []++prop_dropsRequestedSequences :: Property.NamedDBProperty+prop_dropsRequestedSequences =+  Property.singletonNamedDBProperty "Drops requested tables" $ \pool -> do+    let+      sequenceDef =+        Orville.mkSequenceDefinition "migration_test_sequence"+      sequenceId =+        Orville.sequenceIdentifier sequenceDef++    firstTimePlan <-+      HH.evalIO $+        Orville.runOrville pool $ do+          Orville.executeVoid Orville.DDLQuery $ Expr.dropSequenceExpr (Just Expr.ifExists) (Orville.sequenceName sequenceDef)+          Orville.executeVoid Orville.DDLQuery $ Orville.mkCreateSequenceExpr sequenceDef+          AutoMigration.generateMigrationPlan AutoMigration.defaultOptions [AutoMigration.SchemaDropSequence sequenceId]++    secondTimePlan <-+      HH.evalIO $+        Orville.runOrville pool $ do+          AutoMigration.executeMigrationPlan AutoMigration.defaultOptions firstTimePlan+          AutoMigration.generateMigrationPlan AutoMigration.defaultOptions [AutoMigration.SchemaDropSequence sequenceId]++    length (AutoMigration.migrationPlanSteps firstTimePlan) === 1+    PgAssert.assertSequenceDoesNotExist pool (Orville.sequenceIdUnqualifiedNameString sequenceId)+    migrationPlanStepStrings secondTimePlan === []++prop_altersModifiedSequences :: Property.NamedDBProperty+prop_altersModifiedSequences =+  Property.namedDBProperty "Alters modified sequences" $ \pool -> do+    let+      baseSequenceDef =+        Orville.mkSequenceDefinition "migration_test_sequence"+      generateIncrement =+        Gen.choice+          [ Gen.int64 (Range.linearFrom 1 1 maxBound)+          , Gen.int64 (Range.linearFrom (-1) minBound (-1))+          ]++    originalSequenceDef <- HH.forAll $ do+      increment <- generateIncrement+      minValue <- Gen.int64 (Range.linearFrom 0 minBound (maxBound - 1))+      maxValue <- Gen.int64 (Range.linear (minValue + 1) maxBound)+      start <- Gen.int64 (Range.linear minValue maxValue)+      cache <- Gen.int64 (Range.linear 1 maxBound)+      cycleFlag <- Gen.bool+      pure+        . Orville.setSequenceIncrement increment+        . Orville.setSequenceMinValue minValue+        . Orville.setSequenceMaxValue maxValue+        . Orville.setSequenceStart start+        . Orville.setSequenceCache cache+        . Orville.setSequenceCycle cycleFlag+        $ baseSequenceDef++    newSequenceDef <- HH.forAll $ do+      mbNewIncrement <- Gen.maybe generateIncrement+      -- The range between min and max values must contain the current next+      -- value of the sequence for PostgreSQL to not raise an error. Because+      -- no value has been fetched from our test sequence, that value is+      -- the start value from the original sequence definition+      mbNewMinValue <- Gen.maybe $ Gen.int64 (Range.linear minBound (Orville.sequenceStart originalSequenceDef))+      mbNewMaxValue <- Gen.maybe $ Gen.int64 (Range.linear (Orville.sequenceStart originalSequenceDef + 1) maxBound)++      -- The new start value must lie in the new range of the sequence. If no+      -- changes are being made to these values then the will remain the same as+      -- in the original sequence+      let+        newMinValue = Maybe.fromMaybe (Orville.sequenceMinValue originalSequenceDef) mbNewMinValue+        newMaxValue = Maybe.fromMaybe (Orville.sequenceMaxValue originalSequenceDef) mbNewMaxValue+      mbNewStart <- Gen.maybe $ Gen.int64 (Range.linear newMinValue newMaxValue)+      mbNewCache <- Gen.maybe $ Gen.int64 (Range.linear 1 maxBound)+      mbNewCycleFlag <- Gen.maybe Gen.bool+      pure+        . maybe id Orville.setSequenceIncrement mbNewIncrement+        . maybe id Orville.setSequenceMinValue mbNewMinValue+        . maybe id Orville.setSequenceMaxValue mbNewMaxValue+        . maybe id Orville.setSequenceStart mbNewStart+        . maybe id Orville.setSequenceCache mbNewCache+        . maybe id Orville.setSequenceCycle mbNewCycleFlag+        $ originalSequenceDef++    firstTimePlan <-+      HH.evalIO $+        Orville.runOrville pool $ do+          Orville.executeVoid Orville.DDLQuery $ Expr.dropSequenceExpr (Just Expr.ifExists) (Orville.sequenceName originalSequenceDef)+          AutoMigration.generateMigrationPlan AutoMigration.defaultOptions [AutoMigration.SchemaSequence originalSequenceDef]++    HH.annotate ("First time steps: " <> show (migrationPlanStepStrings firstTimePlan))+    length (AutoMigration.migrationPlanSteps firstTimePlan) === 1++    secondTimePlan <-+      HH.evalIO $+        Orville.runOrville pool $ do+          AutoMigration.executeMigrationPlan AutoMigration.defaultOptions firstTimePlan+          AutoMigration.generateMigrationPlan AutoMigration.defaultOptions [AutoMigration.SchemaSequence newSequenceDef]++    HH.annotate ("Second time steps: " <> show (migrationPlanStepStrings secondTimePlan))+    assertSequenceExistsMatching pool originalSequenceDef++    thirdTimePlan <-+      HH.evalIO $+        Orville.runOrville pool $ do+          AutoMigration.executeMigrationPlan AutoMigration.defaultOptions secondTimePlan+          AutoMigration.generateMigrationPlan AutoMigration.defaultOptions [AutoMigration.SchemaSequence newSequenceDef]++    assertSequenceExistsMatching pool newSequenceDef+    migrationPlanStepStrings thirdTimePlan === []++assertSequenceExistsMatching ::+  (HH.MonadTest m, MIO.MonadIO m) =>+  Orville.ConnectionPool ->+  Orville.SequenceDefinition ->+  m ()+assertSequenceExistsMatching pool sequenceDef = do+  sequenceRelation <-+    PgAssert.assertSequenceExists+      pool+      (Orville.sequenceIdUnqualifiedNameString . Orville.sequenceIdentifier $ sequenceDef)+  pgSequence <- PgAssert.assertRelationHasPgSequence sequenceRelation+  PgCatalog.pgSequenceIncrement pgSequence === Orville.sequenceIncrement sequenceDef+  PgCatalog.pgSequenceStart pgSequence === Orville.sequenceStart sequenceDef+  PgCatalog.pgSequenceMin pgSequence === Orville.sequenceMinValue sequenceDef+  PgCatalog.pgSequenceMax pgSequence === Orville.sequenceMaxValue sequenceDef+  PgCatalog.pgSequenceCache pgSequence === Orville.sequenceCache sequenceDef+  PgCatalog.pgSequenceCycle pgSequence === Orville.sequenceCycle sequenceDef++prop_arbitrarySchemaInitialMigration :: Property.NamedDBProperty+prop_arbitrarySchemaInitialMigration =+  Property.namedDBProperty "An arbitrary list of schema items can be created from scratch" $ \pool -> do+    testTables <- HH.forAll $ generateTestTables (Range.constant 0 10)++    HH.cover 75 (String.fromString "With Tables") (not . null $ testTables)+    HH.cover 75 (String.fromString "With Columns") (not . null $ concatMap testTableColumns testTables)+    HH.cover 50 (String.fromString "With Indexes") (not . null $ concatMap testTableIndexes testTables)+    HH.cover 50 (String.fromString "With Unique Constraints") (not . null $ concatMap testTableUniqueConstraints testTables)+    HH.cover 30 (String.fromString "With Foreign Keys") (not . null $ concatMap testTableForeignKeys testTables)++    let+      testSchema =+        map testTableSchemaItem testTables++    initialMigrationPlan <-+      HH.evalIO $+        Orville.runOrville pool $ do+          Orville.executeVoid Orville.DDLQuery $ RawSql.fromString "DROP SCHEMA IF EXISTS orville_migration_test CASCADE"+          Orville.executeVoid Orville.DDLQuery $ RawSql.fromString "CREATE SCHEMA orville_migration_test"+          AutoMigration.generateMigrationPlan AutoMigration.defaultOptions testSchema++    HH.annotate ("Initial migration steps: " <> show (migrationPlanStepStrings initialMigrationPlan))++    migrationPlanAfterMigration <-+      HH.evalIO $+        Orville.runOrville pool $ do+          AutoMigration.executeMigrationPlan AutoMigration.defaultOptions initialMigrationPlan+          AutoMigration.generateMigrationPlan AutoMigration.defaultOptions testSchema++    migrationPlanStepStrings migrationPlanAfterMigration === []+    Fold.traverse_ (assertTableStructure pool) testTables++assertTableStructure ::+  (HH.MonadTest m, MIO.MonadIO m) =>+  Orville.ConnectionPool ->+  TestTable ->+  m ()+assertTableStructure pool testTable = do+  tableDesc <- PgAssert.assertTableExistsInSchema pool "orville_migration_test" (testTableName testTable)++  PgAssert.assertColumnNamesEqual+    tableDesc+    (testTableColumns testTable)++  Fold.traverse_+    (PgAssert.assertIndexExists tableDesc <$> testIndexUniqueness <*> testIndexColumns)+    (testTableIndexes testTable)++  Fold.traverse_+    (PgAssert.assertUniqueConstraintExists tableDesc)+    (testTableUniqueConstraints testTable)++  Fold.traverse_+    (PgAssert.assertForeignKeyConstraintExists tableDesc)+    (map mkForeignKeyInfo . testTableForeignKeys $ testTable)++mkForeignKeyInfo :: TestForeignKey -> PgAssert.ForeignKeyInfo+mkForeignKeyInfo testForeignKey =+  PgAssert.ForeignKeyInfo+    { PgAssert.foreignKeyInfoReferences = testForeignKeyReferences testForeignKey+    , PgAssert.foreignKeyInfoOnUpdate = testForeignKeyOnUpdate testForeignKey+    , PgAssert.foreignKeyInfoOnDelete = testForeignKeyOnDelete testForeignKey+    }++data TestTable = TestTable+  { testTableName :: String+  , testTableColumns :: [String]+  , testTablePrimaryKey :: [String]+  , testTableIndexes :: [TestIndex]+  , testTableUniqueConstraints :: [NEL.NonEmpty String]+  , testTableForeignKeys :: [TestForeignKey]+  }+  deriving (Show)++data TestIndex = TestIndex+  { testIndexName :: Maybe String+  , testIndexUniqueness :: Orville.IndexUniqueness+  , testIndexCreationStrategy :: Orville.IndexCreationStrategy+  , testIndexColumns :: NEL.NonEmpty String+  }+  deriving (Show, Eq)++data TestForeignKey = TestForeignKey+  { testForeignKeyReferences :: NEL.NonEmpty (String, String)+  , testForeignKeyTableName :: String+  , testForeignKeyOnUpdate :: Orville.ForeignKeyAction+  , testForeignKeyOnDelete :: Orville.ForeignKeyAction+  }+  deriving (Show)++data TestForeignKeyTarget = TestForeignKeyTarget+  { testForeignKeyTargetTableName :: String+  , testForeignKeyTargetColumns :: NEL.NonEmpty String+  }+  deriving (Show)++testTableForeignKeyTargets :: TestTable -> [TestForeignKeyTarget]+testTableForeignKeyTargets testTable =+  map+    (TestForeignKeyTarget $ testTableName testTable)+    (testTableUniqueConstraints testTable)++mkIndexDefinition :: TestIndex -> Orville.IndexDefinition+mkIndexDefinition testIndex =+  let+    strategy =+      testIndexCreationStrategy testIndex++    baseIndex =+      case testIndexName testIndex of+        Just name ->+          -- If the test index has a name, use it to test Orville's support for+          -- custome named indexes+          let+            indexBody =+              Expr.indexBodyColumns+                . fmap Expr.columnName+                . testIndexColumns+                $ testIndex+          in+            Orville.mkNamedIndexDefinition+              (testIndexUniqueness testIndex)+              name+              indexBody+        Nothing ->+          -- If the test index has no name, use it to test Orville's support for+          -- unnamed indexes+          Orville.mkIndexDefinition+            (testIndexUniqueness testIndex)+            (Orville.stringToFieldName <$> testIndexColumns testIndex)+  in+    Orville.setIndexCreationStrategy strategy baseIndex++generateTestTable :: HH.Gen TestTable+generateTestTable = do+  columns <- generateTestTableColumns++  tableName <- PgGen.pgIdentifierWithPrefix "t_" 1++  TestTable tableName+    <$> pure columns+    <*> Gen.subsequence columns+    <*> generateTestIndexes columns tableName+    <*> generateTestUniqueConstraints columns+    <*> pure [] -- No foreign keys can be generated until we've generate test tables++generateTestTables :: HH.Range Int -> HH.Gen [TestTable]+generateTestTables tableCountRange = do+  tablesWithoutForeignKeys <-+    fmap+      (List.nubBy (Function.on (==) testTableName))+      (Gen.list tableCountRange generateTestTable)++  let+    foreignKeyTargets =+      concatMap testTableForeignKeyTargets tablesWithoutForeignKeys++  traverse+    (addTestTableForeignKeys foreignKeyTargets)+    tablesWithoutForeignKeys++addTestTableForeignKeys ::+  [TestForeignKeyTarget] ->+  TestTable ->+  HH.Gen TestTable+addTestTableForeignKeys targets table = do+  let+    targetColumnCount =+      length . testForeignKeyTargetColumns++    possibleTargets =+      filter+        (\t -> targetColumnCount t <= length (testTableColumns table))+        targets++    genForeignKey target = do+      let+        targetColumns = testForeignKeyTargetColumns target++      sourceColumns <-+        -- nonEmpty can never produce a 'Nothing' here because the target's+        -- columns are a non-empty list.+        Gen.mapMaybe+          NEL.nonEmpty+          (take (targetColumnCount target) <$> Gen.shuffle (testTableColumns table))++      onUpdateAction <- generateForeignKeyAction+      onDeleteAction <- generateForeignKeyAction++      pure $+        TestForeignKey+          { testForeignKeyReferences = NEL.zip sourceColumns targetColumns+          , testForeignKeyTableName = testForeignKeyTargetTableName target+          , testForeignKeyOnUpdate = onUpdateAction+          , testForeignKeyOnDelete = onDeleteAction+          }++  chosenTargets <-+    case possibleTargets of+      [] -> pure []+      _ -> Gen.list (Range.linear 0 2) (Gen.element possibleTargets)++  foreignKeys <- traverse genForeignKey chosenTargets++  pure $ table {testTableForeignKeys = foreignKeys}++generateForeignKeyAction :: HH.Gen Orville.ForeignKeyAction+generateForeignKeyAction =+  Gen.element+    [ Orville.NoAction+    , Orville.Restrict+    , Orville.Cascade+    , Orville.SetNull+    , Orville.SetDefault+    ]++generateTestIndexes :: [String] -> String -> HH.Gen [TestIndex]+generateTestIndexes columns tableName = do+  testIndices <- fmap Maybe.catMaybes $+    Gen.list (Range.linear 0 10) $ do+      -- The use of `take 8` is to avoid creating a prefix that would be truncated+      -- but is also long enough to avoid collision when generating indexes for+      -- an arbitrary amount of tables+      indexName <- Gen.maybe $ PgGen.pgIdentifierWithPrefix ((take 8 tableName) <> "i_") 3+      subcolumns <- Gen.subsequence columns+      maybeNonEmptyColumns <- NEL.nonEmpty <$> Gen.shuffle subcolumns+      uniqueness <- Gen.element [Orville.UniqueIndex, Orville.NonUniqueIndex]+      strategy <-+        Gen.frequency+          [ (10, pure Orville.Transactional)+          , (1, pure Orville.Concurrent)+          ]+      pure $ fmap (TestIndex indexName uniqueness strategy) maybeNonEmptyColumns++  pure $ (List.nubBy (Function.on (==) testIndexColumns)) testIndices++generateTestUniqueConstraints :: [String] -> HH.Gen [NEL.NonEmpty String]+generateTestUniqueConstraints columns =+  fmap Maybe.catMaybes $+    Gen.list+      (Range.linear 0 5)+      (NEL.nonEmpty <$> Gen.subsequence columns)++testTableSchemaItem :: TestTable -> AutoMigration.SchemaItem+testTableSchemaItem testTable =+  let+    addTableItems ::+      Orville.TableDefinition key writeEntity readEntity ->+      Orville.TableDefinition key writeEntity readEntity+    addTableItems tableDef =+      Orville.addTableConstraints (testTableForeignKeyDefinition <$> testTableForeignKeys testTable)+        . Orville.addTableConstraints (mkUniqueConstraint <$> testTableUniqueConstraints testTable)+        . Orville.addTableIndexes (mkIndexDefinition <$> testTableIndexes testTable)+        . Orville.setTableSchema "orville_migration_test"+        $ tableDef+  in+    case testTablePrimaryKeyDefinition testTable of+      Nothing ->+        AutoMigration.SchemaTable $+          addTableItems $+            Orville.mkTableDefinitionWithoutKey+              (testTableName testTable)+              (intColumnsMarshaller $ testTableColumns testTable)+      Just primaryKey ->+        AutoMigration.SchemaTable $+          addTableItems $+            Orville.mkTableDefinition+              (testTableName testTable)+              primaryKey+              (intColumnsMarshaller $ testTableColumns testTable)++testTablePrimaryKeyDefinition :: TestTable -> Maybe (Orville.PrimaryKey [Int32])+testTablePrimaryKeyDefinition testTable =+  let+    mkPart (index, column) =+      Orville.primaryKeyPart (!! index) (Orville.integerField column)+  in+    case zip [1 ..] (testTablePrimaryKey testTable) of+      [] ->+        Nothing+      (first : rest) ->+        Just $+          Orville.compositePrimaryKey+            (mkPart first)+            (fmap mkPart rest)++testTableForeignKeyDefinition :: TestForeignKey -> Orville.ConstraintDefinition+testTableForeignKeyDefinition foreignKey =+  let+    mkForeignReference (localColumn, foreignColumn) =+      Orville.foreignReference+        (Orville.stringToFieldName localColumn)+        (Orville.stringToFieldName foreignColumn)++    foreignTableId =+      Orville.setTableIdSchema "orville_migration_test"+        . Orville.unqualifiedNameToTableId+        . testForeignKeyTableName+        $ foreignKey+  in+    Orville.foreignKeyConstraintWithOptions+      foreignTableId+      (fmap mkForeignReference $ testForeignKeyReferences foreignKey)+      ( Orville.defaultForeignKeyOptions+          { Orville.foreignKeyOptionsOnUpdate = testForeignKeyOnUpdate foreignKey+          , Orville.foreignKeyOptionsOnDelete = testForeignKeyOnDelete foreignKey+          }+      )++generateTestTableColumns :: HH.Gen [String]+generateTestTableColumns =+  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)++intColumnsMarshaller :: [String] -> Orville.SqlMarshaller [Int32] [Int32]+intColumnsMarshaller columns =+  let+    field (idx, column) =+      Orville.marshallField (!! idx) $ Orville.integerField column+  in+    traverse field (zip [0 ..] columns)++mkUniqueConstraint :: NEL.NonEmpty String -> Orville.ConstraintDefinition+mkUniqueConstraint columnList =+  Orville.uniqueConstraint (fmap Orville.stringToFieldName columnList)++mkForeignKeyConstraint :: String -> PgAssert.ForeignKeyInfo -> Orville.ConstraintDefinition+mkForeignKeyConstraint foreignTableName foreignKeyInfo =+  let+    mkForeignReference (localColumn, foreignColumn) =+      Orville.foreignReference+        (Orville.stringToFieldName localColumn)+        (Orville.stringToFieldName foreignColumn)+  in+    Orville.foreignKeyConstraintWithOptions+      (Orville.unqualifiedNameToTableId foreignTableName)+      (fmap mkForeignReference $ PgAssert.foreignKeyInfoReferences foreignKeyInfo)+      ( Orville.defaultForeignKeyOptions+          { Orville.foreignKeyOptionsOnUpdate = PgAssert.foreignKeyInfoOnUpdate foreignKeyInfo+          , Orville.foreignKeyOptionsOnDelete = PgAssert.foreignKeyInfoOnDelete foreignKeyInfo+          }+      )++migrationPlanStepStrings :: AutoMigration.MigrationPlan -> [B8.ByteString]+migrationPlanStepStrings =+  fmap RawSql.toExampleBytes . AutoMigration.migrationPlanSteps
+ test/Test/Connection.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Test.Connection+  ( connectionTests+  )+where++import qualified Control.Exception as E+import qualified Control.Monad.IO.Class as MIO+import qualified Data.ByteString.Char8 as B8+import qualified Data.Text.Encoding as Enc+import qualified Database.PostgreSQL.LibPQ as LibPQ+import Hedgehog ((===))+import qualified Hedgehog as HH+import qualified Hedgehog.Range as Range++import qualified Orville.PostgreSQL.Raw.Connection as Conn+import qualified Orville.PostgreSQL.Raw.PgTextFormatValue as PgTextFormatValue++import qualified Test.PgGen as PgGen+import qualified Test.Property as Property++connectionTests :: Conn.ConnectionPool -> Property.Group+connectionTests pool =+  Property.Group "Connection" $+    [ prop_safeOrUnsafeNonNullBytes pool+    , prop_errorOnSafeNulByte pool+    , prop_truncateValuesAtUnsafeNulByte pool+    , prop_errorOnInvalidSql pool+    ]++prop_safeOrUnsafeNonNullBytes :: Property.NamedDBProperty+prop_safeOrUnsafeNonNullBytes =+  Property.namedDBProperty "executeRaw can pass non-null bytes equivalents whether checked for NUL or not" $ \pool -> do+    text <- HH.forAll $ PgGen.pgText (Range.linear 0 256)++    let+      notNulBytes =+        Enc.encodeUtf8 text++    value <-+      MIO.liftIO . Conn.withPoolConnection pool $ \connection -> do+        result <-+          Conn.executeRaw+            connection+            (B8.pack "SELECT $1::text = $2::text")+            [ Just $ PgTextFormatValue.fromByteString notNulBytes+            , Just $ PgTextFormatValue.unsafeFromByteString notNulBytes+            ]++        LibPQ.getvalue' result 0 0++    value === Just (B8.pack "t")++prop_errorOnSafeNulByte :: Property.NamedDBProperty+prop_errorOnSafeNulByte =+  Property.namedDBProperty "executeRaw returns error if nul byte is given using safe constructor" $ \pool -> do+    textBefore <- HH.forAll $ PgGen.pgText (Range.linear 0 32)+    textAfter <- HH.forAll $ PgGen.pgText (Range.linear 0 32)++    let+      bytesWithNul =+        B8.concat+          [ Enc.encodeUtf8 textBefore+          , B8.pack "\NUL"+          , Enc.encodeUtf8 textAfter+          ]++    result <-+      MIO.liftIO . E.try . Conn.withPoolConnection pool $ \connection ->+        Conn.executeRaw+          connection+          (B8.pack "SELECT $1::text")+          [ Just $ PgTextFormatValue.fromByteString bytesWithNul+          ]++    case result of+      Left PgTextFormatValue.NULByteFoundError ->+        HH.success+      Right _ -> do+        HH.footnote "Expected 'executeRaw' to return failure, but it did not"+        HH.failure++prop_truncateValuesAtUnsafeNulByte :: Property.NamedDBProperty+prop_truncateValuesAtUnsafeNulByte =+  Property.namedDBProperty "executeRaw truncates values at the nul byte given using unsafe constructor" $ \pool -> do+    textBefore <- HH.forAll $ PgGen.pgText (Range.linear 0 32)+    textAfter <- HH.forAll $ PgGen.pgText (Range.linear 0 32)++    let+      bytesBefore =+        Enc.encodeUtf8 textBefore++      bytesWithNul =+        B8.concat+          [ bytesBefore+          , B8.pack "\NUL"+          , Enc.encodeUtf8 textAfter+          ]++    value <-+      MIO.liftIO . Conn.withPoolConnection pool $ \connection -> do+        result <-+          Conn.executeRaw+            connection+            (B8.pack "SELECT $1::text")+            [ Just $ PgTextFormatValue.unsafeFromByteString bytesWithNul+            ]++        LibPQ.getvalue' result 0 0++    value === Just bytesBefore++prop_errorOnInvalidSql :: Property.NamedDBProperty+prop_errorOnInvalidSql =+  -- Note: we only run this test once to cut down on the number of errors+  -- printed out by the database server when running tests repeatedly.+  Property.singletonNamedDBProperty "executeRaw returns error if invalid sql is given" $ \pool -> do+    -- We generate non-empty queries here becaues libpq returns different+    -- error details when an empty string is passed+    randomText <- HH.forAll $ PgGen.pgText (Range.constant 1 16)++    result <-+      MIO.liftIO . E.try . Conn.withPoolConnection pool $ \connection ->+        Conn.executeRaw+          connection+          (Enc.encodeUtf8 randomText)+          []++    case result of+      Left err -> do+        Conn.sqlExecutionErrorExecStatus err === Just LibPQ.FatalError++        let+          syntaxErrorState = B8.pack "42601"++        Conn.sqlExecutionErrorSqlState err === Just syntaxErrorState+      Right _ -> do+        HH.footnote "Expected 'executeRow' to return failure, but it did not"+        HH.failure
+ test/Test/Cursor.hs view
@@ -0,0 +1,83 @@+module Test.Cursor+  ( cursorTests+  )+where++import qualified Data.List as List+import qualified Data.List.NonEmpty as NEL+import qualified Data.Ord as Ord+import Hedgehog ((===))+import qualified Hedgehog as HH+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import qualified Orville.PostgreSQL as Orville+import qualified Orville.PostgreSQL.Execution as Exec++import qualified Test.Entities.Foo as Foo+import qualified Test.Property as Property++cursorTests :: Orville.ConnectionPool -> Property.Group+cursorTests pool =+  Property.group "Cursor" $+    [ prop_withCursorFetch pool+    , prop_withCursorMove pool+    ]++prop_withCursorFetch :: Property.NamedDBProperty+prop_withCursorFetch =+  Property.namedDBProperty "withCursor - fetch" $ \pool -> do+    foos <- HH.forAll (Foo.generateNonEmpty (Range.linear 1 20))+    -- A fetch count of 0 has the special meaning of "current row" in+    -- PostgreSQL so we avoid generating 0 for the fetch count in this test+    numToFetch <- HH.forAll (Gen.integral (Range.linear 1 (length foos)))++    let+      expectedRows =+        take numToFetch+          . List.sortBy (Ord.comparing Foo.fooId)+          . NEL.toList+          $ foos++    actualRows <-+      Foo.withTable pool $ do+        Orville.withTransaction $ do+          _ <- Orville.insertEntities Foo.table foos+          Exec.withCursor Nothing Nothing selectAllFoosOrderedById $ \cursor ->+            Exec.fetch (Just $ Exec.forwardCount numToFetch) cursor++    expectedRows === actualRows++prop_withCursorMove :: Property.NamedDBProperty+prop_withCursorMove =+  Property.namedDBProperty "withCursor - move" $ \pool -> do+    foos <- HH.forAll (Foo.generateNonEmpty (Range.linear 1 20))+    -- A fetch count of 0 has the special meaning of "current row" in+    -- PostgreSQL so we avoid generating any scenario that would give us a+    -- fetch count of 0 in this test+    numToSkip <- HH.forAll (Gen.integral (Range.linear 0 (length foos - 1)))+    numToFetch <- HH.forAll (Gen.integral (Range.linear 1 (length foos - numToSkip)))++    let+      expectedRows =+        take numToFetch+          . drop numToSkip+          . List.sortBy (Ord.comparing Foo.fooId)+          . NEL.toList+          $ foos++    actualRows <-+      Foo.withTable pool $ do+        Orville.withTransaction $ do+          _ <- Orville.insertEntities Foo.table foos+          Exec.withCursor Nothing Nothing selectAllFoosOrderedById $ \cursor -> do+            Exec.move (Just $ Exec.forwardCount numToSkip) cursor+            Exec.fetch (Just $ Exec.forwardCount numToFetch) cursor++    expectedRows === actualRows++selectAllFoosOrderedById :: Exec.Select Foo.Foo+selectAllFoosOrderedById =+  Exec.selectTable+    Foo.table+    (Orville.orderBy $ Orville.orderByField Foo.fooIdField Orville.ascendingOrder)
+ test/Test/Entities/Bar.hs view
@@ -0,0 +1,68 @@+module Test.Entities.Bar+  ( Bar (..)+  , table+  , generate+  , generateList+  , withTable+  , barIdField+  )+where++import Control.Monad.IO.Class (MonadIO (liftIO))+import Data.Int (Int32)+import qualified Data.Text as T+import qualified Hedgehog as HH+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import qualified Orville.PostgreSQL as Orville+import qualified Orville.PostgreSQL.Raw.Connection as Conn++import qualified Test.PgGen as PgGen+import qualified Test.TestTable as TestTable++type BarId = Int32+type BarName = T.Text++data Bar barId = Bar+  { barId :: barId+  , barName :: BarName+  }+  deriving (Eq, Show)++type BarWrite = Bar ()+type BarRead = Bar BarId++table :: Orville.TableDefinition (Orville.HasKey BarId) BarWrite BarRead+table =+  Orville.mkTableDefinition "bar" (Orville.primaryKey barIdField) barMarshaller++barMarshaller :: Orville.SqlMarshaller BarWrite BarRead+barMarshaller =+  Bar+    <$> Orville.marshallReadOnly (Orville.marshallField barId barIdField)+    <*> Orville.marshallField barName barNameField++barIdField :: Orville.FieldDefinition Orville.NotNull BarId+barIdField =+  Orville.serialField "id"++barNameField :: Orville.FieldDefinition Orville.NotNull BarName+barNameField =+  Orville.unboundedTextField "name"++generate :: HH.Gen BarWrite+generate =+  Bar ()+    <$> PgGen.pgText (Range.constant 0 10)++generateList :: HH.Range Int -> HH.Gen [BarWrite]+generateList range =+  (Gen.list range generate)++withTable :: MonadIO m => Orville.ConnectionPool -> Orville.Orville a -> m a+withTable pool operation =+  liftIO $ do+    Conn.withPoolConnection pool $ \connection ->+      TestTable.dropAndRecreateTableDef connection table+    Orville.runOrville pool operation
+ test/Test/Entities/CompositeKeyEntity.hs view
@@ -0,0 +1,121 @@+module Test.Entities.CompositeKeyEntity+  ( CompositeKey (..)+  , CompositeKeyEntity (..)+  , CompositeKeyEntityId+  , CompositeKeyEntityName+  , table+  , generate+  , generateCompositeKeyEntityId+  , generateCompositeKeyEntityName+  , generateNonEmpty+  , withTable+  , compositeKeyEntityIdField+  , compositeKeyEntityNameField+  , compositeKeyEntityAgeField+  )+where++import Control.Monad.IO.Class (MonadIO (liftIO))+import Data.Function (on)+import Data.Int (Int32)+import qualified Data.List.NonEmpty as NEL+import qualified Data.Text as T+import qualified Hedgehog as HH+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import qualified Orville.PostgreSQL as Orville+import qualified Orville.PostgreSQL.Raw.Connection as Conn++import qualified Test.PgGen as PgGen+import qualified Test.TestTable as TestTable++type CompositeKeyEntityId = Int32+type CompositeKeyEntityName = T.Text+type CompositeKeyEntityAge = Int32++data CompositeKey = CompositeKey+  { compositeKeyEntityId :: CompositeKeyEntityId+  , compositeKeyEntityName :: CompositeKeyEntityName+  }+  deriving (Eq, Ord, Show)++data CompositeKeyEntity = CompositeKeyEntity+  { compositeKey :: CompositeKey+  , compositeKeyEntityAge :: CompositeKeyEntityAge+  }+  deriving (Eq, Show)++table :: Orville.TableDefinition (Orville.HasKey CompositeKey) CompositeKeyEntity CompositeKeyEntity+table =+  Orville.mkTableDefinition "compositeKeyEntity" primaryKey compositeKeyEntityMarshaller++primaryKey :: Orville.PrimaryKey CompositeKey+primaryKey =+  Orville.compositePrimaryKey+    (Orville.primaryKeyPart compositeKeyEntityId compositeKeyEntityIdField)+    [Orville.primaryKeyPart compositeKeyEntityName compositeKeyEntityNameField]++compositeKeyEntityMarshaller :: Orville.SqlMarshaller CompositeKeyEntity CompositeKeyEntity+compositeKeyEntityMarshaller =+  CompositeKeyEntity+    <$> Orville.marshallNested compositeKey compositeKeyMap+    <*> Orville.marshallField compositeKeyEntityAge compositeKeyEntityAgeField++compositeKeyMap :: Orville.SqlMarshaller CompositeKey CompositeKey+compositeKeyMap =+  CompositeKey+    <$> Orville.marshallField compositeKeyEntityId compositeKeyEntityIdField+    <*> Orville.marshallField compositeKeyEntityName compositeKeyEntityNameField++compositeKeyEntityIdField :: Orville.FieldDefinition Orville.NotNull CompositeKeyEntityId+compositeKeyEntityIdField =+  Orville.integerField "id"++compositeKeyEntityNameField :: Orville.FieldDefinition Orville.NotNull CompositeKeyEntityName+compositeKeyEntityNameField =+  Orville.unboundedTextField "name"++compositeKeyEntityAgeField :: Orville.FieldDefinition Orville.NotNull CompositeKeyEntityAge+compositeKeyEntityAgeField =+  Orville.integerField "age"++generate :: HH.Gen CompositeKeyEntity+generate =+  CompositeKeyEntity+    <$> ( CompositeKey+            <$> generateCompositeKeyEntityId+            <*> generateCompositeKeyEntityName+        )+    <*> generateCompositeKeyEntityAge++generateCompositeKeyEntityId :: HH.Gen CompositeKeyEntityId+generateCompositeKeyEntityId =+  PgGen.pgInt32++generateCompositeKeyEntityName :: HH.Gen CompositeKeyEntityName+generateCompositeKeyEntityName =+  PgGen.pgText (Range.constant 0 10)++generateCompositeKeyEntityAge :: HH.Gen CompositeKeyEntityAge+generateCompositeKeyEntityAge =+  Gen.integral (Range.constant minCompositeKeyEntityAge maxCompositeKeyEntityAge)++minCompositeKeyEntityAge :: CompositeKeyEntityAge+minCompositeKeyEntityAge = 0++maxCompositeKeyEntityAge :: CompositeKeyEntityAge+maxCompositeKeyEntityAge = 50++generateNonEmpty :: HH.Range Int -> HH.Gen (NEL.NonEmpty CompositeKeyEntity)+generateNonEmpty range =+  fmap+    (NEL.nubBy ((==) `on` compositeKey))+    (Gen.nonEmpty range generate)++withTable :: MonadIO m => Orville.ConnectionPool -> Orville.Orville a -> m a+withTable pool operation =+  liftIO $ do+    Conn.withPoolConnection pool $ \connection ->+      TestTable.dropAndRecreateTableDef connection table+    Orville.runOrville pool operation
+ test/Test/Entities/Foo.hs view
@@ -0,0 +1,140 @@+module Test.Entities.Foo+  ( Foo (..)+  , FooId+  , FooName+  , table+  , generate+  , generateFooWithName+  , generateFooWithId+  , generateFooId+  , generateFooName+  , generateList+  , generateListUsing+  , generateNonEmpty+  , withTable+  , fooIdField+  , fooNameField+  , fooAgeField+  , hasName+  , averageFooAge+  )+where++import Control.Monad.IO.Class (MonadIO (liftIO))+import Data.Function (on)+import Data.Int (Int32)+import qualified Data.List as List+import qualified Data.List.NonEmpty as NEL+import qualified Data.Text as T+import qualified Hedgehog as HH+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import qualified Orville.PostgreSQL as Orville+import qualified Orville.PostgreSQL.Raw.Connection as Conn++import qualified Test.PgGen as PgGen+import qualified Test.TestTable as TestTable++type FooId = Int32+type FooName = T.Text+type FooAge = Int32++data Foo = Foo+  { fooId :: FooId+  , fooName :: FooName+  , fooAge :: FooAge+  }+  deriving (Eq, Show)++table :: Orville.TableDefinition (Orville.HasKey FooId) Foo Foo+table =+  Orville.mkTableDefinition "foo" (Orville.primaryKey fooIdField) fooMarshaller++fooMarshaller :: Orville.SqlMarshaller Foo Foo+fooMarshaller =+  Foo+    <$> Orville.marshallField fooId fooIdField+    <*> Orville.marshallField fooName fooNameField+    <*> Orville.marshallField fooAge fooAgeField++fooIdField :: Orville.FieldDefinition Orville.NotNull FooId+fooIdField =+  Orville.integerField "id"++fooNameField :: Orville.FieldDefinition Orville.NotNull FooName+fooNameField =+  Orville.unboundedTextField "name"++fooAgeField :: Orville.FieldDefinition Orville.NotNull FooAge+fooAgeField =+  Orville.integerField "age"++generate :: HH.Gen Foo+generate =+  Foo+    <$> generateFooId+    <*> generateFooName+    <*> generateFooAge++generateFooWithId :: FooId -> HH.Gen Foo+generateFooWithId knownId =+  Foo knownId+    <$> generateFooName+    <*> generateFooAge++generateFooWithName :: FooName -> HH.Gen Foo+generateFooWithName name =+  Foo+    <$> generateFooId+    <*> pure name+    <*> generateFooAge++generateFooId :: HH.Gen FooId+generateFooId =+  PgGen.pgInt32++generateFooName :: HH.Gen FooName+generateFooName =+  PgGen.pgText (Range.constant 0 10)++generateFooAge :: HH.Gen FooAge+generateFooAge =+  Gen.integral (Range.constant minFooAge maxFooAge)++minFooAge :: FooAge+minFooAge = 0++maxFooAge :: FooAge+maxFooAge = 50++averageFooAge :: FooAge+averageFooAge =+  div (minFooAge + maxFooAge) 2++hasName :: FooName -> Foo -> Bool+hasName name foo =+  fooName foo == name++generateList :: HH.Range Int -> HH.Gen [Foo]+generateList =+  flip generateListUsing generate++generateListUsing :: HH.Range Int -> HH.Gen Foo -> HH.Gen [Foo]+generateListUsing range generator =+  fmap+    (List.nubBy ((==) `on` fooId))+    (Gen.list range generator)++generateNonEmpty :: HH.Range Int -> HH.Gen (NEL.NonEmpty Foo)+generateNonEmpty range =+  fmap+    (NEL.nubBy ((==) `on` fooId))+    (Gen.nonEmpty range generate)++withTable :: MonadIO m => Orville.ConnectionPool -> Orville.Orville a -> m a+withTable pool operation =+  liftIO $ do+    Conn.withPoolConnection pool $ \connection ->+      TestTable.dropAndRecreateTableDef connection table+    Orville.runOrville pool operation
+ test/Test/Entities/FooChild.hs view
@@ -0,0 +1,75 @@+module Test.Entities.FooChild+  ( FooChild (..)+  , isChildOf+  , table+  , fooChildIdField+  , fooChildFooIdField+  , generate+  , generateList+  , withTables+  )+where++import Control.Monad.IO.Class (MonadIO (liftIO))+import Data.Function (on)+import Data.Int (Int32)+import qualified Data.List as List+import qualified Hedgehog as HH+import qualified Hedgehog.Gen as Gen++import qualified Orville.PostgreSQL as Orville+import qualified Orville.PostgreSQL.Raw.Connection as Conn++import qualified Test.Entities.Foo as Foo+import qualified Test.PgGen as PgGen+import qualified Test.TestTable as TestTable++type FooChildId = Int32++data FooChild = FooChild+  { fooChildId :: FooChildId+  , fooChildFooId :: Foo.FooId+  }+  deriving (Eq, Show)++isChildOf :: Foo.Foo -> FooChild -> Bool+isChildOf foo child =+  Foo.fooId foo == fooChildFooId child++table :: Orville.TableDefinition (Orville.HasKey FooChildId) FooChild FooChild+table =+  Orville.mkTableDefinition "foo_child" (Orville.primaryKey fooChildIdField) fooChildMarshaller++fooChildMarshaller :: Orville.SqlMarshaller FooChild FooChild+fooChildMarshaller =+  FooChild+    <$> Orville.marshallField fooChildId fooChildIdField+    <*> Orville.marshallField fooChildFooId fooChildFooIdField++fooChildIdField :: Orville.FieldDefinition Orville.NotNull FooChildId+fooChildIdField =+  Orville.integerField "id"++fooChildFooIdField :: Orville.FieldDefinition Orville.NotNull Foo.FooId+fooChildFooIdField =+  Orville.integerField "foo_id"++generate :: [Foo.Foo] -> HH.Gen FooChild+generate foos =+  FooChild+    <$> PgGen.pgInt32+    <*> Gen.element (Foo.fooId <$> foos)++generateList :: HH.Range Int -> [Foo.Foo] -> HH.Gen [FooChild]+generateList range foos =+  fmap+    (List.nubBy ((==) `on` fooChildId))+    (Gen.list range $ generate foos)++withTables :: MonadIO m => Orville.ConnectionPool -> Orville.Orville a -> m a+withTables pool operation =+  liftIO $ do+    Conn.withPoolConnection pool $ \connection -> do+      TestTable.dropAndRecreateTableDef connection Foo.table+      TestTable.dropAndRecreateTableDef connection table+    Orville.runOrville pool operation
+ test/Test/Entities/User.hs view
@@ -0,0 +1,37 @@+module Test.Entities.User+  ( User (..)+  , table+  , generate+  )+where++import qualified Data.Text as T+import qualified Hedgehog as HH+import qualified Hedgehog.Range as Range++import qualified Orville.PostgreSQL as Orville++import qualified Test.PgGen as PgGen++data User = User+  { user :: T.Text+  }+  deriving (Show, Eq)++table :: Orville.TableDefinition Orville.NoKey User User+table =+  Orville.mkTableDefinitionWithoutKey "user" userMarshaller++userMarshaller :: Orville.SqlMarshaller User User+userMarshaller =+  User+    <$> Orville.marshallField user userField++userField :: Orville.FieldDefinition Orville.NotNull T.Text+userField =+  Orville.unboundedTextField "user"++generate :: HH.Gen User+generate =+  User+    <$> PgGen.pgText (Range.constant 0 10)
+ test/Test/EntityOperations.hs view
@@ -0,0 +1,497 @@+module Test.EntityOperations+  ( entityOperationsTests+  )+where++import qualified Data.List as List+import Data.List.NonEmpty (NonEmpty ((:|)))+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+import qualified Hedgehog.Range as Range++import qualified Orville.PostgreSQL as Orville++import qualified Test.Entities.CompositeKeyEntity as CompositeKeyEntity+import qualified Test.Entities.Foo as Foo+import qualified Test.Property as Property++entityOperationsTests :: Orville.ConnectionPool -> Property.Group+entityOperationsTests pool =+  Property.group "EntityOperations" $+    [ prop_insertEntitiesFindEntitiesByRoundTrip pool+    , prop_insertEntitiesAffectedRows pool+    , prop_insertEntitiesFindFirstEntityByRoundTrip pool+    , prop_insertEntityFindEntityRoundTrip pool+    , prop_insertEntityFindEntitiesRoundTrip pool+    , prop_insertEntityFindEntitiesCompositeKeyRoundTrip pool+    , prop_insertAndReturnEntity pool+    , prop_updateEntity pool+    , prop_updateEntityAffectedRows pool+    , prop_updateAndReturnEntity pool+    , prop_updateEntity_NoMatch pool+    , prop_updateAndReturnEntity_NoMatch pool+    , prop_deleteEntity pool+    , prop_deleteEntityAffectedRows pool+    , prop_deleteAndReturnEntity pool+    , prop_deleteEntity_NoMatch pool+    , prop_deleteAndReturnEntity_NoMatch pool+    , prop_deleteEntities pool+    , prop_deleteEntitiesAffectedRows pool+    , prop_deleteEntities_NoMatch pool+    , prop_deleteAndReturnEntities pool+    , prop_deleteAndReturnEntities_NoMatch pool+    , prop_updateFields pool+    , prop_updateFields_NoMatch pool+    , prop_updateFieldsAffectedRows pool+    , prop_updateFieldsAndReturnEntities pool+    , prop_updateFieldsAndReturnEntities_NoMatch pool+    ]++prop_insertEntitiesFindEntitiesByRoundTrip :: Property.NamedDBProperty+prop_insertEntitiesFindEntitiesByRoundTrip =+  Property.singletonNamedDBProperty "insertEntity/findEntitiesBy forms a round trip" $ \pool -> do+    originalFoo <- HH.forAll Foo.generate++    retrievedFoos <-+      Foo.withTable pool $ do+        Orville.insertEntity Foo.table originalFoo+        Orville.findEntitiesBy Foo.table mempty++    retrievedFoos === [originalFoo]++prop_insertEntitiesFindFirstEntityByRoundTrip :: Property.NamedDBProperty+prop_insertEntitiesFindFirstEntityByRoundTrip =+  Property.namedDBProperty "insertEntities/findFirstEntityBy only return 1" $ \pool -> do+    originalFoos <- HH.forAll $ Foo.generateList (Range.linear 0 10)++    HH.cover 1 (String.fromString "empty list") (null originalFoos)+    HH.cover 20 (String.fromString "non-empty list") (not (null originalFoos))++    mbRetrievedFoo <-+      Foo.withTable pool $ do+        mapM_ (Orville.insertEntities Foo.table) (NEL.nonEmpty originalFoos)+        Orville.findFirstEntityBy Foo.table mempty++    let+      expectedLength =+        case originalFoos of+          [] -> 0+          _ -> 1++    -- Once we add order by to 'SelectOptions' we can order by something here+    -- and assert which item is returned.+    length (Maybe.maybeToList mbRetrievedFoo) === expectedLength++prop_insertEntitiesAffectedRows :: Property.NamedDBProperty+prop_insertEntitiesAffectedRows =+  Property.namedDBProperty "insertEntities returns the number of affected rows" $ \pool -> do+    originalFoos <- HH.forAll $ Foo.generateList (Range.linear 0 10)++    HH.cover 1 (String.fromString "empty list") (null originalFoos)+    HH.cover 20 (String.fromString "non-empty list") (not (null originalFoos))++    affectedRows <-+      Foo.withTable pool $ do+        case NEL.nonEmpty originalFoos of+          Nothing -> pure 0+          Just nonEmptyFoos -> Orville.insertEntitiesAndReturnRowCount Foo.table nonEmptyFoos++    affectedRows === length originalFoos++prop_insertEntityFindEntityRoundTrip :: Property.NamedDBProperty+prop_insertEntityFindEntityRoundTrip =+  Property.singletonNamedDBProperty "insertEntity/findEntity forms a round trip" $ \pool -> do+    originalFoo <- HH.forAll Foo.generate++    mbRetrievedFoo <-+      Foo.withTable pool $ do+        Orville.insertEntity Foo.table originalFoo+        Orville.findEntity Foo.table (Foo.fooId originalFoo)++    mbRetrievedFoo === Just originalFoo++prop_insertEntityFindEntitiesRoundTrip :: Property.NamedDBProperty+prop_insertEntityFindEntitiesRoundTrip =+  Property.singletonNamedDBProperty "insertEntity/findEntities form a round trip" $ \pool -> do+    foos <- HH.forAll $ Foo.generateNonEmpty (Range.linear 1 5)++    retrievedFoos <-+      Foo.withTable pool $ do+        Orville.insertEntities Foo.table foos+        Orville.findEntities Foo.table (Foo.fooId <$> foos)++    List.sortOn Foo.fooId retrievedFoos === List.sortOn Foo.fooId (NEL.toList foos)++prop_insertEntityFindEntitiesCompositeKeyRoundTrip :: Property.NamedDBProperty+prop_insertEntityFindEntitiesCompositeKeyRoundTrip =+  Property.singletonNamedDBProperty "insertEntity/findEntities form a round trip (composite primary key)" $ \pool -> do+    compositeKeyEntities <- HH.forAll $ CompositeKeyEntity.generateNonEmpty (Range.linear 1 5)++    retrievedCompositeKeyEntities <-+      CompositeKeyEntity.withTable pool $ do+        Orville.insertEntities CompositeKeyEntity.table compositeKeyEntities+        Orville.findEntities CompositeKeyEntity.table (CompositeKeyEntity.compositeKey <$> compositeKeyEntities)++    List.sortOn CompositeKeyEntity.compositeKey retrievedCompositeKeyEntities === List.sortOn CompositeKeyEntity.compositeKey (NEL.toList compositeKeyEntities)++prop_insertAndReturnEntity :: Property.NamedDBProperty+prop_insertAndReturnEntity =+  Property.singletonNamedDBProperty "insertAndReturnEntity returns the inserted entity" $ \pool -> do+    originalFoo <- HH.forAll Foo.generate++    retrievedFoo <-+      Foo.withTable pool $ do+        Orville.insertAndReturnEntity Foo.table originalFoo++    retrievedFoo === originalFoo++prop_updateEntity :: Property.NamedDBProperty+prop_updateEntity =+  Property.singletonNamedDBProperty "updateEntity updates row at the given key" $ \pool -> do+    originalFoo <- HH.forAll Foo.generate+    newFoo <- HH.forAll Foo.generate++    returnedFoo <-+      Foo.withTable pool $ do+        Orville.insertEntity Foo.table originalFoo+        Orville.updateEntity Foo.table (Foo.fooId originalFoo) newFoo+        Orville.findEntitiesBy Foo.table mempty++    returnedFoo === [newFoo]++prop_updateEntityAffectedRows :: Property.NamedDBProperty+prop_updateEntityAffectedRows =+  Property.singletonNamedDBProperty "updateEntity returns the number of affected rows" $ \pool -> do+    originalFoo <- HH.forAll Foo.generate+    newFoo <- HH.forAll Foo.generate++    affectedRows <-+      Foo.withTable pool $ do+        Orville.insertEntity Foo.table originalFoo+        Orville.updateEntityAndReturnRowCount Foo.table (Foo.fooId originalFoo) newFoo++    affectedRows === 1++prop_updateAndReturnEntity :: Property.NamedDBProperty+prop_updateAndReturnEntity =+  Property.singletonNamedDBProperty "updateAndReturnEntity returns the updated entity" $ \pool -> do+    originalFoo <- HH.forAll Foo.generate+    newFoo <- HH.forAll Foo.generate++    mbReturnedFoo <-+      Foo.withTable pool $ do+        Orville.insertEntity Foo.table originalFoo+        Orville.updateAndReturnEntity Foo.table (Foo.fooId originalFoo) newFoo++    mbReturnedFoo === Just newFoo++prop_updateEntity_NoMatch :: Property.NamedDBProperty+prop_updateEntity_NoMatch =+  Property.singletonNamedDBProperty "updateEntity updates no rows when key does not match" $ \pool -> do+    originalFoo <- HH.forAll Foo.generate+    newFoo <- HH.forAll Foo.generate++    let+      mismatchFooId =+        1 + Foo.fooId originalFoo++    retrievedFoos <-+      Foo.withTable pool $ do+        Orville.insertEntity Foo.table originalFoo+        Orville.updateEntity Foo.table mismatchFooId newFoo+        Orville.findEntitiesBy Foo.table mempty++    retrievedFoos === [originalFoo]++prop_updateAndReturnEntity_NoMatch :: Property.NamedDBProperty+prop_updateAndReturnEntity_NoMatch =+  Property.singletonNamedDBProperty "updateAndReturnEntity returns Nothing when key does not match" $ \pool -> do+    originalFoo <- HH.forAll Foo.generate+    newFoo <- HH.forAll Foo.generate++    let+      mismatchFooId =+        1 + Foo.fooId originalFoo++    mbReturnedFoo <-+      Foo.withTable pool $ do+        Orville.insertEntity Foo.table originalFoo+        Orville.updateAndReturnEntity Foo.table mismatchFooId newFoo++    mbReturnedFoo === Nothing++prop_deleteEntity :: Property.NamedDBProperty+prop_deleteEntity =+  Property.singletonNamedDBProperty "deleteEntity deletes row at the given key" $ \pool -> do+    originalFoo <- HH.forAll Foo.generate+    let+      withDifferentKey = Gen.filter $ (Foo.fooId originalFoo /=) . Foo.fooId+    anotherFoo <- HH.forAll . withDifferentKey $ Foo.generate++    retrievedFoos <-+      Foo.withTable pool $ do+        Orville.insertEntity Foo.table originalFoo+        Orville.insertEntity Foo.table anotherFoo+        Orville.deleteEntity Foo.table (Foo.fooId originalFoo)+        Orville.findEntitiesBy Foo.table mempty++    retrievedFoos === [anotherFoo]++prop_deleteEntityAffectedRows :: Property.NamedDBProperty+prop_deleteEntityAffectedRows =+  Property.singletonNamedDBProperty "deleteEntity returns the number of affected rows" $ \pool -> do+    originalFoo <- HH.forAll Foo.generate+    let+      withDifferentKey = Gen.filter $ (Foo.fooId originalFoo /=) . Foo.fooId+    anotherFoo <- HH.forAll . withDifferentKey $ Foo.generate++    affectedRows <-+      Foo.withTable pool $ do+        Orville.insertEntity Foo.table originalFoo+        Orville.insertEntity Foo.table anotherFoo+        Orville.deleteEntityAndReturnRowCount Foo.table (Foo.fooId originalFoo)++    affectedRows === 1++prop_deleteAndReturnEntity :: Property.NamedDBProperty+prop_deleteAndReturnEntity =+  Property.singletonNamedDBProperty "deleteAndReturnEntity returns the deleted row" $ \pool -> do+    originalFoo <- HH.forAll Foo.generate+    mbReturnedFoo <-+      Foo.withTable pool $ do+        Orville.insertEntity Foo.table originalFoo+        Orville.deleteAndReturnEntity Foo.table (Foo.fooId originalFoo)++    mbReturnedFoo === Just originalFoo++prop_deleteEntity_NoMatch :: Property.NamedDBProperty+prop_deleteEntity_NoMatch =+  Property.singletonNamedDBProperty "deleteEntity deletes no rows when key doesn't match" $ \pool -> do+    originalFoo <- HH.forAll Foo.generate++    let+      mismatchFooId =+        1 + Foo.fooId originalFoo++    retrievedFoos <-+      Foo.withTable pool $ do+        Orville.insertEntity Foo.table originalFoo+        Orville.deleteEntity Foo.table mismatchFooId+        Orville.findEntitiesBy Foo.table mempty++    retrievedFoos === [originalFoo]++prop_deleteAndReturnEntity_NoMatch :: Property.NamedDBProperty+prop_deleteAndReturnEntity_NoMatch =+  Property.singletonNamedDBProperty "deleteAndReturnEntity returns Nothing when key doesn't match" $ \pool -> do+    originalFoo <- HH.forAll Foo.generate++    let+      mismatchFooId =+        1 + Foo.fooId originalFoo++    mbReturnedFoo <-+      Foo.withTable pool $ do+        Orville.insertEntity Foo.table originalFoo+        Orville.deleteAndReturnEntity Foo.table mismatchFooId++    mbReturnedFoo === Nothing++prop_deleteEntities :: Property.NamedDBProperty+prop_deleteEntities =+  Property.singletonNamedDBProperty "deleteEntities deletes all matching rows" $ \pool -> do+    foos <- HH.forAll $ Foo.generateNonEmpty (Range.linear 1 5)++    let+      fooIds = fmap Foo.fooId foos++    remainingFoos <-+      Foo.withTable pool $ do+        Orville.insertEntities Foo.table foos+        Orville.deleteEntities+          Foo.table+          (Just (Orville.fieldIn Foo.fooIdField fooIds))+        Orville.findEntitiesBy+          Foo.table+          (Orville.where_ (Orville.fieldIn Foo.fooIdField fooIds))++    fmap Foo.fooId remainingFoos === []++prop_deleteEntitiesAffectedRows :: Property.NamedDBProperty+prop_deleteEntitiesAffectedRows =+  Property.singletonNamedDBProperty "deleteEntities returns the number of affected rows" $ \pool -> do+    foos <- HH.forAll $ Foo.generateNonEmpty (Range.linear 1 5)++    let+      fooIds = fmap Foo.fooId foos++    affectedRows <-+      Foo.withTable pool $ do+        Orville.insertEntities Foo.table foos+        Orville.deleteEntitiesAndReturnRowCount+          Foo.table+          (Just (Orville.fieldIn Foo.fooIdField fooIds))++    affectedRows === length foos++prop_deleteEntities_NoMatch :: Property.NamedDBProperty+prop_deleteEntities_NoMatch =+  Property.singletonNamedDBProperty "deleteEntities does not delete non matching rows" $ \pool -> do+    foos <- HH.forAll $ Foo.generateNonEmpty (Range.linear 1 5)++    let+      fooIds = fmap Foo.fooId foos+      mismatchedId = maximum fooIds + 1++    remainingFoos <-+      Foo.withTable pool $ do+        Orville.insertEntities Foo.table foos+        Orville.deleteEntities+          Foo.table+          (Just (Orville.fieldEquals Foo.fooIdField mismatchedId))+        Orville.findEntitiesBy+          Foo.table+          (Orville.where_ (Orville.fieldIn Foo.fooIdField fooIds))++    fmap Foo.fooId remainingFoos === NEL.toList fooIds++prop_deleteAndReturnEntities :: Property.NamedDBProperty+prop_deleteAndReturnEntities =+  Property.singletonNamedDBProperty "deleteAndReturnEntities deletes all matching rows" $ \pool -> do+    foos <- HH.forAll $ Foo.generateNonEmpty (Range.linear 1 5)++    let+      fooIds = fmap Foo.fooId foos++    deletedFoos <-+      Foo.withTable pool $ do+        Orville.insertEntities Foo.table foos+        Orville.deleteAndReturnEntities+          Foo.table+          (Just (Orville.fieldIn Foo.fooIdField fooIds))++    fmap Foo.fooId deletedFoos === NEL.toList fooIds++prop_deleteAndReturnEntities_NoMatch :: Property.NamedDBProperty+prop_deleteAndReturnEntities_NoMatch =+  Property.singletonNamedDBProperty "deleteAndReturnEntities does not delete non matching rows" $ \pool -> do+    foos <- HH.forAll $ Foo.generateNonEmpty (Range.linear 1 5)++    let+      fooIds = fmap Foo.fooId foos+      mismatchedId = maximum fooIds + 1++    deletedFoos <-+      Foo.withTable pool $ do+        Orville.insertEntities Foo.table foos+        Orville.deleteAndReturnEntities+          Foo.table+          (Just (Orville.fieldEquals Foo.fooIdField mismatchedId))++    fmap Foo.fooId deletedFoos === []++prop_updateFields :: Property.NamedDBProperty+prop_updateFields =+  Property.singletonNamedDBProperty "updateFields updates all matching rows" $ \pool -> do+    foos <- HH.forAll $ Foo.generateNonEmpty (Range.linear 1 5)++    let+      fooIds = fmap Foo.fooId foos+      updatedName = T.pack "Updated"++    updatedFoos <-+      Foo.withTable pool $ do+        Orville.insertEntities Foo.table foos+        Orville.updateFields+          Foo.table+          (Orville.setField Foo.fooNameField updatedName :| [])+          (Just (Orville.fieldIn Foo.fooIdField fooIds))+        Orville.findEntitiesBy+          Foo.table+          (Orville.where_ (Orville.fieldIn Foo.fooIdField fooIds))++    fmap Foo.fooName updatedFoos === fmap (const updatedName) (NEL.toList foos)++prop_updateFields_NoMatch :: Property.NamedDBProperty+prop_updateFields_NoMatch =+  Property.singletonNamedDBProperty "updateFields updates no non-matching rows" $ \pool -> do+    foos <- HH.forAll $ Foo.generateNonEmpty (Range.linear 1 5)++    let+      fooIds = fmap Foo.fooId foos+      updatedName = T.pack "Updated"+      mismatchedId = maximum fooIds + 1++    foosAfterUpdate <-+      Foo.withTable pool $ do+        Orville.insertEntities Foo.table foos+        Orville.updateFields+          Foo.table+          (Orville.setField Foo.fooNameField updatedName :| [])+          (Just (Orville.fieldEquals Foo.fooIdField mismatchedId))+        Orville.findEntitiesBy Foo.table mempty++    List.sortOn Foo.fooId foosAfterUpdate === List.sortOn Foo.fooId (NEL.toList foos)++prop_updateFieldsAffectedRows :: Property.NamedDBProperty+prop_updateFieldsAffectedRows =+  Property.singletonNamedDBProperty "updateFields returns the number of affeted rows" $ \pool -> do+    foos <- HH.forAll $ Foo.generateNonEmpty (Range.linear 1 5)++    let+      fooIds = fmap Foo.fooId foos+      updatedName = T.pack "Updated"++    affectedRows <-+      Foo.withTable pool $ do+        Orville.insertEntities Foo.table foos+        Orville.updateFieldsAndReturnRowCount+          Foo.table+          (Orville.setField Foo.fooNameField updatedName :| [])+          (Just (Orville.fieldIn Foo.fooIdField fooIds))++    affectedRows === length foos++prop_updateFieldsAndReturnEntities :: Property.NamedDBProperty+prop_updateFieldsAndReturnEntities =+  Property.singletonNamedDBProperty "updateFieldsAndReturnEntities returns updated rows" $ \pool -> do+    foos <- HH.forAll $ Foo.generateNonEmpty (Range.linear 1 5)++    let+      fooIds = fmap Foo.fooId foos+      updatedName = T.pack "Updated"++    updatedFoos <-+      Foo.withTable pool $ do+        Orville.insertEntities Foo.table foos+        Orville.updateFieldsAndReturnEntities+          Foo.table+          (Orville.setField Foo.fooNameField updatedName :| [])+          (Just (Orville.fieldIn Foo.fooIdField fooIds))++    fmap Foo.fooName updatedFoos === fmap (const updatedName) (NEL.toList foos)++prop_updateFieldsAndReturnEntities_NoMatch :: Property.NamedDBProperty+prop_updateFieldsAndReturnEntities_NoMatch =+  Property.singletonNamedDBProperty "updateFieldsAndReturnEntities returns no non-matching rows" $ \pool -> do+    foos <- HH.forAll $ Foo.generateNonEmpty (Range.linear 1 5)++    let+      fooIds = fmap Foo.fooId foos+      updatedName = T.pack "Updated"+      mismatchedId = maximum fooIds + 1++    updatedFoos <-+      Foo.withTable pool $ do+        Orville.insertEntities Foo.table foos+        Orville.updateFieldsAndReturnEntities+          Foo.table+          (Orville.setField Foo.fooNameField updatedName :| [])+          (Just (Orville.fieldEquals Foo.fooIdField mismatchedId))++    updatedFoos === []
+ test/Test/Execution.hs view
@@ -0,0 +1,120 @@+module Test.Execution+  ( executionTests+  )+where++import qualified Data.ByteString as BS+import qualified Data.IORef as IORef+import Hedgehog ((===))+import qualified Hedgehog as HH++import qualified Orville.PostgreSQL as Orville+import qualified Orville.PostgreSQL.Raw.RawSql as RawSql+import qualified Test.Property as Property++executionTests :: Orville.ConnectionPool -> Property.Group+executionTests pool =+  Property.group+    "Execution"+    [ prop_executeVoidCallbacks pool+    , prop_executeAndDecodeCallbacks pool+    , prop_executeAndReturnAffectedRows pool+    , prop_executeAndReturnAffectedRowsCallbacks pool+    ]++prop_executeVoidCallbacks :: Property.NamedDBProperty+prop_executeVoidCallbacks =+  Property.singletonNamedDBProperty "exceuteVoid makes execution callbacks" $ \pool -> do+    traceRef <- HH.evalIO $ IORef.newIORef []++    let+      selectOne =+        RawSql.fromString "SELECT 1 as number"++    HH.evalIO . Orville.runOrville pool $+      Orville.localOrvilleState+        ( Orville.addSqlExecutionCallback (appendTrace traceRef "Outer")+            . Orville.addSqlExecutionCallback (appendTrace traceRef "Inner")+        )+        (Orville.executeVoid Orville.SelectQuery selectOne)++    callbackTrace <- HH.evalIO $ IORef.readIORef traceRef+    callbackTrace+      === [ ("Outer", Orville.SelectQuery, RawSql.toExampleBytes selectOne)+          , ("Inner", Orville.SelectQuery, RawSql.toExampleBytes selectOne)+          ]++prop_executeAndDecodeCallbacks :: Property.NamedDBProperty+prop_executeAndDecodeCallbacks =+  Property.singletonNamedDBProperty "exceuteAndDecode makes execution callbacks" $ \pool -> do+    traceRef <- HH.evalIO $ IORef.newIORef []++    let+      selectOne =+        RawSql.fromString "SELECT 1 as number"++      marshaller =+        Orville.annotateSqlMarshallerEmptyAnnotation $+          Orville.marshallField id (Orville.integerField "number")+    _ <-+      HH.evalIO . Orville.runOrville pool $+        Orville.localOrvilleState+          ( Orville.addSqlExecutionCallback (appendTrace traceRef "Outer")+              . Orville.addSqlExecutionCallback (appendTrace traceRef "Inner")+          )+          (Orville.executeAndDecode Orville.SelectQuery selectOne marshaller)++    callbackTrace <- HH.evalIO $ IORef.readIORef traceRef+    callbackTrace+      === [ ("Outer", Orville.SelectQuery, RawSql.toExampleBytes selectOne)+          , ("Inner", Orville.SelectQuery, RawSql.toExampleBytes selectOne)+          ]++prop_executeAndReturnAffectedRows :: Property.NamedDBProperty+prop_executeAndReturnAffectedRows =+  Property.singletonNamedDBProperty "executeAndReturnAffectedRows works as advertised" $ \pool -> do+    let+      selectOne =+        RawSql.fromString "SELECT 1 as number"++    affectedRows <-+      HH.evalIO . Orville.runOrville pool $ do+        Orville.executeAndReturnAffectedRows Orville.UpdateQuery selectOne++    affectedRows === 1++prop_executeAndReturnAffectedRowsCallbacks :: Property.NamedDBProperty+prop_executeAndReturnAffectedRowsCallbacks =+  Property.singletonNamedDBProperty "executeAndReturnAffectedRows makes execution callbacks" $ \pool -> do+    traceRef <- HH.evalIO $ IORef.newIORef []++    let+      selectOne =+        RawSql.fromString "SELECT 1 as number"++    _ <-+      HH.evalIO . Orville.runOrville pool $+        Orville.localOrvilleState+          ( Orville.addSqlExecutionCallback (appendTrace traceRef "Outer")+              . Orville.addSqlExecutionCallback (appendTrace traceRef "Inner")+          )+          (Orville.executeAndReturnAffectedRows Orville.SelectQuery selectOne)++    callbackTrace <- HH.evalIO $ IORef.readIORef traceRef+    callbackTrace+      === [ ("Outer", Orville.SelectQuery, RawSql.toExampleBytes selectOne)+          , ("Inner", Orville.SelectQuery, RawSql.toExampleBytes selectOne)+          ]++appendTrace ::+  IORef.IORef [(String, Orville.QueryType, BS.ByteString)] ->+  String ->+  Orville.QueryType ->+  RawSql.RawSql ->+  IO a ->+  IO a+appendTrace traceRef label queryType sql action = do+  let+    trace = (label, queryType, RawSql.toExampleBytes sql)+  IORef.modifyIORef traceRef (++ [trace])+  action
+ test/Test/Expr/Count.hs view
@@ -0,0 +1,77 @@+module Test.Expr.Count+  ( countTests+  )+where++import qualified Data.Foldable as Fold+import qualified Data.List as List+import qualified Data.List.NonEmpty as NEL+import Hedgehog ((===))+import qualified Hedgehog as HH+import qualified Hedgehog.Range as Range++import qualified Orville.PostgreSQL as Orville+import qualified Orville.PostgreSQL.Expr as Expr++import qualified Test.Entities.Foo as Foo+import qualified Test.Property as Property++countTests :: Orville.ConnectionPool -> Property.Group+countTests pool =+  Property.group+    "Expr - Count"+    [ prop_count1 pool+    , prop_countColumn pool+    ]++prop_count1 :: Property.NamedDBProperty+prop_count1 =+  Property.singletonNamedDBProperty "SELECT COUNT(1)" $ \pool -> do+    let+      sql =+        Expr.queryExpr+          (Expr.selectClause (Expr.selectExpr Nothing))+          ( Expr.selectDerivedColumns+              [ Expr.deriveColumnAs Expr.count1 (Expr.columnName "count")+              ]+          )+          Nothing++      marshaller =+        Orville.annotateSqlMarshallerEmptyAnnotation $+          Orville.marshallField id (Orville.integerField "count")++    result <-+      HH.evalIO $+        Orville.runOrville pool $+          Orville.executeAndDecode Orville.SelectQuery sql marshaller++    result === [1]++prop_countColumn :: Property.NamedDBProperty+prop_countColumn =+  Property.singletonNamedDBProperty "In transaction" $ \pool -> do+    let+      sql =+        Expr.queryExpr+          (Expr.selectClause (Expr.selectExpr Nothing))+          ( Expr.selectDerivedColumns+              [ Expr.deriveColumnAs+                  (Expr.countColumn (Orville.fieldColumnName Foo.fooIdField))+                  (Expr.columnName "count")+              ]+          )+          (Just (Expr.tableExpr (Expr.referencesTable $ Orville.tableName Foo.table) Nothing Nothing Nothing Nothing Nothing))++      marshaller =+        Orville.annotateSqlMarshallerEmptyAnnotation $+          Orville.marshallField id (Orville.integerField "count")++    foos <- HH.forAll (Foo.generateList (Range.linear 0 5))++    result <-+      Foo.withTable pool $ do+        Fold.traverse_ (Orville.insertEntities Foo.table) (NEL.nonEmpty foos)+        Orville.executeAndDecode Orville.SelectQuery sql marshaller++    result === [List.genericLength foos]
+ test/Test/Expr/Cursor.hs view
@@ -0,0 +1,324 @@+module Test.Expr.Cursor+  ( cursorTests+  )+where++import qualified Control.Exception.Safe as ExSafe+import qualified Control.Monad.IO.Class as MIO+import qualified Data.ByteString.Char8 as B8+import qualified Data.Int as Int+import Hedgehog ((===))+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 Test.Expr.TestSchema (FooBar, assertEqualFooBarRows, findAllFooBars, mkFooBar, withFooBarData)+import qualified Test.Property as Property++cursorTests :: Orville.ConnectionPool -> Property.Group+cursorTests pool =+  Property.group+    "Expr - Cursor"+    [ prop_cursorInTransaction pool+    , prop_cursorOutsideTransactionWithHold pool+    , prop_cursorCloseAll pool+    , prop_cursorMove pool+    , prop_cursorNoScroll pool+    , prop_cursorFetchAll pool+    , prop_cursorFetchRowCount pool+    , prop_cursorFetchForward pool+    , prop_cursorFetchForwardCount pool+    , prop_cursorFetchForwardAll pool+    , prop_cursorFetchBackward pool+    , prop_cursorFetchBackwardCount pool+    , prop_cursorFetchBackwardAll pool+    , prop_cursorFetchFirstLast pool+    , prop_cursorFetchNextPrior pool+    , prop_cursorFetchAbsolute pool+    , prop_cursorFetchRelative pool+    ]++prop_cursorInTransaction :: Property.NamedDBProperty+prop_cursorInTransaction =+  Property.singletonNamedDBProperty "In transaction" $ \pool -> do+    result <-+      withFooBarData pool [row 1, row 2] $ \connection ->+        withTestTransaction connection $+          withTestCursor connection Nothing Nothing findAllFooBars $ \cursorName -> do+            result <- RawSql.execute connection $ Expr.fetch Nothing cursorName+            Execution.readRows result++    assertEqualFooBarRows result [row 1]++prop_cursorOutsideTransactionWithHold :: Property.NamedDBProperty+prop_cursorOutsideTransactionWithHold =+  Property.singletonNamedDBProperty "Outside transaction (with hold)" $ \pool -> do+    result <-+      withFooBarData pool [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++    assertEqualFooBarRows result [row 1]++prop_cursorCloseAll :: Property.NamedDBProperty+prop_cursorCloseAll =+  Property.singletonNamedDBProperty "Close all cursors" $ \pool -> do+    MIO.liftIO . Conn.withPoolConnection pool $ \connection -> do+      let+        cursorName :: Expr.CursorName+        cursorName = Expr.fromIdentifier $ Expr.identifier "testcursor"++        declare =+          RawSql.executeVoid connection+            . Expr.declare cursorName Nothing (Just Expr.withHold)+            $ RawSql.unsafeSqlExpression "SELECT 1"++        close =+          RawSql.executeVoid connection $ Expr.close (Left Expr.allCursors)++      -- As long as close doesn't raise an exception, the test passes+      ExSafe.bracket_ declare close (pure ())++prop_cursorMove :: Property.NamedDBProperty+prop_cursorMove =+  Property.singletonNamedDBProperty "Move" $ \pool -> do+    result <-+      withFooBarData pool [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+          Execution.readRows result++    assertEqualFooBarRows result [row 3]++prop_cursorNoScroll :: Property.NamedDBProperty+prop_cursorNoScroll =+  Property.singletonNamedDBProperty "Move" $ \pool -> do+    scrollBackResult <-+      withFooBarData pool [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++    case scrollBackResult of+      Right () -> do+        HH.footnote "Expected 'executeVoid' to return failure, but it did not"+        HH.failure+      Left err ->+        -- Expected that the execute failed because we tried to scroll backward+        -- on a non-scrollable cursor+        Conn.sqlExecutionErrorSqlState err === Just (B8.pack "55000")++prop_cursorFetchAll :: Property.NamedDBProperty+prop_cursorFetchAll =+  Property.singletonNamedDBProperty "Fetch all" $ \pool -> do+    [first] <-+      runFetchDirectionsOnData+        pool+        Nothing+        [row 1, row 2]+        [Expr.fetchAll]++    assertEqualFooBarRows first [row 1, row 2]++prop_cursorFetchRowCount :: Property.NamedDBProperty+prop_cursorFetchRowCount =+  Property.singletonNamedDBProperty "Fetch row count" $ \pool -> do+    [first, second] <-+      runFetchDirectionsOnData+        pool+        Nothing+        [row 1, row 2, row 3]+        [Expr.rowCount 2, Expr.rowCount 2]++    assertEqualFooBarRows first [row 1, row 2]+    assertEqualFooBarRows second [row 3]++prop_cursorFetchForward :: Property.NamedDBProperty+prop_cursorFetchForward =+  Property.singletonNamedDBProperty "Fetch forward" $ \pool -> do+    [first, second] <-+      runFetchDirectionsOnData+        pool+        Nothing+        [row 1, row 2]+        [Expr.forward, Expr.forward]++    assertEqualFooBarRows first [row 1]+    assertEqualFooBarRows second [row 2]++prop_cursorFetchForwardCount :: Property.NamedDBProperty+prop_cursorFetchForwardCount =+  Property.singletonNamedDBProperty "Fetch forward count" $ \pool -> do+    [first, second] <-+      runFetchDirectionsOnData+        pool+        Nothing+        [row 1, row 2, row 3]+        [Expr.forwardCount 2, Expr.forwardCount 2]++    assertEqualFooBarRows first [row 1, row 2]+    assertEqualFooBarRows second [row 3]++prop_cursorFetchForwardAll :: Property.NamedDBProperty+prop_cursorFetchForwardAll =+  Property.singletonNamedDBProperty "Fetch forward all" $ \pool -> do+    [first] <-+      runFetchDirectionsOnData+        pool+        Nothing+        [row 1, row 2]+        [Expr.forwardAll]++    assertEqualFooBarRows first [row 1, row 2]++prop_cursorFetchBackward :: Property.NamedDBProperty+prop_cursorFetchBackward =+  Property.singletonNamedDBProperty "Fetch backward" $ \pool -> do+    [first, second] <-+      runFetchDirectionsOnData+        pool+        (Just Expr.scroll)+        [row 1, row 2]+        [Expr.forwardCount 2, Expr.backward]++    assertEqualFooBarRows first [row 1, row 2]+    assertEqualFooBarRows second [row 1]++prop_cursorFetchBackwardCount :: Property.NamedDBProperty+prop_cursorFetchBackwardCount =+  Property.singletonNamedDBProperty "Fetch backward count" $ \pool -> do+    [first, second] <-+      runFetchDirectionsOnData+        pool+        (Just Expr.scroll)+        [row 1, row 2, row 3]+        [Expr.forwardCount 3, Expr.backwardCount 2]++    assertEqualFooBarRows first [row 1, row 2, row 3]+    assertEqualFooBarRows second [row 2, row 1]++prop_cursorFetchBackwardAll :: Property.NamedDBProperty+prop_cursorFetchBackwardAll =+  Property.singletonNamedDBProperty "Fetch backward all" $ \pool -> do+    [first, second] <-+      runFetchDirectionsOnData+        pool+        (Just Expr.scroll)+        [row 1, row 2, row 3]+        [Expr.forwardCount 4, Expr.backwardAll]++    assertEqualFooBarRows first [row 1, row 2, row 3]+    assertEqualFooBarRows second [row 3, row 2, row 1]++prop_cursorFetchFirstLast :: Property.NamedDBProperty+prop_cursorFetchFirstLast =+  Property.singletonNamedDBProperty "Fetch first/last" $ \pool -> do+    [first, second] <-+      runFetchDirectionsOnData+        pool+        Nothing+        [row 1, row 2, row 3]+        [Expr.first, Expr.last]++    assertEqualFooBarRows first [row 1]+    assertEqualFooBarRows second [row 3]++prop_cursorFetchNextPrior :: Property.NamedDBProperty+prop_cursorFetchNextPrior =+  Property.singletonNamedDBProperty "Fetch next/prior" $ \pool -> do+    [first, second, third] <-+      runFetchDirectionsOnData+        pool+        (Just Expr.scroll)+        [row 1, row 2, row 3]+        [Expr.next, Expr.next, Expr.prior]++    assertEqualFooBarRows first [row 1]+    assertEqualFooBarRows second [row 2]+    assertEqualFooBarRows third [row 1]++prop_cursorFetchAbsolute :: Property.NamedDBProperty+prop_cursorFetchAbsolute =+  Property.singletonNamedDBProperty "Fetch absolute" $ \pool -> do+    [first, second] <-+      runFetchDirectionsOnData+        pool+        (Just Expr.scroll)+        [row 1, row 2, row 3]+        [Expr.absolute 3, Expr.absolute (-1)]++    assertEqualFooBarRows first [row 3]+    assertEqualFooBarRows second [row 3]++prop_cursorFetchRelative :: Property.NamedDBProperty+prop_cursorFetchRelative =+  Property.singletonNamedDBProperty "Fetch relative" $ \pool -> do+    [first, second, third, fourth] <-+      runFetchDirectionsOnData+        pool+        (Just Expr.scroll)+        [row 1, row 2, row 3]+        [Expr.relative 1, Expr.relative 2, Expr.relative (-1), Expr.relative 0]++    assertEqualFooBarRows first [row 1]+    assertEqualFooBarRows second [row 3]+    assertEqualFooBarRows third [row 2]+    assertEqualFooBarRows fourth [row 2]++row :: Int.Int32 -> FooBar+row n = mkFooBar n ("row " <> show n)++runFetchDirectionsOnData ::+  Orville.ConnectionPool ->+  Maybe Expr.ScrollExpr ->+  [FooBar] ->+  [Expr.CursorDirection] ->+  HH.PropertyT IO [[[(Maybe B8.ByteString, SqlValue.SqlValue)]]]+runFetchDirectionsOnData pool scroll fooBars directions =+  withFooBarData pool fooBars $ \connection ->+    withTestCursor connection scroll (Just Expr.withHold) findAllFooBars $ \cursorName ->+      let+        runDirection direction = do+          result <- RawSql.execute connection $ Expr.fetch (Just direction) cursorName+          Execution.readRows result+      in+        traverse runDirection directions++withTestCursor ::+  Orville.Connection ->+  Maybe Expr.ScrollExpr ->+  Maybe Expr.HoldExpr ->+  Expr.QueryExpr ->+  (Expr.CursorName -> IO a) ->+  IO a+withTestCursor connection scroll hold query action =+  let+    cursorName :: Expr.CursorName+    cursorName = Expr.fromIdentifier $ Expr.identifier "testcursor"++    declare =+      RawSql.executeVoid connection $+        Expr.declare cursorName scroll hold query++    close =+      RawSql.executeVoid connection $ Expr.close (Right cursorName)+  in+    ExSafe.bracket_ declare close (action cursorName)++withTestTransaction :: Orville.Connection -> IO a -> IO a+withTestTransaction connection action =+  let+    begin =+      RawSql.executeVoid connection $ Expr.beginTransaction Nothing++    commit =+      RawSql.executeVoid connection $ Expr.commit+  in+    ExSafe.bracket_ begin commit action
+ test/Test/Expr/GroupBy.hs view
@@ -0,0 +1,121 @@+module Test.Expr.GroupBy+  ( groupByTests+  )+where++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.Text as T++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 (assertEqualSqlRows)+import qualified Test.Property as Property++data FooBar = FooBar+  { foo :: Int.Int32+  , bar :: String+  }++groupByTests :: Orville.ConnectionPool -> Property.Group+groupByTests pool =+  Property.group+    "Expr - GroupBy"+    [ prop_groupByColumnsExpr pool+    , prop_appendGroupByExpr pool+    ]++prop_groupByColumnsExpr :: Property.NamedDBProperty+prop_groupByColumnsExpr =+  groupByTest "groupByColumnsExpr groups by columns" $+    GroupByTest+      { groupByValuesToInsert = [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]+      }++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"]+      , groupByExpectedQueryResults = [FooBar 2 "dingo", FooBar 1 "dog", FooBar 3 "dingo"]+      , groupByClause =+          Just . Expr.groupByClause $+            Expr.appendGroupByExpr+              (Expr.groupByColumnsExpr . pure $ barColumn)+              (Expr.groupByColumnsExpr . pure $ fooColumn)+      }++data GroupByTest = GroupByTest+  { groupByValuesToInsert :: [FooBar]+  , groupByClause :: Maybe Expr.GroupByClause+  , groupByExpectedQueryResults :: [FooBar]+  }++mkGroupByTestInsertSource :: GroupByTest -> Expr.InsertSource+mkGroupByTestInsertSource test =+  let+    mkRow foobar =+      [ SqlValue.fromInt32 (foo foobar)+      , SqlValue.fromText (T.pack $ bar foobar)+      ]+  in+    Expr.insertSqlValues (map mkRow $ groupByValuesToInsert test)++mkGroupByTestExpectedRows :: GroupByTest -> [[(Maybe B8.ByteString, SqlValue.SqlValue)]]+mkGroupByTestExpectedRows test =+  let+    mkRow foobar =+      [ (Just (B8.pack "foo"), SqlValue.fromInt32 (foo foobar))+      , (Just (B8.pack "bar"), SqlValue.fromText (T.pack $ bar foobar))+      ]+  in+    fmap mkRow (groupByExpectedQueryResults test)++groupByTest :: String -> GroupByTest -> Property.NamedDBProperty+groupByTest testName test =+  Property.singletonNamedDBProperty testName $ \pool -> do+    rows <- MIO.liftIO . Conn.withPoolConnection pool $ \connection -> do+      dropAndRecreateTestTable connection++      RawSql.executeVoid connection $+        Expr.insertExpr testTable Nothing (mkGroupByTestInsertSource test) 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)++      Execution.readRows result++    rows `assertEqualSqlRows` mkGroupByTestExpectedRows test++testTable :: Expr.Qualified Expr.TableName+testTable =+  Expr.qualifyTable Nothing (Expr.tableName "expr_test")++fooColumn :: Expr.ColumnName+fooColumn =+  Expr.columnName "foo"++barColumn :: Expr.ColumnName+barColumn =+  Expr.columnName "bar"++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)")
+ test/Test/Expr/GroupByOrderBy.hs view
@@ -0,0 +1,111 @@+module Test.Expr.GroupByOrderBy+  ( groupByOrderByTests+  )+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.Text as T++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 (assertEqualSqlRows)+import qualified Test.Property as Property++data FooBar = FooBar+  { foo :: Int.Int32+  , bar :: String+  }++groupByOrderByTests :: Orville.ConnectionPool -> Property.Group+groupByOrderByTests pool =+  Property.group+    "Expr - GroupBy and OrderBy"+    [ prop_groupByOrderByExpr pool+    ]++prop_groupByOrderByExpr :: Property.NamedDBProperty+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"]+      , expectedQueryResults = [FooBar 2 "dingo", FooBar 1 "dog", FooBar 1 "shiba"]+      , groupByClause =+          Just . Expr.groupByClause $+            Expr.appendGroupByExpr+              (Expr.groupByColumnsExpr . pure $ barColumn)+              (Expr.groupByColumnsExpr . pure $ fooColumn)+      , orderByClause =+          Just . Expr.orderByClause $+            Expr.orderByColumnName barColumn Expr.ascendingOrder+      }++data GroupByOrderByTest = GroupByOrderByTest+  { valuesToInsert :: [FooBar]+  , groupByClause :: Maybe Expr.GroupByClause+  , orderByClause :: Maybe Expr.OrderByClause+  , expectedQueryResults :: [FooBar]+  }++mkGroupByOrderByTestInsertSource :: GroupByOrderByTest -> Expr.InsertSource+mkGroupByOrderByTestInsertSource test =+  let+    mkRow foobar =+      [ SqlValue.fromInt32 (foo foobar)+      , SqlValue.fromText (T.pack $ bar foobar)+      ]+  in+    Expr.insertSqlValues (map mkRow $ valuesToInsert test)++mkGroupByOrderByTestExpectedRows :: GroupByOrderByTest -> [[(Maybe B8.ByteString, SqlValue.SqlValue)]]+mkGroupByOrderByTestExpectedRows test =+  let+    mkRow foobar =+      [ (Just (B8.pack "foo"), SqlValue.fromInt32 (foo foobar))+      , (Just (B8.pack "bar"), SqlValue.fromText (T.pack $ bar foobar))+      ]+  in+    fmap mkRow (expectedQueryResults test)++groupByOrderByTest :: String -> GroupByOrderByTest -> Property.NamedDBProperty+groupByOrderByTest testName test =+  Property.singletonNamedDBProperty testName $ \pool -> do+    rows <- MIO.liftIO . Conn.withPoolConnection pool $ \connection -> do+      dropAndRecreateTestTable connection++      RawSql.executeVoid connection $+        Expr.insertExpr testTable Nothing (mkGroupByOrderByTestInsertSource test) 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)++      Execution.readRows result++    rows `assertEqualSqlRows` mkGroupByOrderByTestExpectedRows test++testTable :: Expr.Qualified Expr.TableName+testTable =+  Expr.qualifyTable Nothing (Expr.tableName "expr_test")++fooColumn :: Expr.ColumnName+fooColumn =+  Expr.columnName "foo"++barColumn :: Expr.ColumnName+barColumn =+  Expr.columnName "bar"++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)")
+ test/Test/Expr/InsertUpdateDelete.hs view
@@ -0,0 +1,246 @@+module Test.Expr.InsertUpdateDelete+  ( insertUpdateDeleteTests+  )+where++import qualified Control.Monad.IO.Class as MIO+import Data.List.NonEmpty (NonEmpty ((:|)))+import qualified Data.Text as T++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 (assertEqualFooBarRows, barColumn, barColumnRef, dropAndRecreateTestTable, findAllFooBars, fooBarTable, fooColumn, insertFooBarSource, mkFooBar)+import qualified Test.Property as Property++insertUpdateDeleteTests :: Orville.ConnectionPool -> Property.Group+insertUpdateDeleteTests pool =+  Property.group+    "Expr - Insert/Update/Delete"+    [ prop_insertExpr pool+    , prop_insertExprWithReturning pool+    , prop_updateExpr pool+    , prop_updateExprWithWhere pool+    , prop_updateExprWithReturning pool+    , prop_deleteExpr pool+    , prop_deleteExprWithWhere pool+    , prop_deleteExprWithReturning pool+    ]++prop_insertExpr :: Property.NamedDBProperty+prop_insertExpr =+  Property.singletonNamedDBProperty "insertExpr inserts values" $ \pool -> do+    let+      fooBars = [mkFooBar 1 "dog", mkFooBar 2 "cat"]++    rows <-+      MIO.liftIO $+        Conn.withPoolConnection pool $ \connection -> do+          dropAndRecreateTestTable connection++          RawSql.executeVoid connection $+            Expr.insertExpr fooBarTable Nothing (insertFooBarSource fooBars) Nothing++          result <- RawSql.execute connection findAllFooBars++          Execution.readRows result++    assertEqualFooBarRows rows fooBars++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"]++    rows <-+      MIO.liftIO $+        Conn.withPoolConnection pool $ \connection -> do+          dropAndRecreateTestTable connection++          result <-+            RawSql.execute connection $+              Expr.insertExpr+                fooBarTable+                Nothing+                (insertFooBarSource fooBars)+                (Just $ Expr.returningExpr $ Expr.selectColumns [fooColumn, barColumn])++          Execution.readRows result++    assertEqualFooBarRows rows 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"]++      setBarToFerret =+        Expr.updateExpr+          fooBarTable+          (Expr.setClauseList (Expr.setColumn barColumn (SqlValue.fromText (T.pack "ferret")) :| []))+          Nothing+          Nothing++    rows <-+      MIO.liftIO $+        Conn.withPoolConnection pool $ \connection -> do+          dropAndRecreateTestTable connection++          RawSql.executeVoid connection $+            Expr.insertExpr fooBarTable Nothing (insertFooBarSource oldFooBars) Nothing++          RawSql.executeVoid connection setBarToFerret++          result <- RawSql.execute connection findAllFooBars++          Execution.readRows result++    assertEqualFooBarRows rows 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"]++      updateDogToForret =+        Expr.updateExpr+          fooBarTable+          (Expr.setClauseList (Expr.setColumn barColumn (SqlValue.fromText (T.pack "ferret")) :| []))+          (Just (Expr.whereClause (Expr.equals barColumnRef (Expr.valueExpression (SqlValue.fromText (T.pack "dog"))))))+          Nothing++    rows <-+      MIO.liftIO $+        Conn.withPoolConnection pool $ \connection -> do+          dropAndRecreateTestTable connection++          RawSql.executeVoid connection $+            Expr.insertExpr fooBarTable Nothing (insertFooBarSource oldFooBars) Nothing++          RawSql.executeVoid connection updateDogToForret++          result <- RawSql.execute connection findAllFooBars++          Execution.readRows result++    assertEqualFooBarRows rows 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"]++      setBarToFerret =+        Expr.updateExpr+          fooBarTable+          (Expr.setClauseList (Expr.setColumn barColumn (SqlValue.fromText (T.pack "ferret")) :| []))+          Nothing+          (Just $ Expr.returningExpr $ Expr.selectColumns [fooColumn, barColumn])++    rows <-+      MIO.liftIO $+        Conn.withPoolConnection pool $ \connection -> do+          dropAndRecreateTestTable connection++          RawSql.executeVoid connection $+            Expr.insertExpr fooBarTable Nothing (insertFooBarSource oldFooBars) Nothing++          result <- RawSql.execute connection setBarToFerret++          Execution.readRows result++    assertEqualFooBarRows rows 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"]++      deleteRows =+        Expr.deleteExpr+          fooBarTable+          Nothing+          Nothing++    rows <-+      MIO.liftIO $+        Conn.withPoolConnection pool $ \connection -> do+          dropAndRecreateTestTable connection++          RawSql.executeVoid connection $+            Expr.insertExpr fooBarTable Nothing (insertFooBarSource oldFooBars) Nothing++          RawSql.executeVoid connection deleteRows++          result <- RawSql.execute connection findAllFooBars++          Execution.readRows result++    assertEqualFooBarRows rows []++prop_deleteExprWithWhere :: Property.NamedDBProperty+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"]++      deleteDogs =+        Expr.deleteExpr+          fooBarTable+          (Just (Expr.whereClause (Expr.equals barColumnRef (Expr.valueExpression (SqlValue.fromText (T.pack "dog"))))))+          Nothing++    rows <-+      MIO.liftIO $+        Conn.withPoolConnection pool $ \connection -> do+          dropAndRecreateTestTable connection++          RawSql.executeVoid connection $+            Expr.insertExpr fooBarTable Nothing (insertFooBarSource oldFooBars) Nothing++          RawSql.executeVoid connection deleteDogs++          result <- RawSql.execute connection findAllFooBars++          Execution.readRows result++    assertEqualFooBarRows rows 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"]++      deleteDogs =+        Expr.deleteExpr+          fooBarTable+          Nothing+          (Just $ Expr.returningExpr $ Expr.selectColumns [fooColumn, barColumn])++    rows <-+      MIO.liftIO $+        Conn.withPoolConnection pool $ \connection -> do+          dropAndRecreateTestTable connection++          RawSql.executeVoid connection $+            Expr.insertExpr fooBarTable Nothing (insertFooBarSource oldFooBars) Nothing++          result <- RawSql.execute connection deleteDogs++          Execution.readRows result++    assertEqualFooBarRows rows oldFooBars
+ test/Test/Expr/Math.hs view
@@ -0,0 +1,215 @@+module Test.Expr.Math+  ( mathTests+  )+where++import Data.Bits ((.&.), (.|.))+import qualified Data.Bits as Bits+import Data.Int (Int32)+import GHC.Stack (withFrozenCallStack)+import Hedgehog ((===))+import qualified Hedgehog as HH+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import qualified Orville.PostgreSQL as Orville+import qualified Orville.PostgreSQL.Expr as Expr+import qualified Orville.PostgreSQL.Raw.SqlValue as SqlValue++import qualified Test.Property as Property++mathTests :: Orville.ConnectionPool -> Property.Group+mathTests pool =+  Property.group+    "Expr - Math"+    [ prop_plus pool+    , prop_minus pool+    , prop_multiply pool+    , prop_divide pool+    , prop_exponentiate pool+    , prop_bitwiseAnd pool+    , prop_bitwiseOr pool+    , prop_bitwiseXor pool+    , prop_bitwiseShiftLeft pool+    , prop_bitwiseShiftRight pool+    ]++prop_plus :: Property.NamedDBProperty+prop_plus =+  Property.namedDBProperty "plus" $ \pool -> do+    n <- HH.forAll (Gen.integral (Range.linearFrom 0 (-100) 100))+    m <- HH.forAll (Gen.integral (Range.linearFrom 0 (-100) 100))++    result <-+      evaluateIntegerExpression pool $+        Expr.plus+          (int32Expression n)+          (int32Expression m)++    result === (n + m)++prop_minus :: Property.NamedDBProperty+prop_minus =+  Property.namedDBProperty "minus" $ \pool -> do+    n <- HH.forAll (Gen.integral (Range.linearFrom 0 (-100) 100))+    m <- HH.forAll (Gen.integral (Range.linearFrom 0 (-100) 100))++    result <-+      evaluateIntegerExpression pool $+        Expr.minus+          (int32Expression n)+          (int32Expression m)++    result === (n - m)++prop_multiply :: Property.NamedDBProperty+prop_multiply =+  Property.namedDBProperty "multiply" $ \pool -> do+    n <- HH.forAll (Gen.integral (Range.linearFrom 0 (-100) 100))+    m <- HH.forAll (Gen.integral (Range.linearFrom 0 (-100) 100))++    result <-+      evaluateIntegerExpression pool $+        Expr.multiply+          (int32Expression n)+          (int32Expression m)++    result === (n * m)++prop_divide :: Property.NamedDBProperty+prop_divide =+  Property.namedDBProperty "divide" $ \pool -> do+    n <- HH.forAll (Gen.integral (Range.linearFrom 0 (-100) 100))+    m <- HH.forAll (Gen.filter (/= 0) (Gen.integral (Range.linearFrom 0 (-100) 100)))++    result <-+      evaluateIntegerExpression pool $+        Expr.divide+          (int32Expression n)+          (int32Expression m)++    result === (n `quot` m)++prop_exponentiate :: Property.NamedDBProperty+prop_exponentiate =+  Property.namedDBProperty "exponentiate" $ \pool -> do+    n <- HH.forAll (Gen.integral (Range.linear 0 10))+    m <- HH.forAll (Gen.integral (Range.linear 0 10))++    result <-+      evaluateIntegerExpression pool $+        Expr.exponentiate+          (int32Expression n)+          (int32Expression m)++    result === (n ^ m)++prop_bitwiseAnd :: Property.NamedDBProperty+prop_bitwiseAnd =+  Property.namedDBProperty "bitwiseAnd" $ \pool -> do+    n <- HH.forAll (Gen.integral (Range.linear 0 0xFFFFFFF))+    m <- HH.forAll (Gen.integral (Range.linear 0 0xFFFFFFF))++    result <-+      evaluateIntegerExpression pool $+        Expr.bitwiseAnd+          (int32Expression n)+          (int32Expression m)++    result === (n .&. m)++prop_bitwiseOr :: Property.NamedDBProperty+prop_bitwiseOr =+  Property.namedDBProperty "bitwiseOr" $ \pool -> do+    n <- HH.forAll (Gen.integral (Range.linear 0 0xFFFFFFF))+    m <- HH.forAll (Gen.integral (Range.linear 0 0xFFFFFFF))++    result <-+      evaluateIntegerExpression pool $+        Expr.bitwiseOr+          (int32Expression n)+          (int32Expression m)++    result === (n .|. m)++prop_bitwiseXor :: Property.NamedDBProperty+prop_bitwiseXor =+  Property.namedDBProperty "bitwiseXor" $ \pool -> do+    n <- HH.forAll (Gen.integral (Range.linear 0 0xFFFFFFF))+    m <- HH.forAll (Gen.integral (Range.linear 0 0xFFFFFFF))++    result <-+      evaluateIntegerExpression pool $+        Expr.bitwiseXor+          (int32Expression n)+          (int32Expression m)++    result === Bits.xor n m++prop_bitwiseShiftLeft :: Property.NamedDBProperty+prop_bitwiseShiftLeft =+  Property.namedDBProperty "bitwiseShiftLeft" $ \pool -> do+    n <- HH.forAll (Gen.integral (Range.linear 0 0xFFFFFFF))+    m <- HH.forAll (Gen.integral (Range.linear 0 64))++    result <-+      evaluateIntegerExpression pool $+        Expr.bitwiseShiftLeft+          (int32Expression n)+          (intExpression m)++    result === Bits.shiftL n (m `mod` 32)++prop_bitwiseShiftRight :: Property.NamedDBProperty+prop_bitwiseShiftRight =+  Property.namedDBProperty "bitwiseShiftRight" $ \pool -> do+    n <- HH.forAll (Gen.integral (Range.linear 0 0xFFFFFFF))+    m <- HH.forAll (Gen.integral (Range.linear 0 64))++    result <-+      evaluateIntegerExpression pool $+        Expr.bitwiseShiftRight+          (int32Expression n)+          (intExpression m)++    result === Bits.shiftR n (m `mod` 32)++int32Expression :: Int32 -> Expr.ValueExpression+int32Expression n =+  Expr.cast (Expr.valueExpression (SqlValue.fromInt32 n)) Expr.int++intExpression :: Int -> Expr.ValueExpression+intExpression n =+  Expr.cast (Expr.valueExpression (SqlValue.fromInt n)) Expr.int++evaluateIntegerExpression ::+  Orville.ConnectionPool ->+  Expr.ValueExpression ->+  HH.PropertyT IO Int32+evaluateIntegerExpression pool expression = do+  let+    sql =+      Expr.queryExpr+        (Expr.selectClause (Expr.selectExpr Nothing))+        ( Expr.selectDerivedColumns+            [ Expr.deriveColumnAs expression (Expr.columnName "result")+            ]+        )+        Nothing++    marshaller =+      Orville.annotateSqlMarshallerEmptyAnnotation $+        Orville.marshallField id (Orville.integerField "result")++  results <-+    HH.evalIO $+      Orville.runOrville pool $+        Orville.executeAndDecode Orville.SelectQuery sql marshaller++  case results of+    [result] ->+      pure result+    _ ->+      withFrozenCallStack $ do+        HH.annotate $ "Expected exactly 1 row in result, but got the rows: " <> show results+        HH.failure
+ test/Test/Expr/OrderBy.hs view
@@ -0,0 +1,134 @@+module Test.Expr.OrderBy+  ( orderByTests+  )+where++import qualified Control.Monad.IO.Class as MIO+import qualified Data.List.NonEmpty as NE++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 (FooBar (..), assertEqualFooBarRows, barColumn, dropAndRecreateTestTable, fooBarTable, fooColumn, insertFooBarSource, mkFooBar)+import qualified Test.Property as Property++orderByTests :: Orville.ConnectionPool -> Property.Group+orderByTests pool =+  Property.group+    "Expr - OrderBy"+    [ prop_ascendingExpr pool+    , prop_descendingExpr pool+    , prop_appendOrderByExpr pool+    , prop_orderByColumnsExpr pool+    , prop_ascendingOrderWithExpr pool+    , prop_descendingOrderWithExpr pool+    ]++prop_ascendingExpr :: Property.NamedDBProperty+prop_ascendingExpr =+  orderByTest "ascendingExpr sorts a text column" $+    OrderByTest+      { orderByValuesToInsert = [mkFooBar 1 "dog", mkFooBar 2 "dingo", mkFooBar 3 "dog"]+      , orderByExpectedQueryResults = [mkFooBar 2 "dingo", mkFooBar 1 "dog", mkFooBar 3 "dog"]+      , orderByClause =+          Just . Expr.orderByClause $+            Expr.orderByColumnName barColumn Expr.ascendingOrder+      }++prop_descendingExpr :: Property.NamedDBProperty+prop_descendingExpr =+  orderByTest "descendingExpr sorts a text column" $+    OrderByTest+      { orderByValuesToInsert = [mkFooBar 1 "dog", mkFooBar 2 "dingo", mkFooBar 3 "dog"]+      , orderByExpectedQueryResults = [mkFooBar 1 "dog", mkFooBar 3 "dog", mkFooBar 2 "dingo"]+      , orderByClause =+          Just . Expr.orderByClause $+            Expr.orderByColumnName barColumn Expr.descendingOrder+      }++prop_appendOrderByExpr :: Property.NamedDBProperty+prop_appendOrderByExpr =+  orderByTest "appendOrderByExpr causes ordering on both columns" $+    OrderByTest+      { orderByValuesToInsert = [mkFooBar 1 "dog", mkFooBar 2 "dingo", mkFooBar 3 "dog"]+      , orderByExpectedQueryResults = [mkFooBar 2 "dingo", mkFooBar 3 "dog", mkFooBar 1 "dog"]+      , orderByClause =+          Just . Expr.orderByClause $+            Expr.appendOrderByExpr+              (Expr.orderByColumnName barColumn Expr.ascendingOrder)+              (Expr.orderByColumnName fooColumn Expr.descendingOrder)+      }++prop_orderByColumnsExpr :: Property.NamedDBProperty+prop_orderByColumnsExpr =+  orderByTest "orderByColumnsExpr orders by columns" $+    OrderByTest+      { orderByValuesToInsert = [mkFooBar 1 "dog", mkFooBar 2 "dingo", mkFooBar 3 "dog"]+      , orderByExpectedQueryResults = [mkFooBar 2 "dingo", mkFooBar 3 "dog", mkFooBar 1 "dog"]+      , orderByClause =+          Just . Expr.orderByClause $+            Expr.orderByColumnsExpr $+              (barColumn, Expr.ascendingOrder)+                NE.:| [(fooColumn, Expr.descendingOrder)]+      }++prop_ascendingOrderWithExpr :: Property.NamedDBProperty+prop_ascendingOrderWithExpr =+  orderByTest "ascendingOrderWith sorts columns with nulls first/last" $+    OrderByTest+      { orderByValuesToInsert =+          [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"]+      , orderByClause =+          Just . Expr.orderByClause $+            Expr.appendOrderByExpr+              (Expr.orderByColumnName fooColumn $ Expr.ascendingOrderWith Expr.NullsFirst)+              (Expr.orderByColumnName barColumn $ Expr.ascendingOrderWith Expr.NullsLast)+      }++prop_descendingOrderWithExpr :: Property.NamedDBProperty+prop_descendingOrderWithExpr =+  orderByTest "descendingOrderWith sorts columns with nulls first/last" $+    OrderByTest+      { orderByValuesToInsert =+          [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]+      , orderByClause =+          Just . Expr.orderByClause $+            Expr.appendOrderByExpr+              (Expr.orderByColumnName fooColumn $ Expr.descendingOrderWith Expr.NullsFirst)+              (Expr.orderByColumnName barColumn $ Expr.descendingOrderWith Expr.NullsLast)+      }++data OrderByTest = OrderByTest+  { orderByValuesToInsert :: [FooBar]+  , orderByClause :: Maybe Expr.OrderByClause+  , orderByExpectedQueryResults :: [FooBar]+  }++orderByTest :: String -> OrderByTest -> Property.NamedDBProperty+orderByTest testName test =+  Property.singletonNamedDBProperty testName $ \pool -> do+    rows <-+      MIO.liftIO $ do+        Conn.withPoolConnection pool $ \connection -> do+          dropAndRecreateTestTable connection++          RawSql.executeVoid connection $+            Expr.insertExpr fooBarTable Nothing (insertFooBarSource $ orderByValuesToInsert test) Nothing++          result <-+            RawSql.execute connection $+              Expr.queryExpr+                (Expr.selectClause $ Expr.selectExpr Nothing)+                (Expr.selectColumns [fooColumn, barColumn])+                (Just $ Expr.tableExpr (Expr.referencesTable fooBarTable) Nothing Nothing (orderByClause test) Nothing Nothing)++          Execution.readRows result++    assertEqualFooBarRows rows (orderByExpectedQueryResults test)
+ test/Test/Expr/SequenceDefinition.hs view
@@ -0,0 +1,66 @@+module Test.Expr.SequenceDefinition+  ( sequenceDefinitionTests+  )+where++import qualified Control.Monad.IO.Class as MIO+import Hedgehog ((===))++import qualified Orville.PostgreSQL as Orville+import qualified Orville.PostgreSQL.Expr as Expr+import qualified Orville.PostgreSQL.PgCatalog as PgCatalog++import qualified Test.PgAssert as PgAssert+import qualified Test.Property as Property++sequenceDefinitionTests :: Orville.ConnectionPool -> Property.Group+sequenceDefinitionTests pool =+  Property.group+    "Expr - SequenceDefinition"+    [ prop_createWithNoOptions pool+    , prop_createWithWithOptions pool+    ]++prop_createWithNoOptions :: Property.NamedDBProperty+prop_createWithNoOptions =+  Property.singletonNamedDBProperty "Create sequence with no options" $ \pool -> do+    MIO.liftIO $+      Orville.runOrville pool $ do+        Orville.executeVoid Orville.DDLQuery $ Expr.dropSequenceExpr (Just Expr.ifExists) exprSequenceName+        Orville.executeVoid Orville.DDLQuery $ Expr.createSequenceExpr exprSequenceName Nothing Nothing Nothing Nothing Nothing Nothing++    _ <- PgAssert.assertSequenceExists pool sequenceNameString+    pure ()++prop_createWithWithOptions :: Property.NamedDBProperty+prop_createWithWithOptions =+  Property.singletonNamedDBProperty "Create sequence with no options" $ \pool -> do+    MIO.liftIO $+      Orville.runOrville pool $ do+        Orville.executeVoid Orville.DDLQuery $ Expr.dropSequenceExpr (Just Expr.ifExists) exprSequenceName+        Orville.executeVoid Orville.DDLQuery $+          Expr.createSequenceExpr+            exprSequenceName+            (Just $ Expr.incrementBy 2)+            (Just $ Expr.minValue 100)+            (Just $ Expr.maxValue 200)+            (Just $ Expr.startWith 107)+            (Just $ Expr.cache 10)+            (Just Expr.cycle)++    relation <- PgAssert.assertSequenceExists pool sequenceNameString+    pgSequence <- PgAssert.assertRelationHasPgSequence relation+    PgCatalog.pgSequenceIncrement pgSequence === 2+    PgCatalog.pgSequenceStart pgSequence === 107+    PgCatalog.pgSequenceMin pgSequence === 100+    PgCatalog.pgSequenceMax pgSequence === 200+    PgCatalog.pgSequenceCache pgSequence === 10+    PgCatalog.pgSequenceCycle pgSequence === True++exprSequenceName :: Expr.Qualified Expr.SequenceName+exprSequenceName =+  Expr.qualifySequence Nothing (Expr.sequenceName sequenceNameString)++sequenceNameString :: String+sequenceNameString =+  "sequence_definition_test"
+ test/Test/Expr/TableDefinition.hs view
@@ -0,0 +1,101 @@+module Test.Expr.TableDefinition+  ( tableDefinitionTests+  )+where++import qualified Control.Monad.IO.Class as MIO+import Data.List.NonEmpty (NonEmpty ((:|)))++import qualified Orville.PostgreSQL as Orville+import qualified Orville.PostgreSQL.Expr as Expr++import qualified Test.PgAssert as PgAssert+import qualified Test.Property as Property++tableDefinitionTests :: Orville.ConnectionPool -> Property.Group+tableDefinitionTests pool =+  Property.group+    "Expr - TableDefinition"+    [ prop_createWithOneColumn pool+    , prop_createWithMultipleColumns pool+    , prop_addOneColumn pool+    , prop_addMultipleColumns pool+    ]++prop_createWithOneColumn :: Property.NamedDBProperty+prop_createWithOneColumn =+  Property.singletonNamedDBProperty "Create table creates a table with one column" $ \pool -> do+    MIO.liftIO $+      Orville.runOrville pool $ do+        Orville.executeVoid Orville.DDLQuery $ Expr.dropTableExpr (Just Expr.ifExists) exprTableName+        Orville.executeVoid Orville.DDLQuery $ Expr.createTableExpr exprTableName [column1Definition] Nothing []++    tableDesc <- PgAssert.assertTableExists pool tableNameString+    PgAssert.assertColumnNamesEqual tableDesc [column1NameString]++prop_createWithMultipleColumns :: Property.NamedDBProperty+prop_createWithMultipleColumns =+  Property.singletonNamedDBProperty "Create table creates a table with multiple columns" $ \pool -> do+    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 []++    tableDesc <- PgAssert.assertTableExists pool tableNameString+    PgAssert.assertColumnNamesEqual tableDesc [column1NameString, column2NameString]++prop_addOneColumn :: Property.NamedDBProperty+prop_addOneColumn =+  Property.singletonNamedDBProperty "Alter table adds one column" $ \pool -> do+    MIO.liftIO $+      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 :| [])++    tableDesc <- PgAssert.assertTableExists pool tableNameString+    PgAssert.assertColumnNamesEqual tableDesc [column1NameString]++prop_addMultipleColumns :: Property.NamedDBProperty+prop_addMultipleColumns =+  Property.singletonNamedDBProperty "Alter table adds multiple columns" $ \pool -> do+    MIO.liftIO $+      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])++    tableDesc <- PgAssert.assertTableExists pool tableNameString+    PgAssert.assertColumnNamesEqual tableDesc [column1NameString, column2NameString]++exprTableName :: Expr.Qualified Expr.TableName+exprTableName =+  Expr.qualifyTable Nothing (Expr.tableName tableNameString)++tableNameString :: String+tableNameString =+  "table_definition_test"++column1Definition :: Expr.ColumnDefinition+column1Definition =+  Expr.columnDefinition+    (Expr.columnName column1NameString)+    Expr.text+    Nothing+    Nothing++column1NameString :: String+column1NameString =+  "column1"++column2Definition :: Expr.ColumnDefinition+column2Definition =+  Expr.columnDefinition+    (Expr.columnName column2NameString)+    Expr.text+    Nothing+    Nothing++column2NameString :: String+column2NameString =+  "column2"
+ test/Test/Expr/TestSchema.hs view
@@ -0,0 +1,135 @@+module Test.Expr.TestSchema+  ( FooBar (..)+  , mkFooBar+  , findAllFooBars+  , fooBarTable+  , fooColumn+  , fooColumnRef+  , barColumn+  , barColumnRef+  , encodeFooBar+  , orderByFoo+  , insertFooBarSource+  , withFooBarData+  , dropAndRecreateTestTable+  , assertEqualFooBarRows+  , assertEqualSqlRows+  , sqlRowsToText+  )+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.Text as T+import GHC.Stack (HasCallStack, withFrozenCallStack)+import Hedgehog ((===))+import qualified Hedgehog as HH++import qualified Orville.PostgreSQL as Orville+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++data FooBar = FooBar+  { foo :: Maybe Int.Int32+  , bar :: Maybe String+  }++-- Smart constructor for the common case when both fields are not null+mkFooBar :: Int.Int32 -> String -> FooBar+mkFooBar f b = FooBar (Just f) (Just b)++fooBarTable :: Expr.Qualified Expr.TableName+fooBarTable =+  Expr.qualifyTable Nothing (Expr.tableName "foobar")++fooColumn :: Expr.ColumnName+fooColumn =+  Expr.columnName "foo"++fooColumnRef :: Expr.ValueExpression+fooColumnRef =+  Expr.columnReference fooColumn++barColumn :: Expr.ColumnName+barColumn =+  Expr.columnName "bar"++barColumnRef :: Expr.ValueExpression+barColumnRef =+  Expr.columnReference barColumn++orderByFoo :: Expr.OrderByClause+orderByFoo =+  Expr.orderByClause $+    Expr.orderByColumnName fooColumn Expr.ascendingOrder++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)++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 fooBars =+  let+    mkRow fooBar =+      [ nullOr SqlValue.fromInt32 (foo fooBar)+      , nullOr SqlValue.fromText (T.pack <$> bar fooBar)+      ]+  in+    Expr.insertSqlValues (map mkRow fooBars)++nullOr :: (a -> SqlValue.SqlValue) -> Maybe a -> SqlValue.SqlValue+nullOr = maybe SqlValue.sqlNull++withFooBarData ::+  Orville.ConnectionPool ->+  [FooBar] ->+  (Orville.Connection -> IO a) ->+  HH.PropertyT IO a+withFooBarData pool fooBars action =+  MIO.liftIO $+    Conn.withPoolConnection pool $ \connection -> do+      dropAndRecreateTestTable connection++      RawSql.executeVoid connection $+        Expr.insertExpr fooBarTable Nothing (insertFooBarSource fooBars) Nothing++      action connection++dropAndRecreateTestTable :: Orville.Connection -> IO ()+dropAndRecreateTestTable connection = do+  RawSql.executeVoid connection (RawSql.fromString "DROP TABLE IF EXISTS " <> RawSql.toRawSql fooBarTable)+  RawSql.executeVoid connection (RawSql.fromString "CREATE TABLE " <> RawSql.toRawSql fooBarTable <> RawSql.fromString "(foo INTEGER, bar TEXT)")++assertEqualFooBarRows ::+  (HH.MonadTest m, HasCallStack) =>+  [[(Maybe B8.ByteString, SqlValue.SqlValue)]] ->+  [FooBar] ->+  m ()+assertEqualFooBarRows rows fooBars =+  withFrozenCallStack $+    assertEqualSqlRows rows (map encodeFooBar fooBars)++-- SqlValue doesn't have Show or Eq, so use this to compare them in tests+assertEqualSqlRows ::+  (Show a, Eq a, HH.MonadTest m, HasCallStack) =>+  [[(a, SqlValue.SqlValue)]] ->+  [[(a, SqlValue.SqlValue)]] ->+  m ()+assertEqualSqlRows l r =+  withFrozenCallStack $+    sqlRowsToText l === sqlRowsToText r++sqlRowsToText :: [[(a, SqlValue.SqlValue)]] -> [[(a, Either String T.Text)]]+sqlRowsToText = fmap (fmap (\(a, b) -> (a, SqlValue.toText b)))
+ test/Test/Expr/Time.hs view
@@ -0,0 +1,134 @@+module Test.Expr.Time+  ( timeTests+  )+where++import qualified Data.ByteString.Char8 as B8+import Data.Int (Int32)+import qualified Data.Maybe as Maybe+import qualified Data.Text as T+import qualified Data.Time as Time+import Hedgehog ((===))+import qualified Hedgehog as HH+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import qualified Text.Printf as Printf++import qualified Orville.PostgreSQL as Orville+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++timeTests :: Orville.ConnectionPool -> Property.Group+timeTests pool =+  Property.group+    "Expr - Time"+    [ prop_now pool+    , prop_makeInterval pool+    ]++prop_now :: Property.NamedDBProperty+prop_now =+  Property.singletonNamedDBProperty "now()" $ \pool -> do+    let+      sql =+        Expr.queryExpr+          (Expr.selectClause (Expr.selectExpr Nothing))+          ( Expr.selectDerivedColumns+              [ Expr.deriveColumnAs Expr.now (Expr.columnName "result")+              ]+          )+          Nothing++      marshaller =+        Orville.annotateSqlMarshallerEmptyAnnotation $+          Orville.marshallField id (Orville.utcTimestampField "result")++    result <-+      HH.evalIO $+        Orville.runOrville pool $+          Orville.executeAndDecode Orville.SelectQuery sql marshaller++    today <- fmap Time.utctDay (HH.evalIO Time.getCurrentTime)+    fmap Time.utctDay result === [today]++prop_makeInterval :: Property.NamedDBProperty+prop_makeInterval =+  Property.namedDBProperty "make_interval()" $ \pool -> do+    intervalValues <- HH.forAllWith (T.unpack . renderExpectedValue) $ do+      years <- Gen.integral (Range.linear 1 100)+      months <- Gen.integral (Range.linear 1 11)+      weeks <- Gen.integral (Range.linear 1 3)+      days <- Gen.integral (Range.linear 1 6)+      hours <- Gen.integral (Range.linear 1 23)+      minutes <- Gen.integral (Range.linear 1 59)+      seconds <- Gen.integral (Range.linear 1 59)++      pure $+        [ (Expr.years, years)+        , (Expr.months, months)+        , (Expr.weeks, weeks)+        , (Expr.days, days)+        , (Expr.hours, hours)+        , (Expr.minutes, minutes)+        , (Expr.seconds, seconds)+        ]++    let+      intervalExpression =+        Expr.makeInterval $+          map+            (\(arg, value) -> (arg, Expr.valueExpression (SqlValue.fromInt32 value)))+            intervalValues++      sql =+        Expr.queryExpr+          (Expr.selectClause (Expr.selectExpr Nothing))+          ( Expr.selectDerivedColumns+              [ Expr.deriveColumnAs intervalExpression (Expr.columnName "result")+              ]+          )+          Nothing++      marshaller =+        Orville.annotateSqlMarshallerEmptyAnnotation $+          Orville.marshallField id (Orville.unboundedTextField "result")++    result <-+      HH.evalIO $+        Orville.runOrville pool $+          Orville.executeAndDecode Orville.SelectQuery sql marshaller++    result === [renderExpectedValue intervalValues]++renderExpectedValue :: [(Expr.IntervalArgument, Int32)] -> T.Text+renderExpectedValue values =+  let+    valuesByName =+      map+        (\(arg, value) -> (RawSql.toExampleBytes arg, value))+        values++    lookupInterval name =+      Maybe.fromMaybe 0 (lookup (B8.pack name) valuesByName)++    render :: Int32 -> String -> Maybe T.Text+    render value singularName =+      case value of+        0 -> Nothing+        1 -> Just (T.pack (Printf.printf "%d %s" value singularName))+        _ -> Just (T.pack (Printf.printf "%d %ss" value singularName))++    mbTime =+      case (lookupInterval "hours", lookupInterval "mins", lookupInterval "secs") of+        (0, 0, 0) -> Nothing+        (h, m, s) -> Just (T.pack (Printf.printf "%02d:%02d:%02d" h m s))+  in+    T.intercalate (T.pack " ") . Maybe.catMaybes $+      [ render (lookupInterval "years") "year"+      , render (lookupInterval "months") "mon"+      , render ((7 * lookupInterval "weeks") + lookupInterval "days") "day"+      , mbTime+      ]
+ test/Test/Expr/Where.hs view
@@ -0,0 +1,218 @@+module Test.Expr.Where+  ( whereTests+  )+where++import qualified Control.Monad.IO.Class as MIO+import Data.Int (Int32)+import Data.List.NonEmpty (NonEmpty ((:|)))+import qualified Data.Text as T++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, fooColumnRef, insertFooBarSource, mkFooBar)+import qualified Test.Property as Property++whereTests :: Orville.ConnectionPool -> Property.Group+whereTests pool =+  Property.group "Expr - WhereClause" $+    [ prop_noWhereClauseSpecified pool+    , prop_equalsOp pool+    , prop_greaterThanOp pool+    , prop_greaterThanOrEqualsOp pool+    , prop_lessThanOp pool+    , prop_lessThanOrEqualsToOp pool+    , prop_andExpr pool+    , prop_orExpr pool+    , prop_valueIn pool+    , prop_valueNotIn pool+    , prop_tupleIn pool+    , prop_tupleNotIn pool+    ]++prop_noWhereClauseSpecified :: Property.NamedDBProperty+prop_noWhereClauseSpecified =+  whereConditionTest "Returns all rows when where clause is specified" $+    WhereConditionTest+      { whereValuesToInsert = [mkFooBar 1 "ant", mkFooBar 2 "bee", mkFooBar 3 "chihuahua"]+      , whereExpectedQueryResults = [mkFooBar 1 "ant", mkFooBar 2 "bee", mkFooBar 3 "chihuahua"]+      , whereClause = Nothing+      }++prop_equalsOp :: Property.NamedDBProperty+prop_equalsOp =+  whereConditionTest "equalsOp matches exact value" $+    WhereConditionTest+      { whereValuesToInsert = [mkFooBar 1 "ant", mkFooBar 2 "bee", mkFooBar 3 "chihuahua"]+      , whereExpectedQueryResults = [mkFooBar 2 "bee"]+      , whereClause =+          Just . Expr.whereClause $+            Expr.equals fooColumnRef (int32ValueExpr 2)+      }++prop_greaterThanOp :: Property.NamedDBProperty+prop_greaterThanOp =+  whereConditionTest "greaterThanOp matches greater values" $+    WhereConditionTest+      { whereValuesToInsert = [mkFooBar 1 "ant", mkFooBar 2 "bee", mkFooBar 3 "chihuahua"]+      , whereExpectedQueryResults = [mkFooBar 3 "chihuahua"]+      , whereClause =+          Just . Expr.whereClause $+            Expr.greaterThan fooColumnRef (int32ValueExpr 2)+      }++prop_greaterThanOrEqualsOp :: Property.NamedDBProperty+prop_greaterThanOrEqualsOp =+  whereConditionTest "greaterThanOrEqualsOp matches greater or equal values" $+    WhereConditionTest+      { whereValuesToInsert = [mkFooBar 1 "ant", mkFooBar 2 "bee", mkFooBar 3 "chihuahua"]+      , whereExpectedQueryResults = [mkFooBar 2 "bee", mkFooBar 3 "chihuahua"]+      , whereClause =+          Just . Expr.whereClause $+            Expr.greaterThanOrEqualTo fooColumnRef (int32ValueExpr 2)+      }++prop_lessThanOp :: Property.NamedDBProperty+prop_lessThanOp =+  whereConditionTest "lessThanOp matches lesser values" $+    WhereConditionTest+      { whereValuesToInsert = [mkFooBar 1 "ant", mkFooBar 2 "bee", mkFooBar 3 "chihuahua"]+      , whereExpectedQueryResults = [mkFooBar 1 "ant"]+      , whereClause =+          Just . Expr.whereClause $+            Expr.lessThan fooColumnRef (int32ValueExpr 2)+      }++prop_lessThanOrEqualsToOp :: Property.NamedDBProperty+prop_lessThanOrEqualsToOp =+  whereConditionTest "lessThanOrEqualsOp matches lesser or equal values" $+    WhereConditionTest+      { whereValuesToInsert = [mkFooBar 1 "ant", mkFooBar 2 "bee", mkFooBar 3 "chihuahua"]+      , whereExpectedQueryResults = [mkFooBar 1 "ant", mkFooBar 2 "bee"]+      , whereClause =+          Just . Expr.whereClause $+            Expr.lessThanOrEqualTo fooColumnRef (int32ValueExpr 2)+      }++prop_andExpr :: Property.NamedDBProperty+prop_andExpr =+  whereConditionTest "andExpr requires both conditions to be true" $+    WhereConditionTest+      { whereValuesToInsert = [mkFooBar 1 "dog", mkFooBar 2 "dingo", mkFooBar 3 "dog"]+      , whereExpectedQueryResults = [mkFooBar 3 "dog"]+      , whereClause =+          Just . Expr.whereClause $+            Expr.andExpr+              (Expr.equals fooColumnRef (int32ValueExpr 3))+              (Expr.equals barColumnRef (textValueExpr "dog"))+      }++prop_orExpr :: Property.NamedDBProperty+prop_orExpr =+  whereConditionTest "orExpr requires either conditions to be true" $+    WhereConditionTest+      { whereValuesToInsert = [mkFooBar 1 "dog", mkFooBar 2 "dingo", mkFooBar 3 "dog"]+      , whereExpectedQueryResults = [mkFooBar 2 "dingo", mkFooBar 3 "dog"]+      , whereClause =+          Just . Expr.whereClause $+            Expr.orExpr+              (Expr.equals fooColumnRef (int32ValueExpr 3))+              (Expr.equals barColumnRef (textValueExpr "dingo"))+      }++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"]+      , whereExpectedQueryResults = [mkFooBar 1 "dog", mkFooBar 3 "dog"]+      , whereClause =+          Just . Expr.whereClause $+            Expr.valueIn+              barColumnRef+              (textValueExpr "dog" :| [textValueExpr "cat"])+      }++prop_valueNotIn :: Property.NamedDBProperty+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"]+      , whereExpectedQueryResults = [mkFooBar 2 "dingo"]+      , whereClause =+          Just . Expr.whereClause $+            Expr.valueNotIn+              barColumnRef+              (textValueExpr "dog" :| [textValueExpr "cat"])+      }++prop_tupleIn :: Property.NamedDBProperty+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"]+      , whereExpectedQueryResults = [mkFooBar 1 "dog", mkFooBar 2 "dingo"]+      , whereClause =+          Just . Expr.whereClause $+            Expr.tupleIn+              (fooColumnRef :| [barColumnRef])+              ( (int32ValueExpr 1 :| [textValueExpr "dog"])+                  :| [int32ValueExpr 2 :| [textValueExpr "dingo"]]+              )+      }++prop_tupleNotIn :: Property.NamedDBProperty+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"]+      , whereExpectedQueryResults = [mkFooBar 3 "dog"]+      , whereClause =+          Just . Expr.whereClause $+            Expr.tupleNotIn+              (fooColumnRef :| [barColumnRef])+              ( (int32ValueExpr 1 :| [textValueExpr "dog"])+                  :| [int32ValueExpr 2 :| [textValueExpr "dingo"]]+              )+      }++int32ValueExpr :: Int32 -> Expr.ValueExpression+int32ValueExpr =+  Expr.valueExpression . SqlValue.fromInt32++textValueExpr :: String -> Expr.ValueExpression+textValueExpr =+  Expr.valueExpression . SqlValue.fromText . T.pack++data WhereConditionTest = WhereConditionTest+  { whereValuesToInsert :: [FooBar]+  , whereClause :: Maybe Expr.WhereClause+  , whereExpectedQueryResults :: [FooBar]+  }++whereConditionTest :: String -> WhereConditionTest -> Property.NamedDBProperty+whereConditionTest 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 $ whereValuesToInsert test) 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)++          Execution.readRows result++    assertEqualFooBarRows rows (whereExpectedQueryResults test)
+ test/Test/FieldDefinition.hs view
@@ -0,0 +1,414 @@+module Test.FieldDefinition+  ( fieldDefinitionTests+  )+where++import qualified Control.Exception as E+import qualified Data.ByteString.Char8 as B8+import qualified Data.Maybe as Maybe+import qualified Data.String as String+import qualified Data.Text as T+import qualified Data.UUID as UUID+import Hedgehog ((===))+import qualified Hedgehog as HH+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import qualified Orville.PostgreSQL as Orville+import qualified Orville.PostgreSQL.Execution as Execution+import qualified Orville.PostgreSQL.Expr as Expr+import qualified Orville.PostgreSQL.Marshall as Marshall+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 (sqlRowsToText)+import qualified Test.PgGen as PgGen+import qualified Test.Property as Property++fieldDefinitionTests :: Orville.ConnectionPool -> Property.Group+fieldDefinitionTests pool =+  Property.group "FieldDefinition" $+    integerField pool+      <> bigIntegerField pool+      <> doubleField pool+      <> booleanField pool+      <> unboundedTextField pool+      <> boundedTextField pool+      <> fixedTextField pool+      <> textSearchVectorField pool+      <> uuidField pool+      <> dateField pool+      <> utcTimestampField pool+      <> localTimestampField pool+      <> jsonbField pool++integerField :: Orville.ConnectionPool -> [(HH.PropertyName, HH.Property)]+integerField pool =+  testFieldProperties pool "integerField" $+    FieldDefinitionTest+      { roundTripFieldDef = Marshall.integerField "foo"+      , roundTripDefaultValueTests = [RoundTripDefaultTest Marshall.integerDefault]+      , roundTripGen = PgGen.pgInt32+      }++bigIntegerField :: Orville.ConnectionPool -> [(HH.PropertyName, HH.Property)]+bigIntegerField pool =+  testFieldProperties pool "bigIntegerField" $+    FieldDefinitionTest+      { roundTripFieldDef = Marshall.bigIntegerField "foo"+      , roundTripDefaultValueTests = [RoundTripDefaultTest Marshall.bigIntegerDefault]+      , roundTripGen = Gen.integral (Range.linearFrom 0 minBound maxBound)+      }++doubleField :: Orville.ConnectionPool -> [(HH.PropertyName, HH.Property)]+doubleField pool =+  testFieldProperties pool "doubleField" $+    FieldDefinitionTest+      { roundTripFieldDef = Marshall.doubleField "foo"+      , roundTripDefaultValueTests = [RoundTripDefaultTest Marshall.doubleDefault]+      , roundTripGen = PgGen.pgDouble+      }++booleanField :: Orville.ConnectionPool -> [(HH.PropertyName, HH.Property)]+booleanField pool =+  testFieldProperties pool "booleanField" $+    FieldDefinitionTest+      { roundTripFieldDef = Marshall.booleanField "foo"+      , roundTripDefaultValueTests = [RoundTripDefaultTest Marshall.booleanDefault]+      , roundTripGen = Gen.bool+      }++unboundedTextField :: Orville.ConnectionPool -> [(HH.PropertyName, HH.Property)]+unboundedTextField pool =+  testFieldProperties pool "unboundedTextField" $+    FieldDefinitionTest+      { roundTripFieldDef = Marshall.unboundedTextField "foo"+      , roundTripDefaultValueTests = [RoundTripDefaultTest Marshall.textDefault]+      , roundTripGen = PgGen.pgText (Range.constant 0 1024)+      }++boundedTextField :: Orville.ConnectionPool -> [(HH.PropertyName, HH.Property)]+boundedTextField pool =+  testFieldProperties pool "boundedTextField" $+    FieldDefinitionTest+      { roundTripFieldDef = Marshall.boundedTextField "foo" 4+      , roundTripDefaultValueTests = [RoundTripDefaultTest Marshall.textDefault]+      , roundTripGen = PgGen.pgText (Range.constant 0 4)+      }++fixedTextField :: Orville.ConnectionPool -> [(HH.PropertyName, HH.Property)]+fixedTextField pool =+  testFieldProperties pool "fixedTextField" $+    FieldDefinitionTest+      { roundTripFieldDef = Marshall.fixedTextField "foo" 4+      , roundTripDefaultValueTests = [RoundTripDefaultTest Marshall.textDefault]+      , roundTripGen = PgGen.pgText (Range.constant 4 4)+      }++textSearchVectorField :: Orville.ConnectionPool -> [(HH.PropertyName, HH.Property)]+textSearchVectorField pool =+  testFieldProperties pool "textSearchVectorField" $+    FieldDefinitionTest+      { roundTripFieldDef = Marshall.textSearchVectorField "foo"+      , roundTripDefaultValueTests = []+      , roundTripGen = tsVectorGen+      }++uuidField :: Orville.ConnectionPool -> [(HH.PropertyName, HH.Property)]+uuidField pool =+  testFieldProperties pool "uuidField" $+    FieldDefinitionTest+      { roundTripFieldDef = Marshall.uuidField "foo"+      , roundTripDefaultValueTests = []+      , roundTripGen = uuidGen+      }++dateField :: Orville.ConnectionPool -> [(HH.PropertyName, HH.Property)]+dateField pool =+  testFieldProperties pool "dateField" $+    FieldDefinitionTest+      { roundTripFieldDef = Marshall.dateField "foo"+      , roundTripDefaultValueTests =+          [ RoundTripDefaultTest Marshall.dateDefault+          , InsertOnlyDefaultTest Marshall.currentDateDefault+          ]+      , roundTripGen = PgGen.pgDay+      }++utcTimestampField :: Orville.ConnectionPool -> [(HH.PropertyName, HH.Property)]+utcTimestampField pool =+  testFieldProperties pool "utcTimestampField" $+    FieldDefinitionTest+      { roundTripFieldDef = Marshall.utcTimestampField "foo"+      , roundTripDefaultValueTests =+          [ RoundTripDefaultTest Marshall.utcTimestampDefault+          , InsertOnlyDefaultTest Marshall.currentUTCTimestampDefault+          ]+      , roundTripGen = PgGen.pgUTCTime+      }++localTimestampField :: Orville.ConnectionPool -> [(HH.PropertyName, HH.Property)]+localTimestampField pool =+  testFieldProperties pool "localTimestampField" $+    FieldDefinitionTest+      { roundTripFieldDef = Marshall.localTimestampField "foo"+      , roundTripDefaultValueTests =+          [ RoundTripDefaultTest Marshall.localTimestampDefault+          , InsertOnlyDefaultTest Marshall.currentLocalTimestampDefault+          ]+      , roundTripGen = PgGen.pgLocalTime+      }++jsonbField :: Orville.ConnectionPool -> [(HH.PropertyName, HH.Property)]+jsonbField pool =+  testFieldProperties pool "jsonbField" $+    FieldDefinitionTest+      { roundTripFieldDef = Marshall.jsonbField "foo"+      , roundTripDefaultValueTests = []+      , roundTripGen = PgGen.pgJSON+      }++testFieldProperties ::+  (Show a, Eq a) =>+  Orville.ConnectionPool ->+  String ->+  FieldDefinitionTest a ->+  [(HH.PropertyName, HH.Property)]+testFieldProperties pool fieldDefName roundTripTest =+  ( ( String.fromString (fieldDefName <> " - can round trip values (not null)")+    , HH.property $ runRoundTripTest pool roundTripTest+    )+      : ( String.fromString (fieldDefName <> " - can round trip values (nullable)")+        , HH.property $ runNullableRoundTripTest pool roundTripTest+        )+      : ( String.fromString (fieldDefName <> " - cannot insert null values into a not null field")+        , Property.singletonProperty $ runNullCounterExampleTest pool roundTripTest+        )+      : map (testDefaultValueProperties pool fieldDefName roundTripTest) (roundTripDefaultValueTests roundTripTest)+  )++testDefaultValueProperties ::+  (Show a, Eq a) =>+  Orville.ConnectionPool ->+  String ->+  FieldDefinitionTest a ->+  DefaultValueTest a ->+  (HH.PropertyName, HH.Property)+testDefaultValueProperties pool fieldDefName roundTripTest defaultValueTest =+  case defaultValueTest of+    RoundTripDefaultTest mkDefaultValue ->+      ( String.fromString (fieldDefName <> " - can round trip a value inserted via a column default")+      , Property.singletonProperty $+          runDefaultValueFieldDefinitionTest pool roundTripTest mkDefaultValue+      )+    InsertOnlyDefaultTest defaultValue ->+      ( String.fromString (fieldDefName <> " - can insert an insert-only default value")+      , Property.singletonProperty $+          runDefaultValueInsertOnlyTest pool roundTripTest defaultValue+      )++-- This generator generates alphanumeric values currently because of syntax+-- issues with random characters being generated. There is a story to built+-- a better Haskell representation of TextSearchVector, which presumably will+-- help fix this.+tsVectorGen :: HH.Gen T.Text+tsVectorGen = do+  text <- Gen.text (Range.linear 1 1024) Gen.alphaNum+  pure $ T.concat [T.pack "'", text, T.pack "'"]++uuidGen :: HH.Gen UUID.UUID+uuidGen =+  UUID.fromWords+    <$> Gen.word32 Range.linearBounded+    <*> Gen.word32 Range.linearBounded+    <*> Gen.word32 Range.linearBounded+    <*> Gen.word32 Range.linearBounded++data FieldDefinitionTest a = FieldDefinitionTest+  { roundTripFieldDef :: Marshall.FieldDefinition Marshall.NotNull a+  , roundTripDefaultValueTests :: [DefaultValueTest a]+  , roundTripGen :: HH.Gen a+  }++data DefaultValueTest a+  = RoundTripDefaultTest (a -> Marshall.DefaultValue a)+  | InsertOnlyDefaultTest (Marshall.DefaultValue a)++runRoundTripTest :: (Show a, Eq a) => Orville.ConnectionPool -> FieldDefinitionTest a -> HH.PropertyT IO ()+runRoundTripTest pool testCase = do+  let+    fieldDef = roundTripFieldDef testCase++  value <- HH.forAll (roundTripGen testCase)+  rows <- HH.evalIO . Conn.withPoolConnection pool $ \connection -> do+    dropAndRecreateTestTable fieldDef connection++    RawSql.executeVoid connection $+      Expr.insertExpr+        testTable+        Nothing+        (Expr.insertSqlValues [[Marshall.fieldValueToSqlValue fieldDef value]])+        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)++    Execution.readRows result++  let+    roundTripResult =+      case rows of+        [[(_, sqlValue)]] ->+          Marshall.fieldValueFromSqlValue fieldDef sqlValue+        _ ->+          Left ("Expected one row with one value in results, but got: " ++ show (sqlRowsToText rows))++  roundTripResult === Right value++runNullableRoundTripTest :: (Show a, Eq a) => Orville.ConnectionPool -> FieldDefinitionTest a -> HH.PropertyT IO ()+runNullableRoundTripTest pool testCase = do+  let+    fieldDef = Marshall.nullableField (roundTripFieldDef testCase)++  value <-+    HH.forAll $+      Gen.frequency+        [ (1, pure Nothing)+        , (3, Just <$> roundTripGen testCase)+        ]++  HH.cover 1 (String.fromString "Nothing") (Maybe.isNothing value)+  HH.cover 20 (String.fromString "Just") (Maybe.isJust value)++  rows <- HH.evalIO . Conn.withPoolConnection pool $ \connection -> do+    dropAndRecreateTestTable fieldDef connection++    RawSql.executeVoid connection $+      Expr.insertExpr+        testTable+        Nothing+        (Expr.insertSqlValues [[Marshall.fieldValueToSqlValue fieldDef value]])+        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)++    Execution.readRows result++  let+    roundTripResult =+      case rows of+        [[(_, sqlValue)]] ->+          Marshall.fieldValueFromSqlValue fieldDef sqlValue+        _ ->+          Left ("Expected one row with one value in results, but got: " ++ show (sqlRowsToText rows))++  roundTripResult === Right value++runNullCounterExampleTest :: Orville.ConnectionPool -> FieldDefinitionTest a -> HH.PropertyT IO ()+runNullCounterExampleTest pool testCase = do+  result <- HH.evalIO . Conn.withPoolConnection pool $ \connection -> do+    let+      fieldDef = roundTripFieldDef testCase++    E.try $ do+      dropAndRecreateTestTable fieldDef connection++      RawSql.executeVoid connection $+        Expr.insertExpr+          testTable+          Nothing+          (Expr.insertSqlValues [[SqlValue.sqlNull]])+          Nothing++  case result of+    Left err ->+      Conn.sqlExecutionErrorSqlState err === Just (B8.pack "23502")+    Right _ -> do+      HH.footnote "Expected insert query to fail, but it did not"+      HH.failure++runDefaultValueFieldDefinitionTest ::+  (Show a, Eq a) =>+  Orville.ConnectionPool ->+  FieldDefinitionTest a ->+  (a -> Marshall.DefaultValue a) ->+  HH.PropertyT IO ()+runDefaultValueFieldDefinitionTest pool testCase mkDefaultValue = do+  value <- HH.forAll (roundTripGen testCase)++  let+    defaultValue =+      mkDefaultValue value++    fieldDef =+      Marshall.setDefaultValue defaultValue $ roundTripFieldDef testCase++  rows <- HH.evalIO . Conn.withPoolConnection pool $ \connection -> do+    dropAndRecreateTestTable fieldDef connection++    RawSql.executeVoid connection $+      Expr.insertExpr+        testTable+        Nothing+        (RawSql.unsafeSqlExpression "VALUES(DEFAULT)")+        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)++    Execution.readRows result++  let+    roundTripResult =+      case rows of+        [[(_, sqlValue)]] ->+          Marshall.fieldValueFromSqlValue fieldDef sqlValue+        _ ->+          Left ("Expected one row with one value in results, but got: " ++ show (sqlRowsToText rows))++  roundTripResult === Right value++runDefaultValueInsertOnlyTest ::+  Orville.ConnectionPool ->+  FieldDefinitionTest a ->+  Marshall.DefaultValue a ->+  HH.PropertyT IO ()+runDefaultValueInsertOnlyTest pool testCase defaultValue =+  HH.evalIO . Conn.withPoolConnection pool $ \connection -> do+    let+      fieldDef =+        Marshall.setDefaultValue defaultValue $ roundTripFieldDef testCase++    dropAndRecreateTestTable fieldDef connection++    RawSql.executeVoid connection $+      Expr.insertExpr+        testTable+        Nothing+        (RawSql.unsafeSqlExpression "VALUES(DEFAULT)")+        Nothing++testTable :: Expr.Qualified Expr.TableName+testTable =+  Expr.qualifyTable Nothing (Expr.tableName "field_definition_test")++dropAndRecreateTestTable :: Marshall.FieldDefinition nullability a -> Orville.Connection -> IO ()+dropAndRecreateTestTable fieldDef connection = do+  RawSql.executeVoid connection (RawSql.fromString "DROP TABLE IF EXISTS " <> RawSql.toRawSql testTable)++  RawSql.executeVoid connection $+    Expr.createTableExpr testTable [Marshall.fieldColumnDefinition fieldDef] Nothing []
+ test/Test/MarshallError.hs view
@@ -0,0 +1,222 @@+module Test.MarshallError+  ( marshallErrorTests+  )+where++import qualified Control.Exception as E+import qualified Data.ByteString.Char8 as B8+import qualified Data.Set as Set+import qualified Data.Text as T+import Hedgehog ((===))+import qualified Hedgehog as HH+import qualified Hedgehog.Gen as Gen++import qualified Orville.PostgreSQL as Orville+import qualified Orville.PostgreSQL.ErrorDetailLevel as ErrorDetailLevel+import qualified Orville.PostgreSQL.Marshall.MarshallError as MarshallError+import qualified Orville.PostgreSQL.Raw.RawSql as RawSql+import qualified Orville.PostgreSQL.Raw.SqlValue as SqlValue++import qualified Test.Property as Property++marshallErrorTests :: Orville.ConnectionPool -> Property.Group+marshallErrorTests pool =+  Property.group+    "MarshallError"+    [ prop_renderDecodingErrorWithFullDetails+    , prop_renderDecodingErrorWithoutSchemaNames+    , prop_renderDecodingErrorWithoutRowIdValues+    , prop_renderDecodingErrorWithoutNonIdValues+    , prop_renderDecodingErrorWithoutErrorMessage+    , prop_renderMissingErrorDetailsWithFullDetails+    , prop_renderMissingErrorDetailsWithoutSchemaNames+    , prop_showMarshallErrorRaisedFromOrvilleContext pool+    ]++{- |+  Shared example used to test error detail level rendering of decoding errors+  below.++@since 1.0.0.0+-}+exampleDecodingError :: MarshallError.MarshallError+exampleDecodingError =+  MarshallError.MarshallError+    { MarshallError.marshallErrorDetailLevel = ErrorDetailLevel.minimalErrorDetailLevel+    , MarshallError.marshallErrorRowIdentifier = [(B8.pack "foo", SqlValue.fromInt8 1)]+    , MarshallError.marshallErrorDetails =+        MarshallError.DecodingError $+          MarshallError.DecodingErrorDetails+            { MarshallError.decodingErrorValues = [(B8.pack "bar", SqlValue.fromText (T.pack "baz"))]+            , MarshallError.decodingErrorMessage = "Failure"+            }+    }++prop_renderDecodingErrorWithFullDetails :: Property.NamedProperty+prop_renderDecodingErrorWithFullDetails =+  Property.singletonNamedProperty "Render decoding error with full details" $+    let+      rendered =+        MarshallError.renderMarshallError+          ErrorDetailLevel.maximalErrorDetailLevel+          exampleDecodingError+    in+      rendered+        === "Unable to decode row with identifier [foo = 1]: \+            \Unable to decode columns from result set: Failure. \+            \Value(s) that failed to decode: [bar = baz]"++prop_renderDecodingErrorWithoutSchemaNames :: Property.NamedProperty+prop_renderDecodingErrorWithoutSchemaNames =+  Property.singletonNamedProperty "Render decoding error without schema names" $+    let+      rendered =+        MarshallError.renderMarshallError+          ( ErrorDetailLevel.maximalErrorDetailLevel+              { ErrorDetailLevel.includeSchemaNames = False+              }+          )+          exampleDecodingError+    in+      rendered+        === "Unable to decode row with identifier [[REDACTED] = 1]: \+            \Unable to decode columns from result set: Failure. \+            \Value(s) that failed to decode: [[REDACTED] = baz]"++prop_renderDecodingErrorWithoutRowIdValues :: Property.NamedProperty+prop_renderDecodingErrorWithoutRowIdValues =+  Property.singletonNamedProperty "Render decoding error without row id values" $+    let+      rendered =+        MarshallError.renderMarshallError+          ( ErrorDetailLevel.maximalErrorDetailLevel+              { ErrorDetailLevel.includeRowIdentifierValues = False+              }+          )+          exampleDecodingError+    in+      rendered+        === "Unable to decode row with identifier [foo = [REDACTED]]: \+            \Unable to decode columns from result set: Failure. \+            \Value(s) that failed to decode: [bar = baz]"++prop_renderDecodingErrorWithoutNonIdValues :: Property.NamedProperty+prop_renderDecodingErrorWithoutNonIdValues =+  Property.singletonNamedProperty "Render decoding error without non id values" $+    let+      rendered =+        MarshallError.renderMarshallError+          ( ErrorDetailLevel.maximalErrorDetailLevel+              { ErrorDetailLevel.includeNonIdentifierValues = False+              }+          )+          exampleDecodingError+    in+      rendered+        === "Unable to decode row with identifier [foo = 1]: \+            \Unable to decode columns from result set: Failure. \+            \Value(s) that failed to decode: [bar = [REDACTED]]"++prop_renderDecodingErrorWithoutErrorMessage :: Property.NamedProperty+prop_renderDecodingErrorWithoutErrorMessage =+  Property.singletonNamedProperty "Render decoding error without non id values" $+    let+      rendered =+        MarshallError.renderMarshallError+          ( ErrorDetailLevel.maximalErrorDetailLevel+              { ErrorDetailLevel.includeErrorMessage = False+              }+          )+          exampleDecodingError+    in+      rendered+        === "Unable to decode row with identifier [foo = 1]: \+            \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.++@since 1.0.0.0+-}+exampleMissingColumnError :: MarshallError.MarshallError+exampleMissingColumnError =+  MarshallError.MarshallError+    { MarshallError.marshallErrorDetailLevel = ErrorDetailLevel.minimalErrorDetailLevel+    , MarshallError.marshallErrorRowIdentifier = [(B8.pack "foo", SqlValue.fromInt8 1)]+    , MarshallError.marshallErrorDetails =+        MarshallError.MissingColumnError $+          MarshallError.MissingColumnErrorDetails+            { MarshallError.missingColumnName = B8.pack "baz"+            , MarshallError.actualColumnNames = Set.fromList [B8.pack "foo", B8.pack "bar"]+            }+    }++prop_renderMissingErrorDetailsWithFullDetails :: Property.NamedProperty+prop_renderMissingErrorDetailsWithFullDetails =+  Property.singletonNamedProperty "Render missing column error with full details" $+    let+      rendered =+        MarshallError.renderMarshallError+          ErrorDetailLevel.maximalErrorDetailLevel+          exampleMissingColumnError+    in+      rendered+        === "Unable to decode row with identifier [foo = 1]: \+            \Column baz not found in results set. \+            \Actual columns were [bar, foo]"++prop_renderMissingErrorDetailsWithoutSchemaNames :: Property.NamedProperty+prop_renderMissingErrorDetailsWithoutSchemaNames =+  Property.singletonNamedProperty "Render missing column error without schema names" $+    let+      rendered =+        MarshallError.renderMarshallError+          ( ErrorDetailLevel.maximalErrorDetailLevel+              { ErrorDetailLevel.includeSchemaNames = False+              }+          )+          exampleMissingColumnError+    in+      rendered+        === "Unable to decode row with identifier [[REDACTED] = 1]: \+            \Column [REDACTED] not found in results set. \+            \Actual columns were [[REDACTED], [REDACTED]]"++prop_showMarshallErrorRaisedFromOrvilleContext :: Property.NamedDBProperty+prop_showMarshallErrorRaisedFromOrvilleContext =+  Property.namedDBProperty "Showing a MarshallError raised from an Orville context" $ \pool -> do+    errorDetailLevel <- HH.forAll generateErrorDetailLevel++    let+      sql =+        RawSql.fromString "SELECT 1 as id, 'notAnNumber' as number"++      marshaller =+        Orville.annotateSqlMarshaller [Orville.stringToFieldName "id"] $+          Orville.marshallField id (Orville.integerField "number")++      orvilleState =+        Orville.newOrvilleState errorDetailLevel pool++    result <-+      HH.evalIO $ do+        E.try . Orville.runOrvilleWithState orvilleState $ do+          Orville.executeAndDecode Orville.SelectQuery sql marshaller++    case result of+      Right _ -> do+        HH.annotate "Expected decoding result set to fail, but it did not"+        HH.failure+      Left marshallError ->+        show marshallError+          === MarshallError.renderMarshallError errorDetailLevel marshallError++generateErrorDetailLevel :: HH.Gen ErrorDetailLevel.ErrorDetailLevel+generateErrorDetailLevel =+  ErrorDetailLevel.ErrorDetailLevel+    <$> Gen.bool+    <*> Gen.bool+    <*> Gen.bool+    <*> Gen.bool
+ test/Test/PgAssert.hs view
@@ -0,0 +1,373 @@+module Test.PgAssert+  ( assertTableExists+  , assertTableExistsInSchema+  , assertTableDoesNotExist+  , assertTableDoesNotExistInSchema+  , assertSequenceExists+  , assertSequenceExistsInSchema+  , assertSequenceDoesNotExist+  , assertSequenceDoesNotExistInSchema+  , assertRelationHasPgSequence+  , assertColumnNamesEqual+  , assertColumnExists+  , assertColumnDefaultExists+  , assertColumnDefaultMatches+  , assertUniqueConstraintExists+  , assertForeignKeyConstraintExists+  , assertIndexExists+  , ForeignKeyInfo (..)+  )+where++import qualified Control.Monad as Monad+import qualified Control.Monad.IO.Class as MIO+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.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.PgCatalog as PgCatalog+import qualified Orville.PostgreSQL.Raw.RawSql as RawSql++assertTableExists ::+  (HH.MonadTest m, MIO.MonadIO m, HasCallStack) =>+  Orville.ConnectionPool ->+  String ->+  m PgCatalog.RelationDescription+assertTableExists pool =+  assertTableExistsInSchema pool "public"++assertTableDoesNotExist ::+  (HH.MonadTest m, MIO.MonadIO m, HasCallStack) =>+  Orville.ConnectionPool ->+  String ->+  m ()+assertTableDoesNotExist pool =+  assertTableDoesNotExistInSchema pool "public"++assertTableExistsInSchema ::+  (HH.MonadTest m, MIO.MonadIO m, HasCallStack) =>+  Orville.ConnectionPool ->+  String ->+  String ->+  m PgCatalog.RelationDescription+assertTableExistsInSchema pool schemaName tableName =+  assertRelationExistsInSchema pool schemaName tableName PgCatalog.OrdinaryTable++assertTableDoesNotExistInSchema ::+  (HH.MonadTest m, MIO.MonadIO m, HasCallStack) =>+  Orville.ConnectionPool ->+  String ->+  String ->+  m ()+assertTableDoesNotExistInSchema pool schemaName tableName =+  assertRelationDoesNotExistInSchema pool schemaName tableName PgCatalog.OrdinaryTable++assertSequenceExists ::+  (HH.MonadTest m, MIO.MonadIO m, HasCallStack) =>+  Orville.ConnectionPool ->+  String ->+  m PgCatalog.RelationDescription+assertSequenceExists pool =+  assertSequenceExistsInSchema pool "public"++assertSequenceDoesNotExist ::+  (HH.MonadTest m, MIO.MonadIO m, HasCallStack) =>+  Orville.ConnectionPool ->+  String ->+  m ()+assertSequenceDoesNotExist pool =+  assertSequenceDoesNotExistInSchema pool "public"++assertSequenceExistsInSchema ::+  (HH.MonadTest m, MIO.MonadIO m, HasCallStack) =>+  Orville.ConnectionPool ->+  String ->+  String ->+  m PgCatalog.RelationDescription+assertSequenceExistsInSchema pool schemaName sequenceName =+  assertRelationExistsInSchema pool schemaName sequenceName PgCatalog.Sequence++assertSequenceDoesNotExistInSchema ::+  (HH.MonadTest m, MIO.MonadIO m, HasCallStack) =>+  Orville.ConnectionPool ->+  String ->+  String ->+  m ()+assertSequenceDoesNotExistInSchema pool schemaName sequenceName =+  assertRelationDoesNotExistInSchema pool schemaName sequenceName PgCatalog.Sequence++assertRelationHasPgSequence ::+  (HH.MonadTest m, HasCallStack) =>+  PgCatalog.RelationDescription ->+  m PgCatalog.PgSequence+assertRelationHasPgSequence relationDesc =+  case PgCatalog.relationSequence relationDesc of+    Nothing ->+      withFrozenCallStack $ do+        HH.annotate $ "Expected relation to have a PgSequence value, but it did not"+        HH.failure+    Just pgSequence ->+      pure pgSequence++assertRelationExistsInSchema ::+  (HH.MonadTest m, MIO.MonadIO m, HasCallStack) =>+  Orville.ConnectionPool ->+  String ->+  String ->+  PgCatalog.RelationKind ->+  m PgCatalog.RelationDescription+assertRelationExistsInSchema pool schemaName relationName relationKind = do+  dbDesc <-+    MIO.liftIO $+      Orville.runOrville pool $ do+        PgCatalog.describeDatabaseRelations+          [(String.fromString schemaName, String.fromString relationName)]++  case PgCatalog.lookupRelation (String.fromString schemaName, String.fromString relationName) dbDesc of+    Nothing -> do+      withFrozenCallStack $ do+        HH.annotate $ relationName <> " relation not found"+        HH.failure+    Just rel -> do+      PgCatalog.pgClassRelationKind (PgCatalog.relationRecord rel) === relationKind+      pure rel++assertRelationDoesNotExistInSchema ::+  (HH.MonadTest m, MIO.MonadIO m, HasCallStack) =>+  Orville.ConnectionPool ->+  String ->+  String ->+  PgCatalog.RelationKind ->+  m ()+assertRelationDoesNotExistInSchema pool schemaName tableName relationKind = do+  dbDesc <-+    MIO.liftIO $+      Orville.runOrville pool $ do+        PgCatalog.describeDatabaseRelations+          [(String.fromString schemaName, String.fromString tableName)]++  case PgCatalog.lookupRelation (String.fromString schemaName, String.fromString tableName) dbDesc of+    Nothing ->+      pure ()+    Just rel ->+      if PgCatalog.pgClassRelationKind (PgCatalog.relationRecord rel) == relationKind+        then withFrozenCallStack $ do+          HH.annotate $+            tableName+              <> " relation expected to not be present with kind "+              <> show relationKind+              <> ", but it was found"++          HH.failure+        else pure ()++assertColumnNamesEqual ::+  (HH.MonadTest m, HasCallStack) =>+  PgCatalog.RelationDescription ->+  [String] ->+  m ()+assertColumnNamesEqual relationDesc expectedColumns = do+  let+    attributeNames =+      fmap PgCatalog.pgAttributeName+        . filter PgCatalog.isOrdinaryColumn+        . Map.elems+        . PgCatalog.relationAttributes+        $ relationDesc++  withFrozenCallStack $+    List.sort attributeNames === List.sort (map String.fromString expectedColumns)++assertColumnExists ::+  (HH.MonadTest m, HasCallStack) =>+  PgCatalog.RelationDescription ->+  String ->+  m PgCatalog.PgAttribute+assertColumnExists relationDesc columnName = do+  case PgCatalog.lookupAttribute (String.fromString columnName) relationDesc of+    Nothing -> do+      withFrozenCallStack $ do+        HH.annotate $ columnName <> " column not found"+        HH.failure+    Just attr ->+      pure attr++assertColumnDefaultExists ::+  (HH.MonadTest m, HasCallStack) =>+  PgCatalog.RelationDescription ->+  String ->+  m ()+assertColumnDefaultExists relationDesc columnName = do+  attr <- assertColumnExists relationDesc columnName++  let+    actualDefault = PgCatalog.lookupAttributeDefault attr relationDesc++  withFrozenCallStack $+    case actualDefault of+      Nothing -> do+        HH.annotate $ columnName <> " expected to have a default, but it did not"+        HH.failure+      Just _ ->+        pure ()++assertColumnDefaultMatches ::+  (HH.MonadTest m, HasCallStack) =>+  PgCatalog.RelationDescription ->+  String ->+  Maybe (Orville.DefaultValue a) ->+  m ()+assertColumnDefaultMatches relationDesc columnName expectedDefault = do+  attr <- assertColumnExists relationDesc columnName++  let+    actualDefault = PgCatalog.lookupAttributeDefault attr relationDesc++  withFrozenCallStack $+    case (expectedDefault, actualDefault) of+      (Nothing, Nothing) ->+        pure ()+      (Nothing, Just _) -> do+        HH.annotate $ columnName <> " was not expected to have a default, but it did"+        HH.failure+      (Just _, Nothing) -> do+        HH.annotate $ columnName <> " expected to have a default, but it did not"+        HH.failure+      (Just defaultValue, Just pgDefault) ->+        let+          expectedBytes =+            RawSql.toExampleBytes+              . Orville.defaultValueExpression+              $ defaultValue++          actualBytes =+            Enc.encodeUtf8+              . PgCatalog.pgAttributeDefaultExpression+              $ pgDefault+        in+          expectedBytes === actualBytes++assertUniqueConstraintExists ::+  (HH.MonadTest m, HasCallStack) =>+  PgCatalog.RelationDescription ->+  NEL.NonEmpty String ->+  m ()+assertUniqueConstraintExists relationDesc columnNames = do+  let+    attNames = map String.fromString (NEL.toList columnNames)+    constraintMatches constraintDesc =+      and+        [ PgCatalog.pgConstraintType (PgCatalog.constraintRecord constraintDesc) == PgCatalog.UniqueConstraint+        , fmap (map PgCatalog.pgAttributeName) (PgCatalog.constraintKey constraintDesc) == Just attNames+        ]++  Monad.when (not $ isMatchingConstraintPresent constraintMatches relationDesc) $+    withFrozenCallStack $ do+      HH.annotate $ "Unique constraint " <> show (NEL.toList columnNames) <> " not found"+      HH.failure++data ForeignKeyInfo = ForeignKeyInfo+  { foreignKeyInfoReferences :: NEL.NonEmpty (String, String)+  , foreignKeyInfoOnUpdate :: Orville.ForeignKeyAction+  , foreignKeyInfoOnDelete :: Orville.ForeignKeyAction+  }+  deriving (Show, Eq)++assertForeignKeyConstraintExists ::+  (HH.MonadTest m, HasCallStack) =>+  PgCatalog.RelationDescription ->+  ForeignKeyInfo ->+  m ()+assertForeignKeyConstraintExists relationDesc foreignKeyInfo = do+  let+    attNames = map (String.fromString . fst) (NEL.toList $ foreignKeyInfoReferences foreignKeyInfo)+    foreignNames = map (String.fromString . snd) (NEL.toList $ foreignKeyInfoReferences foreignKeyInfo)++    constraintMatches constraintDesc =+      let+        constraintRec = PgCatalog.constraintRecord constraintDesc+      in+        and+          [ PgCatalog.pgConstraintType constraintRec == PgCatalog.ForeignKeyConstraint+          , fmap (map PgCatalog.pgAttributeName) (PgCatalog.constraintKey constraintDesc) == Just attNames+          , fmap (map PgCatalog.pgAttributeName) (PgCatalog.constraintForeignKey constraintDesc) == Just foreignNames+          , PgCatalog.pgConstraintForeignKeyOnUpdateType constraintRec == Just (foreignKeyInfoOnUpdate foreignKeyInfo)+          , PgCatalog.pgConstraintForeignKeyOnDeleteType constraintRec == Just (foreignKeyInfoOnDelete foreignKeyInfo)+          ]++  Monad.when (not $ isMatchingConstraintPresent constraintMatches relationDesc) $+    withFrozenCallStack $ do+      HH.annotate $ "Foreign key constraint " <> show (NEL.toList $ foreignKeyInfoReferences foreignKeyInfo) <> " not found"+      HH.failure++isMatchingConstraintPresent ::+  (PgCatalog.ConstraintDescription -> Bool) ->+  PgCatalog.RelationDescription ->+  Bool+isMatchingConstraintPresent predicate relationDesc =+  List.any+    predicate+    (PgCatalog.relationConstraints relationDesc)++assertIndexExists ::+  (HH.MonadTest m, HasCallStack) =>+  PgCatalog.RelationDescription ->+  Orville.IndexUniqueness ->+  NEL.NonEmpty String ->+  m ()+assertIndexExists relationDesc uniqueness columnNames = do+  let+    expectedMemberNames =+      map (Just . String.fromString) (NEL.toList columnNames)++    memberAttributeName member =+      case member of+        PgCatalog.IndexAttribute attr -> Just $ PgCatalog.pgAttributeName attr+        PgCatalog.IndexExpression -> Nothing++    isUnique =+      case uniqueness of+        Orville.UniqueIndex -> True+        Orville.NonUniqueIndex -> False++    shouldIgnoreConstraintIndex constraint =+      elem+        (PgCatalog.pgConstraintType constraint)+        [ PgCatalog.PrimaryKeyConstraint+        , PgCatalog.UniqueConstraint+        , PgCatalog.ExclusionConstraint+        ]++    constraintIndexesToIgnore =+      map PgCatalog.pgConstraintIndexOid+        . filter shouldIgnoreConstraintIndex+        . map PgCatalog.constraintRecord+        . PgCatalog.relationConstraints+        $ relationDesc++    indexMatches indexDesc =+      and+        [ PgCatalog.pgIndexIsUnique (PgCatalog.indexRecord indexDesc) == isUnique+        , fmap memberAttributeName (PgCatalog.indexMembers indexDesc) == expectedMemberNames+        , not $ (elem (PgCatalog.pgIndexPgClassOid $ PgCatalog.indexRecord indexDesc) constraintIndexesToIgnore)+        ]++  Monad.when (not $ isMatchingIndexPresent indexMatches relationDesc) $+    withFrozenCallStack $ do+      HH.annotate $ show uniqueness <> " " <> show (NEL.toList columnNames) <> " not found"+      HH.failure++isMatchingIndexPresent ::+  (PgCatalog.IndexDescription -> Bool) ->+  PgCatalog.RelationDescription ->+  Bool+isMatchingIndexPresent predicate relationDesc =+  List.any+    predicate+    (PgCatalog.relationIndexes relationDesc)
+ test/Test/PgCatalog.hs view
@@ -0,0 +1,197 @@+module Test.PgCatalog+  ( pgCatalogTests+  )+where++import qualified Control.Monad.IO.Class as MIO+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import qualified Data.String as String+import qualified Data.Text as T+import Hedgehog ((===))+import qualified Hedgehog as HH++import qualified Orville.PostgreSQL as Orville+import qualified Orville.PostgreSQL.PgCatalog as PgCatalog++import qualified Test.Entities.Foo as Foo+import qualified Test.Property as Property+import qualified Test.TestTable as TestTable++pgCatalogTests :: Orville.ConnectionPool -> Property.Group+pgCatalogTests pool =+  Property.group+    "PgCatalog"+    [ prop_queryPgClass pool+    , prop_queryPgAttribute pool+    , prop_queryPgAttributeDefault pool+    , prop_queryPgConstraint pool+    , prop_describeDatabaseRelations pool+    ]++prop_queryPgClass :: Property.NamedDBProperty+prop_queryPgClass =+  Property.singletonNamedDBProperty "Can query the pg_class table to find out about a table" $ \pool -> do+    result <- HH.evalIO . Orville.runOrville pool $ do+      Orville.findFirstEntityBy+        PgCatalog.pgClassTable+        (Orville.where_ $ Orville.fieldEquals PgCatalog.relationNameField pgClass)++    fmap PgCatalog.pgClassRelationName result === Just pgClass+    fmap PgCatalog.pgClassRelationKind result === Just PgCatalog.OrdinaryTable++prop_queryPgAttribute :: Property.NamedDBProperty+prop_queryPgAttribute =+  Property.singletonNamedDBProperty "Can query the pg_attribute table to find out about a column" $ \pool -> do+    maybePgClassRecord <- HH.evalIO . Orville.runOrville pool $ do+      Orville.findFirstEntityBy+        PgCatalog.pgClassTable+        (Orville.where_ $ Orville.fieldEquals PgCatalog.relationNameField pgClass)++    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++    maybePgAttr <- HH.evalIO . Orville.runOrville pool $ do+      Orville.findFirstEntityBy+        PgCatalog.pgAttributeTable+        ( Orville.where_ $+            Orville.andExpr+              (Orville.fieldEquals PgCatalog.attributeRelationOidField pgClassOid)+              (Orville.fieldEquals PgCatalog.attributeNameField relname)+        )++    fmap PgCatalog.pgAttributeName maybePgAttr === Just relname+    fmap PgCatalog.pgAttributeLength maybePgAttr === Just 64++prop_queryPgAttributeDefault :: Property.NamedDBProperty+prop_queryPgAttributeDefault =+  Property.singletonNamedDBProperty "Can query the pg_attrdef table to find out about a default value" $ \pool -> do+    let+      fieldDefWithDefault =+        Orville.setDefaultValue (Orville.integerDefault 0) (Orville.integerField "foo")++      tableDef =+        Orville.mkTableDefinitionWithoutKey+          "test_pg_attrdef_query"+          (Orville.marshallField id fieldDefWithDefault)++    maybePgClassRecord <- HH.evalIO . Orville.runOrville pool $ do+      Orville.withConnection $ \connection ->+        MIO.liftIO $ TestTable.dropAndRecreateTableDef connection tableDef++      Orville.findFirstEntityBy+        PgCatalog.pgClassTable+        (Orville.where_ $ Orville.fieldEquals PgCatalog.relationNameField (String.fromString "test_pg_attrdef_query"))++    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++    defaults <- HH.evalIO . Orville.runOrville pool $ do+      Orville.findEntitiesBy+        PgCatalog.pgAttributeDefaultTable+        (Orville.where_ $ Orville.fieldEquals PgCatalog.attributeDefaultRelationOidField pgClassOid)++    map PgCatalog.pgAttributeDefaultAttributeNumber defaults === [PgCatalog.attributeNumberFromInt16 1]+    map PgCatalog.pgAttributeDefaultExpression defaults === [T.pack "0"]++prop_queryPgConstraint :: Property.NamedDBProperty+prop_queryPgConstraint =+  Property.singletonNamedDBProperty "Can query the pg_constraint table to find out about a constraint" $ \pool -> do+    maybePgClassRecord <- HH.evalIO . Foo.withTable pool $ do+      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++    constraints <- HH.evalIO . Orville.runOrville pool $ do+      Orville.findEntitiesBy+        PgCatalog.pgConstraintTable+        (Orville.where_ $ Orville.fieldEquals PgCatalog.constraintRelationOidField pgClassOid)++    map PgCatalog.pgConstraintType constraints === [PgCatalog.PrimaryKeyConstraint]+    map PgCatalog.pgConstraintKey constraints === [Just [1]]++prop_describeDatabaseRelations :: Property.NamedDBProperty+prop_describeDatabaseRelations =+  Property.singletonNamedDBProperty "Can describe relations from different schemas at once" $ \pool -> do+    let+      relationsToDescribe =+        [ (pgCatalog, pgNamespace)+        , (pgCatalog, pgClass)+        , (informationSchema, tables)+        ]++    desc <- HH.evalIO . Orville.runOrville pool $ do+      PgCatalog.describeDatabaseRelations relationsToDescribe++    Map.keysSet (PgCatalog.databaseRelations desc) === Set.fromList relationsToDescribe++    pgNamespaceDescription <-+      case Map.lookup (pgCatalog, pgNamespace) (PgCatalog.databaseRelations desc) of+        Nothing -> do+          HH.annotate "Expected to find pg_namespace table, but did not"+          HH.failure+        Just description ->+          pure description++    Map.keysSet (PgCatalog.relationAttributes pgNamespaceDescription)+      === Set.fromList+        [ String.fromString "cmax"+        , String.fromString "cmin"+        , String.fromString "ctid"+        , String.fromString "nspacl"+        , String.fromString "nspname"+        , String.fromString "nspowner"+        , String.fromString "oid"+        , String.fromString "tableoid"+        , String.fromString "xmax"+        , String.fromString "xmin"+        ]++pgCatalog :: PgCatalog.NamespaceName+pgCatalog =+  String.fromString "pg_catalog"++informationSchema :: PgCatalog.NamespaceName+informationSchema =+  String.fromString "information_schema"++pgClass :: PgCatalog.RelationName+pgClass =+  String.fromString "pg_class"++pgNamespace :: PgCatalog.RelationName+pgNamespace =+  String.fromString "pg_namespace"++tables :: PgCatalog.RelationName+tables =+  String.fromString "tables"++relname :: PgCatalog.AttributeName+relname =+  String.fromString "relname"++fooRelation :: PgCatalog.RelationName+fooRelation =+  String.fromString+    . Orville.tableIdUnqualifiedNameString+    . Orville.tableIdentifier+    $ Foo.table
+ test/Test/PgGen.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.PgGen+  ( pgText+  , pgDouble+  , pgInt32+  , pgIdentifier+  , pgIdentifierWithPrefix+  , pgUTCTime+  , pgLocalTime+  , pgDay+  , pgJSON+  )+where++import Data.Int (Int32)+import qualified Data.Text as T+import qualified Data.Time as Time+import qualified Hedgehog as HH+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++pgText :: HH.Range Int -> HH.Gen T.Text+pgText range =+  Gen.text range $+    Gen.filter (/= '\NUL') Gen.unicode++pgInt32 :: HH.Gen Int32+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.++  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+-}+pgDouble :: HH.Gen Double+pgDouble = do+  let+    -- We use 14 instead of 15 here to allow for the addinitional power+    -- of 10 that may end up coming from the mantissa, based on the+    -- value of 'maxMantissa' below+    maxExpn =+      truncate (logBase 2 (10 ^ (14 :: Int)) :: Double)++    maxMantissa =+      10++  mantissa <- Gen.integral (Range.linearFrom 0 (-maxMantissa) maxMantissa)+  expn <- Gen.integral (Range.linearFrom 0 (-maxExpn) maxExpn)+  pure . roundExcessPrecisionAfterDecimal 15 $ encodeFloat mantissa expn++roundExcessPrecisionAfterDecimal :: Integer -> Double -> Double+roundExcessPrecisionAfterDecimal maxTotalPrecision double =+  let+    digitsBeforeDecimal =+      decimalDigits (truncate double)++    digitsAfterDecimal =+      maxTotalPrecision - digitsBeforeDecimal++    roundingFactor =+      10.0 ^^ digitsAfterDecimal++    roundDouble =+      fromInteger . round+  in+    if digitsAfterDecimal > 0+      then roundDouble (double * roundingFactor) / roundingFactor+      else double++decimalDigits :: Integer -> Integer+decimalDigits n =+  if abs n < 10+    then 1+    else 1 + decimalDigits (quot n 10)++pgIdentifier :: HH.Gen String+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.++@since 1.0.0.0+-}+pgIdentifierWithPrefix :: String -> Int -> HH.Gen String+pgIdentifierWithPrefix prefix minLength =+  fmap (prefix <>)+    . Gen.string (Range.linear minLength (63 - length prefix))+    . 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.++@since 1.0.0.0+-}+pgIdentifierChars :: [Char]+pgIdentifierChars =+  ['a' .. 'z']+    <> ['A' .. 'Z']+    <> ['0' .. '9']+    <> "{}[]()<>!?:;_~^'%&"++pgUTCTime :: HH.Gen Time.UTCTime+pgUTCTime =+  Time.UTCTime <$> pgDay <*> pgDiffTime++pgLocalTime :: HH.Gen Time.LocalTime+pgLocalTime =+  Time.LocalTime <$> pgDay <*> pgTimeOfDay++pgDay :: HH.Gen Time.Day+pgDay = do+  year <- Gen.integral (Range.linearFrom 2000 0 3000)+  month <- Gen.integral (Range.constant 1 12)+  day <- Gen.integral (Range.constant 1 (Time.gregorianMonthLength year month))++  pure (Time.fromGregorian year month day)++pgTimeOfDay :: HH.Gen Time.TimeOfDay+pgTimeOfDay = fmap Time.timeToTimeOfDay pgDiffTime++pgJSON :: HH.Gen T.Text+pgJSON = do+  let+    alphaNumText :: HH.Range Int -> HH.Gen T.Text+    alphaNumText range =+      Gen.text range $ Gen.filter (/= '\NUL') Gen.alphaNum++  jsonKey <- alphaNumText (Range.constant 0 1024)+  jsonValue <- alphaNumText (Range.constant 0 1024)++  pure $ "{\"" <> jsonKey <> "\": \"" <> jsonValue <> "\"}"++pgDiffTime :: HH.Gen Time.DiffTime+pgDiffTime =+  Time.secondsToDiffTime <$> Gen.integral (Range.constant 0 85399)
+ test/Test/PgTime.hs view
@@ -0,0 +1,32 @@+module Test.PgTime+  ( pgTimeTests+  )+where++import Data.Attoparsec.ByteString (parseOnly)+import qualified Data.String as String+import Data.Time (UTCTime (..), fromGregorian)+import qualified Hedgehog as HH++import qualified Orville.PostgreSQL as Orville+import qualified Orville.PostgreSQL.Raw.PgTime as PgTime++import qualified Test.Property as Property++pgTimeTests :: Orville.ConnectionPool -> Property.Group+pgTimeTests _pool =+  Property.group "PgTime" $+    [+      ( String.fromString "Handles seconds in UTC offset correctly"+      , Property.singletonProperty $+          parseOnly PgTime.utcTime (String.fromString "1971-01-01 00:00:00-00:44:30")+            HH.=== Right (UTCTime (fromGregorian 1971 1 1) (44 * 60 + 30))+      )+    ,+      ( String.fromString "Handles far future"+      , Property.singletonProperty $+          -- https://github.com/postgres/postgres/blob/b5737efea00717173c0cc889ebd115966abd8c8c/src/test/regress/sql/timestamptz.sql#L175+          parseOnly PgTime.utcTime (String.fromString "294276-12-31 23:59:59+00")+            HH.=== Right (UTCTime (fromGregorian 294276 12 31) (23 * 3600 + 59 * 60 + 59))+      )+    ]
+ test/Test/Plan.hs view
@@ -0,0 +1,612 @@+{-# LANGUAGE CPP #-}++#if defined(MIN_VERSION_GLASGOW_HASKELL)+#if MIN_VERSION_GLASGOW_HASKELL(9,0,1,0)+{-# LANGUAGE QualifiedDo #-}+#endif+#endif+module Test.Plan+  ( planTests+  )+where++import qualified Control.Exception as Exception+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.String as String+import Hedgehog ((===))+import qualified Hedgehog as HH+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import qualified Orville.PostgreSQL as Orville+import qualified Orville.PostgreSQL.Plan as Plan+import qualified Orville.PostgreSQL.Plan.Many as Many++#if defined(MIN_VERSION_GLASGOW_HASKELL)+#if MIN_VERSION_GLASGOW_HASKELL(9,0,1,0)+import qualified Orville.PostgreSQL.Plan.Syntax as PlanSyntax+#endif+#endif++import qualified Test.Entities.Foo as Foo+import qualified Test.Entities.FooChild as FooChild+import qualified Test.Property as Property++{- ORMOLU_DISABLE -}+{- disable formatting so fourmolu doesn't go haywire with the cpp within the list -}+planTests :: Orville.ConnectionPool -> Property.Group+planTests pool =+  Property.group "Plan" $+    [ prop_askParam pool+    , prop_findMaybeOne pool+    , prop_findMaybeOneWhere pool+    , prop_findAll pool+    , prop_findAllWhere pool+    , prop_planMany_findMaybeOne pool+    , prop_planMany_findMaybeOneWhere pool+    , prop_planMany_findAll pool+    , prop_planMany_findAllWhere pool+    , prop_planEither pool+    , prop_planMany_planEither pool+    , prop_bindAndUse pool+    , prop_planMany_bindAndUse pool+    , prop_planMany_findOne_dedupesInClauses pool+#if defined(MIN_VERSION_GLASGOW_HASKELL)+#if MIN_VERSION_GLASGOW_HASKELL(9,0,1,0)+    , prop_bindAndUse_qualifiedDo pool+    , prop_planMany_bindAndUse_qualifiedDo pool+#endif+#endif+    , prop_assert pool+    , prop_explain+    ]+{- ORMOLU_ENABLE -}++prop_askParam :: Property.NamedDBProperty+prop_askParam =+  Property.namedDBProperty "askParam returns the plan's parameter" $ \pool -> do+    let+      plan :: Plan.Plan scope Int Int+      plan = Plan.askParam++    inputParam <- HH.forAll $ Gen.integral (Range.constant minBound maxBound)+    resultParam <- MIO.liftIO $ Orville.runOrville pool (Plan.execute plan inputParam)+    resultParam === inputParam++prop_findMaybeOne :: Property.NamedDBProperty+prop_findMaybeOne =+  Property.namedDBProperty "findMaybeOne finds a row where the field matches (if any)" $ \pool -> do+    let+      plan :: Plan.Plan scope Foo.FooName (Maybe Foo.Foo)+      plan = Plan.findMaybeOne Foo.table Foo.fooNameField++    (targetName, foos) <- HH.forAll generateSearchTargetAndSubjects+    maybeResult <-+      Foo.withTable pool $ do+        traverse_ (Orville.insertEntities Foo.table) (NEL.nonEmpty foos)+        Plan.execute plan targetName++    let+      isMatch = Foo.hasName targetName++    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+    let+      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+    results <-+      Foo.withTable pool $ do+        traverse_ (Orville.insertEntities Foo.table) (NEL.nonEmpty foos)+        Plan.execute plan targetNames++    let+      isMatch foo = elem (Foo.fooName foo) targetNames++    coverSearchResultCases isMatch foos++    assertEachManyResult targetNames results $ \targetName maybeFoo ->+      assertMatchIsFromPredicate+        maybeFoo+        (\foo -> Foo.hasName targetName 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+    let+      plan :: Plan.Plan scope Foo.FooName (Maybe Foo.Foo)+      plan =+        Plan.findMaybeOneWhere+          Foo.table+          Foo.fooNameField+          (Orville.fieldGreaterThan Foo.fooAgeField Foo.averageFooAge)++    (targetName, foos) <- HH.forAll generateSearchTargetAndSubjects+    maybeResult <-+      Foo.withTable pool $ do+        traverse_ (Orville.insertEntities Foo.table) (NEL.nonEmpty foos)+        Plan.execute plan targetName++    let+      isMatch foo = Foo.hasName targetName 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+    let+      plan :: Plan.Plan scope [Foo.FooName] (Many.Many Foo.FooName (Maybe Foo.Foo))+      plan =+        Plan.planMany $+          Plan.findMaybeOneWhere+            Foo.table+            Foo.fooNameField+            (Orville.fieldGreaterThan Foo.fooAgeField Foo.averageFooAge)++    (targetNames, foos) <- HH.forAll generateSearchTargetListAndSubjects+    results <-+      Foo.withTable pool $ do+        traverse_ (Orville.insertEntities Foo.table) (NEL.nonEmpty foos)+        Plan.execute plan targetNames++    let+      isMatch foo =+        elem (Foo.fooName foo) targetNames+          && Foo.fooAge foo > Foo.averageFooAge++    coverSearchResultCases isMatch foos++    assertEachManyResult targetNames results $ \targetName maybeFoo ->+      assertMatchIsFromPredicate+        maybeFoo+        (\foo -> Foo.hasName targetName foo && isMatch foo)+        foos++prop_findAll :: Property.NamedDBProperty+prop_findAll =+  Property.namedDBProperty "findAll finds all rows where the field matches" $ \pool -> do+    let+      plan :: Plan.Plan scope Foo.FooName [Foo.Foo]+      plan = Plan.findAll Foo.table Foo.fooNameField++    (targetName, foos) <- HH.forAll generateSearchTargetAndSubjects+    results <-+      Foo.withTable pool $ do+        traverse_ (Orville.insertEntities Foo.table) (NEL.nonEmpty foos)+        Plan.execute plan targetName++    let+      isMatch = Foo.hasName targetName++    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+    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+    results <-+      Foo.withTable pool $ do+        traverse_ (Orville.insertEntities Foo.table) (NEL.nonEmpty foos)+        Plan.execute plan targetNames++    let+      isMatch foo = elem (Foo.fooName foo) targetNames++    coverSearchResultCases isMatch foos+    assertEachManyResult targetNames results $ \targetName foundFoos ->+      assertAllMatchesFound Foo.fooId foundFoos (\foo -> Foo.hasName targetName foo && isMatch foo) foos++prop_findAllWhere :: Property.NamedDBProperty+prop_findAllWhere =+  Property.namedDBProperty "findAllWhere finds all rows where the field matches, with the given condition" $ \pool -> do+    let+      plan :: Plan.Plan scope Foo.FooName [Foo.Foo]+      plan =+        Plan.findAllWhere+          Foo.table+          Foo.fooNameField+          (Orville.fieldGreaterThan Foo.fooAgeField Foo.averageFooAge)++    (targetName, foos) <- HH.forAll generateSearchTargetAndSubjects+    results <-+      Foo.withTable pool $ do+        traverse_ (Orville.insertEntities Foo.table) (NEL.nonEmpty foos)+        Plan.execute plan targetName++    let+      isMatch foo = Foo.hasName targetName 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+    let+      plan :: Plan.Plan scope [Foo.FooName] (Many.Many Foo.FooName [Foo.Foo])+      plan =+        Plan.planMany $+          Plan.findAllWhere+            Foo.table+            Foo.fooNameField+            (Orville.fieldGreaterThan Foo.fooAgeField Foo.averageFooAge)++    (targetNames, foos) <- HH.forAll generateSearchTargetListAndSubjects+    results <-+      Foo.withTable pool $ do+        traverse_ (Orville.insertEntities Foo.table) (NEL.nonEmpty foos)+        Plan.execute plan targetNames++    let+      isMatch foo = elem (Foo.fooName foo) targetNames && Foo.fooAge foo > Foo.averageFooAge++    coverSearchResultCases isMatch foos+    assertEachManyResult targetNames results $ \targetName foundFoos ->+      assertAllMatchesFound Foo.fooId foundFoos (\foo -> Foo.hasName targetName 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+    let+      plan :: Plan.Plan scope (Either Foo.FooId Foo.FooName) Foo.Foo+      plan =+        either id id+          <$> Plan.planEither+            (Plan.findOne Foo.table Foo.fooIdField)+            (Plan.findOne Foo.table Foo.fooNameField)++    foo <- HH.forAll Foo.generate+    param <-+      HH.forAll . Gen.element $+        [ Left (Foo.fooId foo)+        , Right (Foo.fooName foo)+        ]++    foundFoo <-+      Foo.withTable pool $ do+        _ <- Orville.insertEntity Foo.table foo+        Plan.execute plan param++    foundFoo === foo++prop_planMany_planEither :: Property.NamedDBProperty+prop_planMany_planEither =+  Property.namedDBProperty "(planMany planEither) executes either the right and left plans with appropriate inputs" $ \pool -> do+    let+      plan :: Plan.Plan scope [Either Foo.FooId Foo.FooName] (Many.Many (Either Foo.FooId Foo.FooName) Foo.Foo)+      plan =+        Plan.planMany $+          either id id+            <$> Plan.planEither+              (Plan.findOne Foo.table Foo.fooIdField)+              (Plan.findOne Foo.table Foo.fooNameField)++    foos <- HH.forAll $ Foo.generateList (Range.linear 0 10)++    let+      pickInput :: Foo.Foo -> HH.PropertyT IO (Either Foo.FooId Foo.FooName)+      pickInput foo =+        HH.forAll . Gen.element $+          [ Left (Foo.fooId foo)+          , Right (Foo.fooName foo)+          ]++    params <- traverse pickInput foos++    foundFoos <-+      Foo.withTable pool $ do+        traverse_ (Orville.insertEntities Foo.table) (NEL.nonEmpty foos)+        Plan.execute plan params++    assertEachManyResult params foundFoos $ \input foo ->+      case input of+        Left fooId ->+          Foo.fooId foo === fooId+        Right fooName ->+          Foo.fooName foo === fooName++prop_bindAndUse :: Property.NamedDBProperty+prop_bindAndUse =+  Property.namedDBProperty "bind/use allows caller to use plan output as input for another plan" $ \pool -> do+    let+      plan :: Plan.Plan scope Foo.FooName (Foo.Foo, [FooChild.FooChild])+      plan =+        Plan.bind (Plan.findOne Foo.table Foo.fooNameField) $ \foo ->+          let+            fooId = Foo.fooId <$> foo+          in+            (,)+              <$> Plan.use foo+              <*> Plan.using fooId (Plan.findAll FooChild.table FooChild.fooChildFooIdField)++    foo <- HH.forAll Foo.generate+    fooChild <- HH.forAll $ FooChild.generate [foo]++    result <-+      FooChild.withTables pool $ do+        _ <- Orville.insertEntity Foo.table foo+        _ <- Orville.insertEntity FooChild.table fooChild+        Plan.execute plan (Foo.fooName foo)++    result === (foo, [fooChild])++prop_planMany_bindAndUse :: Property.NamedDBProperty+prop_planMany_bindAndUse =+  Property.namedDBProperty "(planMany bind/use) allows caller to use plan output as input for another plan" $ \pool -> do+    let+      plan :: Plan.Plan scope [Foo.FooName] (Many.Many Foo.FooName (Foo.Foo, [FooChild.FooChild]))+      plan =+        Plan.planMany $+          Plan.bind (Plan.findOne Foo.table Foo.fooNameField) $ \foo ->+            let+              fooId = Foo.fooId <$> foo+            in+              (,)+                <$> Plan.use foo+                <*> Plan.using fooId (Plan.findAll FooChild.table FooChild.fooChildFooIdField)++    allFoos <- HH.forAll $ Foo.generateList (Range.linear 1 5)+    allChildren <- HH.forAll $ FooChild.generateList (Range.linear 0 20) allFoos++    let+      allFooNames = Foo.fooName <$> allFoos++    results <-+      FooChild.withTables pool $ do+        traverse_ (Orville.insertEntities Foo.table) (NEL.nonEmpty allFoos)+        traverse_ (Orville.insertEntities FooChild.table) (NEL.nonEmpty allChildren)+        Plan.execute plan allFooNames++    assertEachManyResult allFooNames results $ \fooName (foo, children) -> do+      Foo.fooName foo === fooName+      assertAllMatchesFound FooChild.fooChildId children (FooChild.isChildOf foo) allChildren++prop_planMany_findOne_dedupesInClauses :: Property.NamedDBProperty+prop_planMany_findOne_dedupesInClauses =+  Property.singletonNamedDBProperty "planMany/findOne dedupes in clause to avoid PostgreSQL parameter limit" $ \pool -> do+    let+      plan :: Plan.Plan scope [Foo.FooId] (Many.Many Foo.FooId Foo.Foo)+      plan =+        Plan.planMany (Plan.findOne Foo.table Foo.fooIdField)++    unsavedFoo <- HH.forAll Foo.generate++    results <-+      FooChild.withTables pool $ do+        savedFoo <- Orville.insertAndReturnEntity Foo.table unsavedFoo+        let+          fooIds =+            replicate 65536 (Foo.fooId savedFoo)++        Plan.execute plan fooIds++    length (Many.elems results) === 65536++#if defined(MIN_VERSION_GLASGOW_HASKELL)+#if MIN_VERSION_GLASGOW_HASKELL(9,0,1,0)+prop_bindAndUse_qualifiedDo :: Property.NamedDBProperty+prop_bindAndUse_qualifiedDo =+  Property.namedDBProperty "bind/use allows caller to use plan output as input for another plan (QualifiedDo version)" $ \pool -> do+    let plan :: Plan.Plan scope Foo.FooName (Foo.Foo, [FooChild.FooChild])+        plan = PlanSyntax.do+          foo <- Plan.findOne Foo.table Foo.fooNameField++          let fooId = Foo.fooId <$> foo++          children <-+            Plan.using fooId $+              Plan.findAll FooChild.table FooChild.fooChildFooIdField++          (,)+            <$> Plan.use foo+            <*> Plan.use children++    foo <- HH.forAll Foo.generate+    fooChild <- HH.forAll $ FooChild.generate [foo]++    result <-+      FooChild.withTables pool $ do+        _ <- Orville.insertEntity Foo.table foo+        _ <- Orville.insertEntity FooChild.table fooChild+        Plan.execute plan (Foo.fooName foo)++    result === (foo, [fooChild])++prop_planMany_bindAndUse_qualifiedDo :: Property.NamedDBProperty+prop_planMany_bindAndUse_qualifiedDo =+  Property.namedDBProperty "(planMany bind/use) allows caller to use plan output as input for another plan (QualifiedDo version)" $ \pool -> do+    let plan :: Plan.Plan scope [Foo.FooName] (Many.Many Foo.FooName (Foo.Foo, [FooChild.FooChild]))+        plan =+          Plan.planMany $ PlanSyntax.do+            foo <- Plan.findOne Foo.table Foo.fooNameField++            let fooId = Foo.fooId <$> foo++            children <-+              Plan.using fooId $+                Plan.findAll FooChild.table FooChild.fooChildFooIdField++            (,)+              <$> Plan.use foo+              <*> Plan.use children++    allFoos <- HH.forAll $ Foo.generateList (Range.linear 1 5)+    allChildren <- HH.forAll $ FooChild.generateList (Range.linear 0 20) allFoos++    let allFooNames = Foo.fooName <$> allFoos++    results <-+      FooChild.withTables pool $ do+        traverse_ (Orville.insertEntities Foo.table) (NEL.nonEmpty allFoos)+        traverse_ (Orville.insertEntities FooChild.table) (NEL.nonEmpty allChildren)+        Plan.execute plan allFooNames++    assertEachManyResult allFooNames results $ \fooName (foo, children) -> do+      Foo.fooName foo === fooName+      assertAllMatchesFound FooChild.fooChildId children (FooChild.isChildOf foo) allChildren+#endif+#endif++prop_assert :: Property.NamedDBProperty+prop_assert =+  Property.namedDBProperty "assert raises an AssertionError in IO" $ \pool -> do+    let+      plan :: Plan.Plan scope (Either String ()) ()+      plan =+        Plan.assert (\_ value -> value) Plan.askParam++    input <- HH.forAll $ Gen.element [Left "Test Error", Right ()]+    result <- MIO.liftIO $ Exception.try $ Orville.runOrville pool (Plan.execute plan input)+    Either.isLeft (result :: Either Plan.AssertionFailed ()) === Either.isLeft input++prop_explain :: Property.NamedProperty+prop_explain =+  Property.namedProperty "explain shows the SQL steps that will be executed" $ do+    let+      plan :: Plan.Plan scope Foo.FooName [FooChild.FooChild]+      plan =+        Plan.chain+          (Plan.findOne Foo.table Foo.fooNameField)+          (Plan.focusParam Foo.fooId $ Plan.findAll FooChild.table FooChild.fooChildFooIdField)++      explanation =+        Plan.explain plan++    explanation+      === [ "SELECT \"name\",\"id\",\"name\",\"age\" FROM \"foo\" WHERE (\"name\") = ($1)"+          , "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.++@since 1.0.0.0+-}+generateSearchTargetAndSubjects :: HH.Gen (Foo.FooName, [Foo.Foo])+generateSearchTargetAndSubjects = do+  targetName <- Foo.generateFooName++  let+    generatePossibleTargetFoo =+      Gen.choice+        [ Foo.generateFooWithName targetName+        , Foo.generate+        ]++  foos <- Foo.generateListUsing (Range.linear 0 5) generatePossibleTargetFoo+  pure (targetName, foos)++{- |+  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 = do+  targetNames <- Gen.list (Range.linear 0 5) Foo.generateFooName++  let+    generatePossibleTargetFoo =+      Gen.choice (Foo.generate : fmap Foo.generateFooWithName targetNames)++  foos <- Foo.generateListUsing (Range.linear 0 5) generatePossibleTargetFoo+  pure (targetNames, 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.++@since 1.0.0.0+-}+coverSearchResultCases :: HH.MonadTest m => (a -> Bool) -> [a] -> m ()+coverSearchResultCases predicate subjects = do+  HH.cover 1 (String.fromString "no search subjects") (null subjects)+  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.++@since 1.0.0.0+-}+assertMatchIsFromPredicate ::+  (HH.MonadTest m, Eq entity) =>+  Maybe entity ->+  (entity -> Bool) ->+  [entity] ->+  m ()+assertMatchIsFromPredicate maybeEntity predicate subjects =+  case maybeEntity of+    Nothing ->+      HH.assert (not $ any predicate subjects)+    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.++@since 1.0.0.0+-}+assertAllMatchesFound ::+  (HH.MonadTest m, Ord key, Eq entity, Show entity) =>+  -- | Key value to sort on to eliminate order dependencies+  (entity -> key) ->+  -- | the actual matches+  [entity] ->+  -- | the predicate to use for matching+  (entity -> Bool) ->+  -- | the full search space+  [entity] ->+  m ()+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.++@since 1.0.0.0+-}+assertEachManyResult ::+  (Show key, HH.MonadTest m) =>+  [key] ->+  Many.Many key value ->+  (key -> value -> m ()) ->+  m ()+assertEachManyResult expectedKeys manyValues assertion = do+  let+    checkResult key =+      case Many.lookup key manyValues of+        Left Many.NotAKey -> do+          HH.footnote $ "Expected " <> show key <> " to be a key in results, but it was not"+          HH.failure+        Right value ->+          assertion key value++  traverse_ checkResult expectedKeys
+ test/Test/PostgreSQLAxioms.hs view
@@ -0,0 +1,126 @@+module Test.PostgreSQLAxioms+  ( postgreSQLAxiomTests+  )+where++import qualified Control.Exception.Safe as ExSafe+import qualified Control.Monad.IO.Class as MIO+import qualified Data.ByteString.Char8 as B8+import Hedgehog ((===))+import qualified Hedgehog as HH++import qualified Orville.PostgreSQL as Orville+import qualified Orville.PostgreSQL.Marshall.SqlType as SqlType+import qualified Orville.PostgreSQL.Raw.Connection as Conn+import qualified Orville.PostgreSQL.Raw.RawSql as RawSql+import qualified Test.Property as Property++postgreSQLAxiomTests :: Orville.ConnectionPool -> Property.Group+postgreSQLAxiomTests pool =+  Property.group+    "PostgreSQL Axioms"+    [ prop_smallIntegerBounds pool+    , prop_integerBounds pool+    , prop_bigIntegerBounds pool+    ]++prop_smallIntegerBounds :: Property.NamedDBProperty+prop_smallIntegerBounds =+  Property.singletonNamedDBProperty "smallinteger bounds match Haskell Int16" $ \pool -> do+    assertPostgreSQLMinValueMatchesHaskell pool SqlType.smallInteger+    assertPostgreSQLMaxValueMatchesHaskell pool SqlType.smallInteger++prop_integerBounds :: Property.NamedDBProperty+prop_integerBounds =+  Property.singletonNamedDBProperty "integer bounds match Haskell Int32" $ \pool -> do+    assertPostgreSQLMinValueMatchesHaskell pool SqlType.integer+    assertPostgreSQLMaxValueMatchesHaskell pool SqlType.integer++prop_bigIntegerBounds :: Property.NamedDBProperty+prop_bigIntegerBounds =+  Property.singletonNamedDBProperty "bigInteger bounds match Haskell Int64" $ \pool -> do+    assertPostgreSQLMinValueMatchesHaskell pool SqlType.bigInteger+    assertPostgreSQLMaxValueMatchesHaskell pool SqlType.bigInteger++assertPostgreSQLMinValueMatchesHaskell ::+  (Eq a, Show a, Bounded a, HH.MonadTest m, MIO.MonadIO m, ExSafe.MonadCatch m) =>+  Orville.ConnectionPool ->+  SqlType.SqlType a ->+  m ()+assertPostgreSQLMinValueMatchesHaskell pool sqlType = do+  -- First check that the min value can be selected via PostgreSQL+  result <- HH.evalEitherM $ selectValue pool minBound sqlType+  result === minBound++  -- Then check that minvalue - 1 gives a numeric overflow error, verifying that+  -- the min value haskell is, in fact, the minimum value in PostgreSQL+  err <- evalEitherMLeft $ selectValueWithModifier pool minBound (RawSql.fromString "-1") sqlType+  Conn.sqlExecutionErrorSqlState err === Just (B8.pack "22003")++assertPostgreSQLMaxValueMatchesHaskell ::+  (Eq a, Show a, Bounded a, HH.MonadTest m, MIO.MonadIO m, ExSafe.MonadCatch m) =>+  Orville.ConnectionPool ->+  SqlType.SqlType a ->+  m ()+assertPostgreSQLMaxValueMatchesHaskell pool sqlType = do+  -- First check that the max value can be selected via PostgreSQL+  result <- HH.evalEitherM $ selectValue pool maxBound sqlType+  result === maxBound++  -- Then check that maxvalue - 1 gives a numeric overflow error, verifying that+  -- the max value haskell is, in fact, the maximum value in PostgreSQL+  err <- evalEitherMLeft $ selectValueWithModifier pool maxBound (RawSql.fromString "+1") sqlType+  Conn.sqlExecutionErrorSqlState err === Just (B8.pack "22003")++evalEitherMLeft :: (HH.MonadTest m, ExSafe.MonadCatch m, Show b) => m (Either a b) -> m a+evalEitherMLeft =+  let+    swap :: Either a b -> Either b a+    swap (Left a) = Right a+    swap (Right b) = Left b+  in+    HH.evalEitherM . fmap swap++selectValue ::+  (HH.MonadTest m, MIO.MonadIO m) =>+  Orville.ConnectionPool ->+  a ->+  SqlType.SqlType a ->+  m (Either Conn.SqlExecutionError a)+selectValue pool inputValue sqlType =+  selectValueWithModifier pool inputValue mempty sqlType++selectValueWithModifier ::+  (HH.MonadTest m, MIO.MonadIO m) =>+  Orville.ConnectionPool ->+  a ->+  RawSql.RawSql ->+  SqlType.SqlType a ->+  m (Either Conn.SqlExecutionError a)+selectValueWithModifier pool inputValue modifier sqlType = do+  let+    selectOne =+      RawSql.fromString "SELECT (("+        <> RawSql.parameter (SqlType.sqlTypeToSql sqlType inputValue)+        <> modifier+        <> RawSql.fromString ")"+        <> RawSql.fromString "::"+        <> RawSql.toRawSql (SqlType.sqlTypeExpr sqlType)+        <> RawSql.fromString ") as result"++    marshaller =+      Orville.annotateSqlMarshallerEmptyAnnotation $+        Orville.marshallField id (Orville.fieldOfType sqlType "result")++  errOrResults <-+    HH.evalIO . Orville.runOrville pool . ExSafe.try $+      Orville.executeAndDecode Orville.SelectQuery selectOne marshaller++  case errOrResults of+    Left err ->+      pure (Left err)+    Right [outputValue] ->+      pure (Right outputValue)+    Right results -> do+      HH.annotate $ "Expected exactly one result row from query, but got " <> show (length results)+      HH.failure
+ test/Test/Property.hs view
@@ -0,0 +1,106 @@+module Test.Property+  ( NamedProperty+  , namedProperty+  , singletonNamedProperty+  , NamedDBProperty+  , namedDBProperty+  , singletonNamedDBProperty+  , singletonProperty+  , Group (..)+  , group+  , checkGroups+  , checkGroup+  , allPassed+  )+where++import qualified Control.Monad as Monad+import qualified Data.String as String+import qualified GHC.Stack as CallStack+import qualified Hedgehog as HH+import qualified Hedgehog.Internal.Config as Config+import qualified Hedgehog.Internal.Property as Property+import qualified Hedgehog.Internal.Report as Report+import qualified Hedgehog.Internal.Runner as Runner+import qualified Hedgehog.Internal.Seed as Seed++import qualified Orville.PostgreSQL as Orville++type NamedProperty = (HH.PropertyName, HH.Property)+type NamedDBProperty = Orville.ConnectionPool -> NamedProperty++namedProperty :: String -> HH.PropertyT IO () -> NamedProperty+namedProperty nameString propertyT =+  (String.fromString nameString, HH.property propertyT)++singletonNamedProperty ::+  String ->+  HH.PropertyT IO () ->+  NamedProperty+singletonNamedProperty nameString property =+  HH.withTests 1 <$> namedProperty nameString property++namedDBProperty ::+  String ->+  (Orville.ConnectionPool -> HH.PropertyT IO ()) ->+  NamedDBProperty+namedDBProperty nameString dbProperty pool =+  namedProperty nameString (dbProperty pool)++singletonNamedDBProperty ::+  String ->+  (Orville.ConnectionPool -> HH.PropertyT IO ()) ->+  NamedDBProperty+singletonNamedDBProperty nameString dbProperty pool =+  HH.withTests 1 <$> namedProperty nameString (dbProperty pool)++singletonProperty :: CallStack.HasCallStack => HH.PropertyT IO () -> HH.Property+singletonProperty = HH.withTests 1 . HH.property++data Group = Group+  { groupName :: String+  , groupProperties :: [NamedProperty]+  }++group :: String -> [NamedProperty] -> Group+group = Group++checkGroups :: Foldable f => f Group -> IO Report.Summary+checkGroups groups = do+  useColor <- Config.resolveColor Nothing+  summary <- foldMap (checkGroup useColor) groups+  putStrLn =<< Report.renderSummary useColor summary+  pure summary++checkGroup :: Config.UseColor -> Group -> IO Report.Summary+checkGroup useColor propGroup = do+  let+    name = groupName propGroup+    properties = groupProperties propGroup++  putStrLn $ "• " <> name <> " : " <> show (length properties) <> " properties"+  foldMap (checkProperty useColor) properties++checkProperty :: Config.UseColor -> NamedProperty -> IO Report.Summary+checkProperty useColor (name, prop) = do+  seed <- Seed.random+  report <-+    Runner.checkReport+      (Property.propertyConfig prop)+      0+      seed+      (Property.propertyTest prop)+      (\_ -> pure ())++  let+    result = Report.reportStatus report++  Monad.when (result /= Report.OK) $ do+    putStrLn =<< Report.renderResult useColor (Just name) report++  pure $ Report.fromResult result++allPassed :: Report.Summary -> Bool+allPassed summary =+  Report.summaryFailed summary == 0+    && Report.summaryGaveUp summary == 0
+ test/Test/RawSql.hs view
@@ -0,0 +1,150 @@+module Test.RawSql+  ( rawSqlTests+  )+where++import qualified Data.ByteString.Char8 as B8+import Data.Functor.Identity (runIdentity)+import qualified Data.Text as T+import Hedgehog ((===))+import qualified Hedgehog as HH++import qualified Orville.PostgreSQL as Orville+import qualified Orville.PostgreSQL.Raw.Connection as Conn+import qualified Orville.PostgreSQL.Raw.PgTextFormatValue as PgTextFormatValue+import qualified Orville.PostgreSQL.Raw.RawSql as RawSql+import qualified Orville.PostgreSQL.Raw.SqlValue as SqlValue++import qualified Test.Property as Property++rawSqlTests :: Orville.ConnectionPool -> Property.Group+rawSqlTests pool =+  Property.group+    "RawSql"+    [ prop_concatenatesSQLStrings+    , prop_tracksPlaceholders+    , prop_escapesStringLiteralsForExamples+    , prop_escapesIdentifiersForExamples+    , prop_escapesStringLiteralsForConnections pool+    , prop_escapesIdentifiersForConnections pool+    ]++prop_concatenatesSQLStrings :: Property.NamedProperty+prop_concatenatesSQLStrings =+  Property.singletonNamedProperty "Builds concatenated sql from strings" $ do+    let+      rawSql =+        RawSql.fromString "SELECT * "+          <> RawSql.fromString "FROM foo "+          <> RawSql.fromString "WHERE id = 1"++      expectedBytes =+        B8.pack "SELECT * FROM foo WHERE id = 1"++      (actualBytes, actualParams) =+        runIdentity $+          RawSql.toBytesAndParams RawSql.exampleQuoting rawSql++    actualBytes === expectedBytes+    actualParams === []++prop_tracksPlaceholders :: Property.NamedProperty+prop_tracksPlaceholders =+  Property.singletonNamedProperty "Tracks value placeholders in concatenated order" $ do+    let+      rawSql =+        RawSql.fromString "SELECT * "+          <> RawSql.fromString "FROM foo "+          <> RawSql.fromString "WHERE id = "+          <> RawSql.parameter (SqlValue.fromInt32 1)+          <> RawSql.fromString " AND "+          <> RawSql.fromString "bar IN ("+          <> RawSql.intercalate RawSql.comma bars+          <> RawSql.fromString ")"++      bars =+        map+          RawSql.parameter+          [ SqlValue.fromText (T.pack "pants")+          , SqlValue.fromText (T.pack "cheese")+          ]++      expectedBytes =+        B8.pack "SELECT * FROM foo WHERE id = $1 AND bar IN ($2,$3)"++      expectedParams =+        [ Just . PgTextFormatValue.fromByteString . B8.pack $ "1"+        , Just . PgTextFormatValue.fromByteString . B8.pack $ "pants"+        , Just . PgTextFormatValue.fromByteString . B8.pack $ "cheese"+        ]++      (actualBytes, actualParams) =+        runIdentity $+          RawSql.toBytesAndParams RawSql.exampleQuoting rawSql++    actualBytes === expectedBytes+    actualParams === expectedParams++prop_escapesStringLiteralsForExamples :: Property.NamedProperty+prop_escapesStringLiteralsForExamples =+  Property.singletonNamedProperty "Escapes and quotes string literals for examples" $ do+    let+      rawSql =+        RawSql.stringLiteral (B8.pack "Hello W'orld")++      expectedBytes =+        B8.pack "'Hello W''orld'"++      actualBytes =+        RawSql.toExampleBytes rawSql++    actualBytes === expectedBytes++prop_escapesIdentifiersForExamples :: Property.NamedProperty+prop_escapesIdentifiersForExamples =+  Property.singletonNamedProperty "Escapes and quotes identifiers for examples" $ do+    let+      rawSql =+        RawSql.identifier (B8.pack "Hello W\"orld")++      expectedBytes =+        B8.pack "\"Hello W\"\"orld\""++      actualBytes =+        RawSql.toExampleBytes rawSql++    actualBytes === expectedBytes++prop_escapesStringLiteralsForConnections :: Property.NamedDBProperty+prop_escapesStringLiteralsForConnections =+  Property.singletonNamedDBProperty "Escapes and quotes string literals for connections" $ \pool -> do+    let+      rawSql =+        RawSql.stringLiteral (B8.pack "Hello W'orld")++      expectedBytes =+        B8.pack "'Hello W''orld'"++    (actualBytes, _) <-+      HH.evalIO $+        Conn.withPoolConnection pool $ \conn ->+          RawSql.toBytesAndParams (RawSql.connectionQuoting conn) rawSql++    actualBytes === expectedBytes++prop_escapesIdentifiersForConnections :: Property.NamedDBProperty+prop_escapesIdentifiersForConnections =+  Property.singletonNamedDBProperty "Escapes and quotes identifiers for connections" $ \pool -> do+    let+      rawSql =+        RawSql.identifier (B8.pack "Hello W\"orld")++      expectedBytes =+        B8.pack "\"Hello W\"\"orld\""++    (actualBytes, _) <-+      HH.evalIO $+        Conn.withPoolConnection pool $ \conn ->+          RawSql.toBytesAndParams (RawSql.connectionQuoting conn) rawSql++    actualBytes === expectedBytes
+ test/Test/ReservedWords.hs view
@@ -0,0 +1,36 @@+module Test.ReservedWords+  ( reservedWordsTests+  )+where++import qualified Control.Monad.IO.Class as MIO+import qualified Data.String as String+import qualified Hedgehog as HH++import qualified Orville.PostgreSQL as Orville+import qualified Orville.PostgreSQL.Raw.Connection as Conn++import qualified Test.Entities.User as User+import qualified Test.Property as Property+import qualified Test.TestTable as TestTable++reservedWordsTests :: Orville.ConnectionPool -> Property.Group+reservedWordsTests pool =+  Property.group "ReservedWords" $+    [+      ( String.fromString "Can insert and select an entity with reserved words in its schema"+      , Property.singletonProperty $ do+          originalUser <- HH.forAll User.generate++          usersFromDB <-+            MIO.liftIO $ do+              Conn.withPoolConnection pool $ \connection ->+                TestTable.dropAndRecreateTableDef connection User.table++              Orville.runOrville pool $ do+                _ <- Orville.insertEntity User.table originalUser+                Orville.findEntitiesBy User.table mempty++          usersFromDB HH.=== [originalUser]+      )+    ]
+ test/Test/SelectOptions.hs view
@@ -0,0 +1,354 @@+module Test.SelectOptions+  ( selectOptionsTests+  )+where++import qualified Data.ByteString.Char8 as B8+import qualified Data.Int as Int+import Data.List.NonEmpty (NonEmpty ((:|)))+import qualified Data.Text as T+import GHC.Stack (HasCallStack, withFrozenCallStack)+import qualified Hedgehog as HH++import Orville.PostgreSQL ((.&&), (./=), (.<), (.<-), (.</-), (.<=), (.==), (.>), (.>=), (.||))+import qualified Orville.PostgreSQL as O+import qualified Orville.PostgreSQL.Expr as Expr+import qualified Orville.PostgreSQL.Marshall.FieldDefinition as FieldDef+import qualified Orville.PostgreSQL.Raw.RawSql as RawSql+import qualified Test.Property as Property++selectOptionsTests :: Property.Group+selectOptionsTests =+  Property.group+    "SelectOptions"+    [ prop_emptyWhereClause+    , prop_fieldEquals+    , prop_fieldEqualsOperator+    , prop_fieldNotEquals+    , prop_fieldNotEqualsOperator+    , prop_fieldLessThan+    , prop_fieldLessThanOperator+    , prop_fieldGreaterThan+    , prop_fieldGreaterThanOperator+    , prop_fieldLessThanOrEqualTo+    , prop_fieldLessThanOrEqualToOperator+    , prop_fieldGreaterThanOrEqualTo+    , prop_fieldGreaterThanOrEqualToOperator+    , prop_fieldIsNull+    , prop_fieldIsNotNull+    , prop_fieldLike+    , prop_fieldLikeInsensitive+    , prop_andExpr+    , prop_andExprOperator+    , prop_orExpr+    , prop_orExprOperator+    , prop_andExprOrRightAssociativity+    , prop_equalityAndOrPrecedence+    , prop_whereCombined+    , prop_fieldIn+    , prop_fieldInOperator+    , prop_fieldNotIn+    , prop_fieldNotInOperator+    , prop_distinct+    , prop_orderBy+    , prop_orderByCombined+    , prop_groupBy+    , prop_groupByCombined+    ]++prop_emptyWhereClause :: Property.NamedProperty+prop_emptyWhereClause =+  Property.singletonNamedProperty "emptySelectOptions yields no whereClause" $+    assertWhereClauseEquals+      Nothing+      O.emptySelectOptions++prop_fieldEquals :: Property.NamedProperty+prop_fieldEquals =+  Property.singletonNamedProperty "fieldEquals generates expected sql" $+    assertWhereClauseEquals+      (Just "WHERE (\"foo\") = ($1)")+      (O.where_ $ O.fieldEquals fooField 0)++prop_fieldEqualsOperator :: Property.NamedProperty+prop_fieldEqualsOperator =+  Property.singletonNamedProperty ".== generates expected sql" $+    assertWhereClauseEquals+      (Just "WHERE (\"foo\") = ($1)")+      (O.where_ $ fooField .== 0)++prop_fieldNotEquals :: Property.NamedProperty+prop_fieldNotEquals =+  Property.singletonNamedProperty "fieldNotEquals generates expected sql" $+    assertWhereClauseEquals+      (Just "WHERE (\"foo\") <> ($1)")+      (O.where_ $ O.fieldNotEquals fooField 0)++prop_fieldNotEqualsOperator :: Property.NamedProperty+prop_fieldNotEqualsOperator =+  Property.singletonNamedProperty "./= generates expected sql" $+    assertWhereClauseEquals+      (Just "WHERE (\"foo\") <> ($1)")+      (O.where_ $ fooField ./= 0)++prop_fieldLessThan :: Property.NamedProperty+prop_fieldLessThan =+  Property.singletonNamedProperty "fieldLessThan generates expected sql" $+    assertWhereClauseEquals+      (Just "WHERE (\"foo\") < ($1)")+      (O.where_ $ O.fieldLessThan fooField 0)++prop_fieldLessThanOperator :: Property.NamedProperty+prop_fieldLessThanOperator =+  Property.singletonNamedProperty ".< generates expected sql" $+    assertWhereClauseEquals+      (Just "WHERE (\"foo\") < ($1)")+      (O.where_ $ fooField .< 0)++prop_fieldGreaterThan :: Property.NamedProperty+prop_fieldGreaterThan =+  Property.singletonNamedProperty "fieldGreaterThan generates expected sql" $+    assertWhereClauseEquals+      (Just "WHERE (\"foo\") > ($1)")+      (O.where_ $ O.fieldGreaterThan fooField 0)++prop_fieldGreaterThanOperator :: Property.NamedProperty+prop_fieldGreaterThanOperator =+  Property.singletonNamedProperty ".> generates expected sql" $+    assertWhereClauseEquals+      (Just "WHERE (\"foo\") > ($1)")+      (O.where_ $ fooField .> 0)++prop_fieldLessThanOrEqualTo :: Property.NamedProperty+prop_fieldLessThanOrEqualTo =+  Property.singletonNamedProperty "fieldLessThanOrEqualTo generates expected sql" $+    assertWhereClauseEquals+      (Just "WHERE (\"foo\") <= ($1)")+      (O.where_ $ O.fieldLessThanOrEqualTo fooField 0)++prop_fieldLessThanOrEqualToOperator :: Property.NamedProperty+prop_fieldLessThanOrEqualToOperator =+  Property.singletonNamedProperty ".<= generates expected sql" $+    assertWhereClauseEquals+      (Just "WHERE (\"foo\") <= ($1)")+      (O.where_ $ fooField .<= 0)++prop_fieldGreaterThanOrEqualTo :: Property.NamedProperty+prop_fieldGreaterThanOrEqualTo =+  Property.singletonNamedProperty "fieldGreaterThanOrEqualTo generates expected sql" $+    assertWhereClauseEquals+      (Just "WHERE (\"foo\") >= ($1)")+      (O.where_ $ O.fieldGreaterThanOrEqualTo fooField 0)++prop_fieldGreaterThanOrEqualToOperator :: Property.NamedProperty+prop_fieldGreaterThanOrEqualToOperator =+  Property.singletonNamedProperty ".>= generates expected sql" $+    assertWhereClauseEquals+      (Just "WHERE (\"foo\") >= ($1)")+      (O.where_ $ fooField .>= 0)++prop_fieldLike :: Property.NamedProperty+prop_fieldLike =+  Property.singletonNamedProperty "fieldLike generates expected sql" $+    assertWhereClauseEquals+      (Just "WHERE (\"foo\") LIKE ($1)")+      (O.where_ $ O.fieldLike fooField $ T.pack "%0%")++prop_fieldLikeInsensitive :: Property.NamedProperty+prop_fieldLikeInsensitive =+  Property.singletonNamedProperty "fieldLikeInsensitive generates expected sql" $+    assertWhereClauseEquals+      (Just "WHERE (\"foo\") ILIKE ($1)")+      (O.where_ $ O.fieldLikeInsensitive fooField $ T.pack "%0%")++prop_fieldIsNull :: Property.NamedProperty+prop_fieldIsNull =+  Property.singletonNamedProperty "fieldIsNull generates expected sql" $+    assertWhereClauseEquals+      (Just "WHERE \"baz\" IS NULL")+      (O.where_ $ O.fieldIsNull bazField)++prop_fieldIsNotNull :: Property.NamedProperty+prop_fieldIsNotNull =+  Property.singletonNamedProperty "fieldIsNotNull generates expected sql" $+    assertWhereClauseEquals+      (Just "WHERE \"baz\" IS NOT NULL")+      (O.where_ $ O.fieldIsNotNull bazField)++prop_andExpr :: Property.NamedProperty+prop_andExpr =+  Property.singletonNamedProperty "andExpr generates expected sql" $+    assertWhereClauseEquals+      (Just "WHERE ((\"foo\") = ($1)) AND ((\"bar\") = ($2))")+      (O.where_ $ Expr.andExpr (O.fieldEquals fooField 10) (O.fieldEquals barField 20))++prop_andExprOperator :: Property.NamedProperty+prop_andExprOperator =+  Property.singletonNamedProperty ".&& generates expected sql" $+    assertWhereClauseEquals+      (Just "WHERE ((\"foo\") = ($1)) AND ((\"bar\") = ($2))")+      (O.where_ $ O.fieldEquals fooField 10 .&& O.fieldEquals barField 20)++prop_orExpr :: Property.NamedProperty+prop_orExpr =+  Property.singletonNamedProperty "orExpr generates expected sql" $+    assertWhereClauseEquals+      (Just "WHERE ((\"foo\") = ($1)) OR ((\"bar\") = ($2))")+      (O.where_ $ Expr.orExpr (O.fieldEquals fooField 10) (O.fieldEquals barField 20))++prop_orExprOperator :: Property.NamedProperty+prop_orExprOperator =+  Property.singletonNamedProperty ".|| generates expected sql" $+    assertWhereClauseEquals+      (Just "WHERE ((\"foo\") = ($1)) OR ((\"bar\") = ($2))")+      (O.where_ $ O.fieldEquals fooField 10 .|| O.fieldEquals barField 20)++prop_andExprOrRightAssociativity :: Property.NamedProperty+prop_andExprOrRightAssociativity =+  Property.singletonNamedProperty ".|| and .&& are right associative" $+    assertWhereClauseEquals+      (Just "WHERE ((\"foo\") = ($1)) OR (((\"foo\") = ($2)) AND (((\"foo\") = ($3)) OR ((\"foo\") = ($4))))")+      ( O.where_ $+          O.fieldEquals fooField 10+            .|| O.fieldEquals fooField 20+            .&& O.fieldEquals fooField 30+            .|| O.fieldEquals fooField 40+      )++prop_equalityAndOrPrecedence :: Property.NamedProperty+prop_equalityAndOrPrecedence =+  Property.singletonNamedProperty ".|| and .&& are have reasonable precedence to combine with .== and friends" $+    assertWhereClauseEquals+      (Just "WHERE ((\"foo\") = ($1)) OR (((\"foo\") <> ($2)) AND (((\"foo\") > ($3)) OR (((\"foo\") < ($4)) AND (((\"foo\") >= ($5)) OR (((\"foo\") <= ($6)) AND (((\"foo\") IN ($7)) OR ((\"foo\") NOT IN ($8))))))))")+      ( O.where_ $+          fooField+            .== 10+            .|| fooField+            ./= 20+            .&& fooField+            .> 30+            .|| fooField+            .< 40+            .&& fooField+            .>= 50+            .|| fooField+            .<= 60+            .&& fooField+            .<- (70 :| [])+            .|| fooField+            .</- (80 :| [])+      )++prop_whereCombined :: Property.NamedProperty+prop_whereCombined =+  Property.singletonNamedProperty "combining SelectOptions ANDs the where clauses together" $+    assertWhereClauseEquals+      (Just "WHERE ((\"foo\") = ($1)) AND ((\"bar\") = ($2))")+      ( O.where_ (O.fieldEquals fooField 10)+          <> O.where_ (O.fieldEquals barField 20)+      )++prop_fieldIn :: Property.NamedProperty+prop_fieldIn =+  Property.singletonNamedProperty "fieldIn generates expected sql" $+    assertWhereClauseEquals+      (Just "WHERE (\"foo\") IN ($1)")+      (O.where_ $ O.fieldIn fooField (10 :| []))++prop_fieldInOperator :: Property.NamedProperty+prop_fieldInOperator =+  Property.singletonNamedProperty ".<- generates expected sql" $+    assertWhereClauseEquals+      (Just "WHERE (\"foo\") IN ($1)")+      (O.where_ $ fooField .<- (10 :| []))++prop_fieldNotIn :: Property.NamedProperty+prop_fieldNotIn =+  Property.singletonNamedProperty "fieldNotIn generates expected sql" $+    assertWhereClauseEquals+      (Just "WHERE (\"foo\") NOT IN ($1, $2)")+      (O.where_ $ O.fieldNotIn fooField (10 :| [20]))++prop_fieldNotInOperator :: Property.NamedProperty+prop_fieldNotInOperator =+  Property.singletonNamedProperty ".</- generates expected sql" $+    assertWhereClauseEquals+      (Just "WHERE (\"foo\") NOT IN ($1, $2)")+      (O.where_ $ fooField .</- (10 :| [20]))++prop_distinct :: Property.NamedProperty+prop_distinct =+  Property.singletonNamedProperty "distinct generates expected sql" $+    assertDistinctEquals+      ("SELECT DISTINCT ")+      (O.distinct)++prop_orderBy :: Property.NamedProperty+prop_orderBy =+  Property.singletonNamedProperty "orderBy generates expected sql" $+    assertOrderByClauseEquals+      (Just "ORDER BY \"foo\" ASC, \"bar\" DESC")+      ( O.orderBy+          ( O.orderByField 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.orderByField barField O.descendingOrder)+      )++prop_groupBy :: Property.NamedProperty+prop_groupBy =+  Property.singletonNamedProperty "groupBy generates expected sql" $+    assertGroupByClauseEquals+      (Just "GROUP BY \"foo\", \"bar\"")+      ( O.groupBy . Expr.groupByColumnsExpr $+          FieldDef.fieldColumnName fooField :| [FieldDef.fieldColumnName barField]+      )++prop_groupByCombined :: Property.NamedProperty+prop_groupByCombined =+  Property.singletonNamedProperty "groupBy generates expected sql with multiple selectOptions" $+    assertGroupByClauseEquals+      (Just "GROUP BY foo, \"bar\"")+      ( (O.groupBy . RawSql.unsafeSqlExpression $ "foo")+          <> (O.groupBy . Expr.groupByColumnsExpr $ (FieldDef.fieldColumnName barField :| []))+      )++assertDistinctEquals :: (HH.MonadTest m, HasCallStack) => String -> O.SelectOptions -> m ()+assertDistinctEquals mbDistinct selectOptions =+  withFrozenCallStack $+    RawSql.toExampleBytes (O.selectDistinct selectOptions) HH.=== B8.pack mbDistinct++assertWhereClauseEquals :: (HH.MonadTest m, HasCallStack) => Maybe String -> O.SelectOptions -> m ()+assertWhereClauseEquals mbWhereClause selectOptions =+  withFrozenCallStack $+    fmap RawSql.toExampleBytes (O.selectWhereClause selectOptions) HH.=== fmap B8.pack mbWhereClause++assertOrderByClauseEquals :: (HH.MonadTest m, HasCallStack) => Maybe String -> O.SelectOptions -> m ()+assertOrderByClauseEquals mbOrderByClause selectOptions =+  withFrozenCallStack $+    fmap RawSql.toExampleBytes (O.selectOrderByClause selectOptions) HH.=== fmap B8.pack mbOrderByClause++assertGroupByClauseEquals :: (HH.MonadTest m, HasCallStack) => Maybe String -> O.SelectOptions -> m ()+assertGroupByClauseEquals mbGroupByClause selectOptions =+  withFrozenCallStack $+    fmap RawSql.toExampleBytes (O.selectGroupByClause selectOptions) HH.=== fmap B8.pack mbGroupByClause++fooField :: FieldDef.FieldDefinition FieldDef.NotNull Int.Int32+fooField =+  FieldDef.integerField "foo"++barField :: FieldDef.FieldDefinition FieldDef.NotNull Int.Int32+barField =+  FieldDef.integerField "bar"++bazField :: FieldDef.FieldDefinition FieldDef.Nullable (Maybe Int.Int32)+bazField =+  FieldDef.nullableField $ FieldDef.integerField "baz"
+ test/Test/Sequence.hs view
@@ -0,0 +1,68 @@+module Test.Sequence+  ( sequenceTests+  )+where++import qualified Control.Monad.IO.Class as MIO+import Hedgehog ((===))++import qualified Orville.PostgreSQL as Orville+import qualified Orville.PostgreSQL.Expr as Expr++import qualified Test.Property as Property++sequenceTests :: Orville.ConnectionPool -> Property.Group+sequenceTests pool =+  Property.group+    "Sequence"+    [ prop_nextValue pool+    , prop_currentValue pool+    , prop_setValue pool+    ]++prop_nextValue :: Property.NamedDBProperty+prop_nextValue =+  Property.singletonNamedDBProperty "Fetching the next value from a sequence" $ \pool -> do+    result <-+      MIO.liftIO $+        Orville.runOrville pool $ do+          createTestSequence+          traverse (\() -> Orville.sequenceNextValue testSequence) [(), (), ()]+    result === [1, 2, 3]++prop_currentValue :: Property.NamedDBProperty+prop_currentValue =+  Property.singletonNamedDBProperty "Fetching the current value from a sequence" $ \pool -> do+    result <-+      MIO.liftIO $+        Orville.runOrville pool $ do+          createTestSequence+          -- get the next value once to initialize the sequence so that we can+          -- query the current value+          _ <- Orville.sequenceNextValue testSequence+          traverse (\() -> Orville.sequenceCurrentValue testSequence) [(), (), ()]+    result === [1, 1, 1]++prop_setValue :: Property.NamedDBProperty+prop_setValue =+  Property.singletonNamedDBProperty "Setting the current value of a sequence" $ \pool -> do+    result <-+      MIO.liftIO $+        Orville.runOrville pool $ do+          createTestSequence+          _ <- Orville.sequenceSetValue testSequence 42+          Orville.sequenceCurrentValue testSequence+    result === 42++testSequence :: Orville.SequenceDefinition+testSequence =+  Orville.mkSequenceDefinition sequenceNameString++sequenceNameString :: String+sequenceNameString =+  "sequence_definition_test"++createTestSequence :: Orville.Orville ()+createTestSequence = do+  Orville.executeVoid Orville.DDLQuery $ Expr.dropSequenceExpr (Just Expr.ifExists) (Orville.sequenceName testSequence)+  Orville.executeVoid Orville.DDLQuery $ Orville.mkCreateSequenceExpr testSequence
+ test/Test/SqlCommenter.hs view
@@ -0,0 +1,107 @@+module Test.SqlCommenter+  ( sqlCommenterTests+  )+where++import qualified Control.Monad.IO.Class as MIO+import qualified Data.ByteString.Char8 as B8+import Data.Functor.Identity (runIdentity)+import qualified Data.Map.Strict as Map+import qualified Data.Text as T+import Hedgehog ((===))+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.SqlCommenter as SqlCommenter++import Test.Expr.TestSchema+  ( assertEqualFooBarRows+  , dropAndRecreateTestTable+  , findAllFooBars+  , fooBarTable+  , insertFooBarSource+  , mkFooBar+  )+import qualified Test.Property as Property++sqlCommenterTests :: Orville.ConnectionPool -> Property.Group+sqlCommenterTests pool =+  Property.group+    "SqlCommenterAttributes"+    [ prop_sqlcommenterAttributesEscaped+    , prop_sqlCommenterInsertExpr pool+    , prop_sqlCommenterOrvilleState pool+    ]++prop_sqlcommenterAttributesEscaped :: Property.NamedProperty+prop_sqlcommenterAttributesEscaped =+  Property.singletonNamedProperty "SqlCommenterAttributes are escaped and put at end of raw sql" $ do+    let+      rawSql :: RawSql.RawSql+      rawSql =+        SqlCommenter.addSqlCommenterAttributes staticSqlCommenterAttributes $+          RawSql.fromString "SELECT * "+            <> RawSql.fromString "FROM foo "+            <> RawSql.fromString "WHERE id = 1"++      expectedBytes =+        B8.pack "SELECT * FROM foo WHERE id = 1 /*key='value',keyForEscapedValue='queryParam%3Dfoo%20bar%2Fbaz-fizz',keyWith%27InIt='valueWith%27InIt',orm='orville'*/"++      (actualBytes, actualParams) =+        runIdentity $+          RawSql.toBytesAndParams RawSql.exampleQuoting rawSql++    actualBytes HH.=== expectedBytes+    actualParams HH.=== []++prop_sqlCommenterInsertExpr :: Property.NamedDBProperty+prop_sqlCommenterInsertExpr =+  Property.singletonNamedDBProperty "sqlcommenter support does not impact ability of insertExpr inserting values" $ \pool -> do+    let+      fooBars = [mkFooBar 1 "dog", mkFooBar 2 "cat"]++    rows <-+      MIO.liftIO $+        Conn.withPoolConnection pool $ \connection -> do+          dropAndRecreateTestTable connection++          let+            insertExpr = Expr.insertExpr fooBarTable Nothing (insertFooBarSource fooBars) Nothing+          RawSql.executeVoid connection $+            SqlCommenter.addSqlCommenterAttributes staticSqlCommenterAttributes insertExpr++          result <- RawSql.execute connection findAllFooBars++          Execution.readRows result++    assertEqualFooBarRows rows fooBars++prop_sqlCommenterOrvilleState :: Property.NamedDBProperty+prop_sqlCommenterOrvilleState =+  Property.singletonNamedDBProperty "sqlcommenter support in OrvilleState does not impact execution" $ \pool -> do+    let+      selectOne =+        RawSql.fromString "SELECT 1 as number"++    affectedRows <-+      HH.evalIO . Orville.runOrville pool $ do+        Orville.localOrvilleState+          (Orville.setSqlCommenterAttributes staticSqlCommenterAttributes)+          (Orville.executeAndReturnAffectedRows Orville.UpdateQuery selectOne)++    affectedRows === 1++staticSqlCommenterAttributes :: SqlCommenter.SqlCommenterAttributes+staticSqlCommenterAttributes =+  fmap T.pack+    . Map.mapKeys T.pack+    $ Map.fromList+      [ ("orm", "orville")+      , ("key", "value")+      , ("keyForEscapedValue", "queryParam=foo bar/baz-fizz")+      , ("keyWith'InIt", "valueWith'InIt")+      ]
+ test/Test/SqlMarshaller.hs view
@@ -0,0 +1,355 @@+module Test.SqlMarshaller+  ( sqlMarshallerTests+  )+where++import qualified Control.Monad.IO.Class as MIO+import qualified Data.Bifunctor as Bifunctor+import qualified Data.ByteString.Char8 as B8+import qualified Data.Either as Either+import qualified Data.Int as Int+import qualified Data.Set as Set+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+import qualified Hedgehog.Range as Range++import qualified Orville.PostgreSQL.ErrorDetailLevel as ErrorDetailLevel+import qualified Orville.PostgreSQL.Execution.ExecutionResult as Result+import qualified Orville.PostgreSQL.Marshall as Marshall+import qualified Orville.PostgreSQL.Raw.SqlValue as SqlValue++import Test.Expr.TestSchema (assertEqualSqlRows)+import qualified Test.PgGen as PgGen+import qualified Test.Property as Property++sqlMarshallerTests :: Property.Group+sqlMarshallerTests =+  Property.group+    "SqlMarshaller"+    [ property_returnPureValue+    , property_combineWithApplicative+    , property_marshellField_readSingleField+    , prop_marshallField_missingColumn+    , prop_marshallField_decodeValueFailure+    , prop_marshallResultFromSql_Foo+    , prop_marshallResultFromSql_Bar+    , prop_foldMarshallerFields+    , prop_passMaybeThrough+    , prop_partialMap+    ]++property_returnPureValue :: Property.NamedProperty+property_returnPureValue =+  Property.namedProperty "Can read a pure Int via SqlMarshaller" $ do+    someInt <- HH.forAll generateInt+    result <- marshallTestRowFromSql (pure someInt) (Result.mkFakeLibPQResult [] [[]])+    Bifunctor.first show result === Right [someInt]++property_combineWithApplicative :: Property.NamedProperty+property_combineWithApplicative =+  Property.namedProperty "Can combine SqlMarshallers with <*>" $ do+    firstInt <- HH.forAll generateInt+    secondInt <- HH.forAll generateInt+    result <- marshallTestRowFromSql ((pure (+ firstInt)) <*> (pure secondInt)) (Result.mkFakeLibPQResult [] [[]])+    Bifunctor.first show result === Right [firstInt + secondInt]++property_marshellField_readSingleField :: Property.NamedProperty+property_marshellField_readSingleField =+  Property.namedProperty "Read a single field from a result row using marshallField" $ do+    targetName <- HH.forAll generateName+    targetValue <- HH.forAll generateInt32++    namesBefore <- HH.forAll (generateNamesOtherThan targetName)+    namesAfter <- HH.forAll (generateNamesOtherThan targetName)++    valuesBefore <- HH.forAll (generateAssociatedValues namesBefore generateInt32)+    valuesAfter <- HH.forAll (generateAssociatedValues namesAfter generateInt32)++    let+      fieldDef = Marshall.integerField targetName+      marshaller = Marshall.marshallField id fieldDef+      input =+        Result.mkFakeLibPQResult+          (map B8.pack (namesBefore ++ (targetName : namesAfter)))+          [map SqlValue.fromInt32 (valuesBefore ++ (targetValue : valuesAfter))]++    result <- marshallTestRowFromSql marshaller input+    Bifunctor.first show result === Right [targetValue]++prop_marshallField_missingColumn :: Property.NamedProperty+prop_marshallField_missingColumn =+  Property.namedProperty "marshallField fails gracefully when decoding a non-existent column" $ do+    targetName <- HH.forAll generateName+    otherNames <- HH.forAll (generateNamesOtherThan targetName)+    otherValues <- HH.forAll (generateAssociatedValues otherNames generateInt32)++    let+      fieldDef = Marshall.integerField targetName+      marshaller = Marshall.marshallField id fieldDef+      input =+        Result.mkFakeLibPQResult+          (map B8.pack otherNames)+          [map SqlValue.fromInt32 otherValues]++      expectedError =+        Marshall.MarshallError+          { Marshall.marshallErrorDetailLevel = ErrorDetailLevel.maximalErrorDetailLevel+          , Marshall.marshallErrorRowIdentifier = mempty+          , Marshall.marshallErrorDetails =+              Marshall.MissingColumnError $+                Marshall.MissingColumnErrorDetails+                  { Marshall.missingColumnName = B8.pack targetName+                  , Marshall.actualColumnNames = Set.fromList $ fmap B8.pack otherNames+                  }+          }++    result <- marshallTestRowFromSql marshaller input+    -- Use show on the error here so MarshallError and friends don't+    -- need an Eq instance+    Bifunctor.first show result === Left (show expectedError)++prop_marshallField_decodeValueFailure :: Property.NamedProperty+prop_marshallField_decodeValueFailure =+  Property.namedProperty "marshallField fails gracefully when failing to decode a value" $ do+    targetName <- HH.forAll generateName+    nonIntegerText <- HH.forAll (Gen.text (Range.linear 0 10) Gen.alpha)++    let+      fieldDef = Marshall.integerField targetName+      marshaller = Marshall.marshallField id fieldDef+      input =+        Result.mkFakeLibPQResult+          [B8.pack targetName]+          [[SqlValue.fromText nonIntegerText]]++    result <- marshallTestRowFromSql marshaller input++    case result of+      Right n -> do+        HH.annotateShow n+        HH.footnote "Expected decoding failure, but got success"+        HH.failure+      Left rowDecodeErr ->+        case Marshall.marshallErrorDetails rowDecodeErr of+          Marshall.DecodingError details ->+            map fst (Marshall.decodingErrorValues details) === [B8.pack targetName]+          err -> do+            HH.annotate $ Marshall.renderMarshallErrorDetails ErrorDetailLevel.maximalErrorDetailLevel err+            HH.footnote "Expected DecodingError error, but got another error instead."+            HH.failure++prop_marshallResultFromSql_Foo :: Property.NamedProperty+prop_marshallResultFromSql_Foo =+  Property.namedProperty "marshallResultFromSql decodes all rows in Foo result set" $ 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 fooMarshaller 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+    bars <- HH.forAll $ Gen.list (Range.linear 0 10) generateBar++    let+      mkRowValues bar =+        [ SqlValue.fromDouble (barNumber bar)+        , maybe SqlValue.sqlNull SqlValue.fromText (barComment bar)+        , maybe SqlValue.sqlNull SqlValue.fromText (barLabel bar)+        ]++      input =+        Result.mkFakeLibPQResult+          [B8.pack "number", B8.pack "comment", B8.pack "label"]+          (map mkRowValues bars)++    result <- marshallTestRowFromSql barMarshaller input+    Bifunctor.first show result === Right bars++prop_foldMarshallerFields :: Property.NamedProperty+prop_foldMarshallerFields =+  Property.namedProperty "foldMarshallerFields collects all fields as their sql values" $ do+    foo <- HH.forAll generateFoo++    let+      addField entry fields =+        case entry of+          Marshall.Natural fieldDef (Just getValue) ->+            (Marshall.fieldName fieldDef, Marshall.fieldValueToSqlValue fieldDef (getValue foo)) : fields+          Marshall.Natural _ Nothing ->+            fields+          Marshall.Synthetic _ ->+            fields++      actualFooRow =+        Marshall.foldMarshallerFields+          fooMarshaller+          []+          addField++      expectedFooRow =+        [ (Marshall.stringToFieldName "name", SqlValue.fromText $ fooName foo)+        , (Marshall.stringToFieldName "size", SqlValue.fromInt32 $ fooSize foo)+        , (Marshall.stringToFieldName "option", maybe SqlValue.sqlNull SqlValue.fromBool $ fooOption foo)+        ]++    [actualFooRow] `assertEqualSqlRows` [expectedFooRow]++prop_passMaybeThrough :: Property.NamedProperty+prop_passMaybeThrough =+  Property.namedProperty "can pass a Maybe through SqlMarshaller" $ do+    someMaybeBool <- HH.forAll $ Gen.maybe Gen.bool+    result <- marshallTestRowFromSql (pure someMaybeBool) (Result.mkFakeLibPQResult [] [[]])+    Bifunctor.first show result === Right [someMaybeBool]++prop_partialMap :: Property.NamedProperty+prop_partialMap =+  Property.namedProperty "can use marshallPartial to fail decoding with in a custom way" $ do+    texts <- HH.forAll $ Gen.list (Range.linear 0 10) (PgGen.pgText (Range.linear 0 10))++    let+      validateText text =+        if T.length text > 8+          then Left "Text too long"+          else Right text++      mkRowValues text =+        [ SqlValue.fromText text+        ]++      input =+        Result.mkFakeLibPQResult+          [B8.pack "text"]+          (map mkRowValues texts)++      marshaller =+        Marshall.marshallPartial $+          validateText+            <$> Marshall.marshallField id (Marshall.unboundedTextField "text")++      mkExpected text =+        case validateText text of+          Right validText ->+            Right validText+          Left message ->+            Left $+              -- Use show here to render the error so that MarshallError+              -- and friends don't need to have an Eq instance+              show $+                Marshall.MarshallError+                  { Marshall.marshallErrorDetailLevel = ErrorDetailLevel.maximalErrorDetailLevel+                  , Marshall.marshallErrorRowIdentifier = mempty+                  , Marshall.marshallErrorDetails =+                      Marshall.DecodingError $+                        Marshall.DecodingErrorDetails+                          { Marshall.decodingErrorValues = [(B8.pack "text", SqlValue.fromText text)]+                          , Marshall.decodingErrorMessage = message+                          }+                  }++      expected =+        traverse mkExpected texts++    HH.cover 1 (String.fromString "With no errors") (Either.isRight expected)+    HH.cover 1 (String.fromString "With at least one error") (Either.isLeft expected)++    result <- marshallTestRowFromSql marshaller input+    Bifunctor.first show result === expected++data Foo = Foo+  { fooName :: T.Text+  , fooSize :: Int.Int32+  , fooOption :: Maybe Bool+  }+  deriving (Eq, Show)++data Bar = Bar+  { barNumber :: Double+  , barComment :: Maybe T.Text+  , barLabel :: Maybe T.Text+  }+  deriving (Eq, Show)++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")++generateFoo :: HH.Gen Foo+generateFoo =+  Foo+    <$> PgGen.pgText (Range.linear 0 16)+    <*> generateInt32+    <*> Gen.maybe Gen.bool++barMarshaller :: Marshall.SqlMarshaller Bar Bar+barMarshaller =+  Bar+    <$> Marshall.marshallField barNumber (Marshall.doubleField "number")+    <*> Marshall.marshallField barComment (Marshall.nullableField $ Marshall.unboundedTextField "comment")+    <*> Marshall.marshallField barLabel (Marshall.nullableField $ Marshall.boundedTextField "label" 16)++generateBar :: HH.Gen Bar+generateBar =+  Bar+    <$> PgGen.pgDouble+    <*> Gen.maybe (PgGen.pgText $ Range.linear 0 32)+    <*> Gen.maybe (PgGen.pgText $ Range.linear 1 16)++generateNamesOtherThan :: String -> HH.Gen [String]+generateNamesOtherThan specialName =+  Gen.list+    (Range.linear 0 10)+    (generateNameOtherThan specialName)++generateAssociatedValues :: [key] -> HH.Gen value -> HH.Gen [value]+generateAssociatedValues keys genValue =+  traverse (const genValue) keys++generateInt32 :: HH.Gen Int.Int32+generateInt32 =+  Gen.int32 (Range.exponentialFrom 0 minBound maxBound)++generateNameOtherThan :: String -> HH.Gen String+generateNameOtherThan specialName =+  Gen.filter (/= specialName) generateName++generateName :: HH.Gen String+generateName =+  Gen.string (Range.linear 1 256) Gen.alphaNum++generateInt :: HH.MonadGen m => m Int+generateInt = Gen.int $ Range.exponential 1 1024++marshallTestRowFromSql ::+  ( HH.MonadTest m+  , MIO.MonadIO m+  , Result.ExecutionResult result+  ) =>+  Marshall.SqlMarshaller writeEntity readEntity ->+  result ->+  m (Either Marshall.MarshallError [readEntity])+marshallTestRowFromSql marshaller input =+  HH.evalIO $+    Marshall.marshallResultFromSqlUsingRowIdExtractor+      ErrorDetailLevel.maximalErrorDetailLevel+      (Marshall.mkRowIdentityExtractor [] input)+      marshaller+      input
+ test/Test/SqlType.hs view
@@ -0,0 +1,567 @@+module Test.SqlType+  ( sqlTypeTests+  )+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.String as String+import qualified Data.Text as T+import qualified Data.Time as Time+import Hedgehog ((===))+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.Marshall.SqlType as SqlType+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++sqlTypeTests :: Orville.ConnectionPool -> Property.Group+sqlTypeTests pool =+  Property.group "SqlType" $+    integerTests pool+      <> smallIntegerTests pool+      <> bigIntegerTests pool+      <> serialTests pool+      <> bigSerialTests pool+      <> doubleTests pool+      <> boolTests pool+      <> unboundedTextTests pool+      <> fixedTextTests pool+      <> boundedTextTests pool+      <> textSearchVectorTests pool+      <> dateTests pool+      <> timestampTests pool+      <> jsonbTests pool++integerTests :: Orville.ConnectionPool -> [(HH.PropertyName, HH.Property)]+integerTests pool =+  [+    ( String.fromString "Testing the decode of INTEGER with value 0"+    , runDecodingTest pool $+        DecodingTest+          { sqlTypeDDL = "INTEGER"+          , rawSqlValue = Just $ B8.pack $ show (0 :: Int)+          , sqlType = SqlType.integer+          , expectedValue = 0+          }+    )+  ,+    ( String.fromString "Testing the decode of INTEGER with value 2147483647"+    , runDecodingTest pool $+        DecodingTest+          { sqlTypeDDL = "INTEGER"+          , rawSqlValue = Just $ B8.pack $ show (2147483647 :: Int)+          , sqlType = SqlType.integer+          , expectedValue = 2147483647+          }+    )+  ,+    ( String.fromString "Testing the decode of INTEGER with value -2147483648"+    , runDecodingTest pool $+        DecodingTest+          { sqlTypeDDL = "INTEGER"+          , rawSqlValue = Just $ B8.pack $ show (-2147483648 :: Int)+          , sqlType = SqlType.integer+          , expectedValue = -2147483648+          }+    )+  ]++smallIntegerTests :: Orville.ConnectionPool -> [(HH.PropertyName, HH.Property)]+smallIntegerTests pool =+  [+    ( String.fromString "Testing the decode of SMALLINT with value 0"+    , runDecodingTest pool $+        DecodingTest+          { sqlTypeDDL = "SMALLINT"+          , rawSqlValue = Just $ B8.pack $ show (0 :: Int)+          , sqlType = SqlType.smallInteger+          , expectedValue = 0+          }+    )+  ,+    ( String.fromString "Testing the decode of SMALLINT with value 32767"+    , runDecodingTest pool $+        DecodingTest+          { sqlTypeDDL = "SMALLINT"+          , rawSqlValue = Just $ B8.pack $ show (32767 :: Int)+          , sqlType = SqlType.smallInteger+          , expectedValue = 32767+          }+    )+  ,+    ( String.fromString "Testing the decode of SMALLINT with value -32768"+    , runDecodingTest pool $+        DecodingTest+          { sqlTypeDDL = "SMALLINT"+          , rawSqlValue = Just $ B8.pack $ show (-32768 :: Int)+          , sqlType = SqlType.smallInteger+          , expectedValue = -32768+          }+    )+  ]++bigIntegerTests :: Orville.ConnectionPool -> [(HH.PropertyName, HH.Property)]+bigIntegerTests pool =+  [+    ( String.fromString "Testing the decode of BIGINT with value 0"+    , runDecodingTest pool $+        DecodingTest+          { sqlTypeDDL = "BIGINT"+          , rawSqlValue = Just $ B8.pack $ show (0 :: Int.Int64)+          , sqlType = SqlType.bigInteger+          , expectedValue = 0+          }+    )+  ,+    ( String.fromString "Testing the decode of BIGINT with value 21474836470"+    , runDecodingTest pool $+        DecodingTest+          { sqlTypeDDL = "BIGINT"+          , rawSqlValue = Just $ B8.pack $ show (21474836470 :: Int.Int64)+          , sqlType = SqlType.bigInteger+          , expectedValue = 21474836470+          }+    )+  ]++serialTests :: Orville.ConnectionPool -> [(HH.PropertyName, HH.Property)]+serialTests pool =+  [+    ( String.fromString "Testing the decode of SERIAL with value 0"+    , runDecodingTest pool $+        DecodingTest+          { sqlTypeDDL = "SERIAL"+          , rawSqlValue = Just $ B8.pack $ show (0 :: Int)+          , sqlType = SqlType.serial+          , expectedValue = 0+          }+    )+  ,+    ( String.fromString "Testing the decode of SERIAL with value 2147483647"+    , runDecodingTest pool $+        DecodingTest+          { sqlTypeDDL = "SERIAL"+          , rawSqlValue = Just $ B8.pack $ show (2147483647 :: Int)+          , sqlType = SqlType.serial+          , expectedValue = 2147483647+          }+    )+  ,+    ( String.fromString "Testing the decode of SERIAL with value -2147483648"+    , runDecodingTest pool $+        DecodingTest+          { sqlTypeDDL = "SERIAL"+          , rawSqlValue = Just $ B8.pack $ show (-2147483648 :: Int)+          , sqlType = SqlType.serial+          , expectedValue = -2147483648+          }+    )+  ]++bigSerialTests :: Orville.ConnectionPool -> [(HH.PropertyName, HH.Property)]+bigSerialTests pool =+  [+    ( String.fromString "Testing the decode of BIGSERIAL with value 0"+    , runDecodingTest pool $+        DecodingTest+          { sqlTypeDDL = "BIGSERIAL"+          , rawSqlValue = Just $ B8.pack $ show (0 :: Int.Int64)+          , sqlType = SqlType.bigSerial+          , expectedValue = 0+          }+    )+  ,+    ( String.fromString "Testing the decode of BIGSERIAL with value 21474836470"+    , runDecodingTest pool $+        DecodingTest+          { sqlTypeDDL = "BIGSERIAL"+          , rawSqlValue = Just $ B8.pack $ show (21474836470 :: Int.Int64)+          , sqlType = SqlType.bigSerial+          , expectedValue = 21474836470+          }+    )+  ]++doubleTests :: Orville.ConnectionPool -> [(HH.PropertyName, HH.Property)]+doubleTests pool =+  [+    ( String.fromString "Testing the decode of DOUBLE PRECISION with value 0"+    , runDecodingTest pool $+        DecodingTest+          { sqlTypeDDL = "DOUBLE PRECISION"+          , rawSqlValue = Just $ B8.pack $ show (0.0 :: Double)+          , sqlType = SqlType.double+          , expectedValue = 0.0+          }+    )+  ,+    ( String.fromString "Testing the decode of DOUBLE PRECISION with value 1.5"+    , runDecodingTest pool $+        DecodingTest+          { sqlTypeDDL = "DOUBLE PRECISION"+          , rawSqlValue = Just $ B8.pack $ show (1.5 :: Double)+          , sqlType = SqlType.double+          , expectedValue = 1.5+          }+    )+  ]++boolTests :: Orville.ConnectionPool -> [(HH.PropertyName, HH.Property)]+boolTests pool =+  [+    ( String.fromString "Testing the decode of BOOL with value False"+    , runDecodingTest pool $+        DecodingTest+          { sqlTypeDDL = "BOOL"+          , rawSqlValue = Just $ B8.pack $ show False+          , sqlType = SqlType.boolean+          , expectedValue = False+          }+    )+  ,+    ( String.fromString "Testing the decode of BOOL with value True"+    , runDecodingTest pool $+        DecodingTest+          { sqlTypeDDL = "BOOL"+          , rawSqlValue = Just $ B8.pack $ show True+          , sqlType = SqlType.boolean+          , expectedValue = True+          }+    )+  ]++unboundedTextTests :: Orville.ConnectionPool -> [(HH.PropertyName, HH.Property)]+unboundedTextTests pool =+  [+    ( String.fromString "Testing the decode of TEXT with value abcde"+    , runDecodingTest pool $+        DecodingTest+          { sqlTypeDDL = "TEXT"+          , rawSqlValue = Just $ B8.pack "abcde"+          , sqlType = SqlType.unboundedText+          , expectedValue = T.pack "abcde"+          }+    )+  ]++fixedTextTests :: Orville.ConnectionPool -> [(HH.PropertyName, HH.Property)]+fixedTextTests pool =+  [+    ( String.fromString "Testing the decode of CHAR(5) with value 'abcde'"+    , runDecodingTest pool $+        DecodingTest+          { sqlTypeDDL = "CHAR(5)"+          , rawSqlValue = Just $ B8.pack "abcde"+          , sqlType = SqlType.fixedText 5+          , expectedValue = T.pack "abcde"+          }+    )+  ,+    ( String.fromString "Testing the decode of CHAR(5) with value 'fghi'"+    , runDecodingTest pool $+        DecodingTest+          { sqlTypeDDL = "CHAR(5)"+          , rawSqlValue = Just $ B8.pack "fghi"+          , sqlType = SqlType.fixedText 5+          , expectedValue = T.pack "fghi "+          }+    )+  ]++boundedTextTests :: Orville.ConnectionPool -> [(HH.PropertyName, HH.Property)]+boundedTextTests pool =+  [+    ( String.fromString "Testing the decode of VARCHAR(5) with value 'abcde'"+    , runDecodingTest pool $+        DecodingTest+          { sqlTypeDDL = "VARCHAR(5)"+          , rawSqlValue = Just $ B8.pack "abcde"+          , sqlType = SqlType.boundedText 5+          , expectedValue = T.pack "abcde"+          }+    )+  ,+    ( String.fromString "Testing the decode of VARCHAR(5) with value 'fghi'"+    , runDecodingTest pool $+        DecodingTest+          { sqlTypeDDL = "VARCHAR(5)"+          , rawSqlValue = Just $ B8.pack "fghi"+          , sqlType = SqlType.boundedText 5+          , expectedValue = T.pack "fghi"+          }+    )+  ]++textSearchVectorTests :: Orville.ConnectionPool -> [(HH.PropertyName, HH.Property)]+textSearchVectorTests pool =+  [+    ( String.fromString "Testing the decode of TSVECTOR with value 'abcde'"+    , runDecodingTest pool $+        DecodingTest+          { sqlTypeDDL = "TSVECTOR"+          , rawSqlValue = Just $ B8.pack "'abcde'"+          , sqlType = SqlType.textSearchVector+          , expectedValue = T.pack "'abcde'"+          }+    )+  ,+    ( String.fromString "Testing the decode of TSVECTOR with value 'fghi'"+    , runDecodingTest pool $+        DecodingTest+          { sqlTypeDDL = "TSVECTOR"+          , rawSqlValue = Just $ B8.pack "'fghi'"+          , sqlType = SqlType.textSearchVector+          , expectedValue = T.pack "'fghi'"+          }+    )+  ]++jsonbTests :: Orville.ConnectionPool -> [(HH.PropertyName, HH.Property)]+jsonbTests pool =+  [+    ( String.fromString "Testing the decode of graph '{\"key\": \"value\"}'"+    , runDecodingTest pool $+        DecodingTest+          { sqlTypeDDL = "JSONB"+          , rawSqlValue = Just $ B8.pack "{\"key\": \"value\"}"+          , sqlType = SqlType.jsonb+          , expectedValue = T.pack "{\"key\": \"value\"}"+          }+    )+  ]++dateTests :: Orville.ConnectionPool -> [(HH.PropertyName, HH.Property)]+dateTests pool =+  [+    ( String.fromString "Testing the decode of DATE with value 2020-12-21"+    , runDecodingTest pool $+        DecodingTest+          { sqlTypeDDL = "DATE"+          , rawSqlValue = Just $ B8.pack "'2020-12-21'"+          , sqlType = SqlType.date+          , expectedValue = Time.fromGregorian 2020 12 21+          }+    )+  ,+    ( String.fromString "Testing the decode of DATE with value 0001-12-21"+    , runDecodingTest pool $+        DecodingTest+          { sqlTypeDDL = "DATE"+          , rawSqlValue = Just $ B8.pack "'0001-12-21'"+          , sqlType = SqlType.date+          , expectedValue = Time.fromGregorian 1 12 21+          }+    )+  ,+    ( String.fromString "Testing the decode of DATE with value 10000-12-21"+    , runDecodingTest pool $+        DecodingTest+          { sqlTypeDDL = "DATE"+          , rawSqlValue = Just $ B8.pack "'10000-12-21'"+          , sqlType = SqlType.date+          , expectedValue = Time.fromGregorian 10000 12 21+          }+    )+  ]++timestampTests :: Orville.ConnectionPool -> [(HH.PropertyName, HH.Property)]+timestampTests pool =+  [+    ( String.fromString "Testing the decode of TIMESTAMP WITH TIME ZONE with value '2020-12-21 00:00:32-00'"+    , runDecodingTest pool $+        DecodingTest+          { sqlTypeDDL = "TIMESTAMP WITH TIME ZONE"+          , rawSqlValue = Just $ B8.pack "'2020-12-21 00:00:32-00'"+          , sqlType = SqlType.timestamp+          , expectedValue = Time.UTCTime (Time.fromGregorian 2020 12 21) (Time.secondsToDiffTime 32)+          }+    )+  ,+    ( String.fromString "Testing the decode of TIMESTAMP WITH TIME ZONE with value '2020-12-20 23:00:00-01'"+    , runDecodingTest pool $+        DecodingTest+          { sqlTypeDDL = "TIMESTAMP WITH TIME ZONE"+          , rawSqlValue = Just $ B8.pack "'2020-12-20 23:00:00-01'"+          , sqlType = SqlType.timestamp+          , expectedValue = Time.UTCTime (Time.fromGregorian 2020 12 21) 0+          }+    )+  ,+    ( String.fromString "Testing the decode of TIMESTAMP WITH TIME ZONE with value '2020-12-21 00:00:32+00'"+    , runDecodingTest pool $+        DecodingTest+          { sqlTypeDDL = "TIMESTAMP WITH TIME ZONE"+          , rawSqlValue = Just $ B8.pack "'2020-12-21 00:00:32+00'"+          , sqlType = SqlType.timestamp+          , expectedValue = Time.UTCTime (Time.fromGregorian 2020 12 21) (Time.secondsToDiffTime 32)+          }+    )+  ,+    ( String.fromString "Testing the decode of TIMESTAMP WITH TIME ZONE with value '2020-12-21 01:00:00+01'"+    , runDecodingTest pool $+        DecodingTest+          { sqlTypeDDL = "TIMESTAMP WITH TIME ZONE"+          , rawSqlValue = Just $ B8.pack "'2020-12-21 01:00:00+01'"+          , sqlType = SqlType.timestamp+          , expectedValue = Time.UTCTime (Time.fromGregorian 2020 12 21) 0+          }+    )+  ,+    ( String.fromString "Testing the decode of TIMESTAMP WITH TIME ZONE with value '2020-12-21 00:30:00+0030'"+    , runDecodingTest pool $+        DecodingTest+          { sqlTypeDDL = "TIMESTAMP WITH TIME ZONE"+          , rawSqlValue = Just $ B8.pack "'2020-12-21 00:30:00+0030'"+          , sqlType = SqlType.timestamp+          , expectedValue = Time.UTCTime (Time.fromGregorian 2020 12 21) 0+          }+    )+  ,+    ( String.fromString "Testing the decode of TIMESTAMP WITH TIME ZONE with value '2020-12-21 00:30:00+00:30'"+    , runDecodingTest pool $+        DecodingTest+          { sqlTypeDDL = "TIMESTAMP WITH TIME ZONE"+          , rawSqlValue = Just $ B8.pack "'2020-12-21 00:30:00+00:30'"+          , sqlType = SqlType.timestamp+          , expectedValue = Time.UTCTime (Time.fromGregorian 2020 12 21) 0+          }+    )+  ,+    ( String.fromString "Testing the decode of TIMESTAMP WITH TIME ZONE with value '2020-12-21 00:00:32.000+00'"+    , runDecodingTest pool $+        DecodingTest+          { sqlTypeDDL = "TIMESTAMP WITH TIME ZONE"+          , rawSqlValue = Just $ B8.pack "'2020-12-21 00:00:32.000+00'"+          , sqlType = SqlType.timestamp+          , expectedValue = Time.UTCTime (Time.fromGregorian 2020 12 21) (Time.secondsToDiffTime 32)+          }+    )+  ,+    ( String.fromString "Testing the decode of TIMESTAMP WITHOUT TIME ZONE with value '2020-12-21 00:00:32'"+    , runDecodingTest pool $+        DecodingTest+          { sqlTypeDDL = "TIMESTAMP WITHOUT TIME ZONE"+          , rawSqlValue = Just $ B8.pack "'2020-12-21 00:00:32'"+          , sqlType = SqlType.timestampWithoutZone+          , expectedValue = Time.LocalTime (Time.fromGregorian 2020 12 21) (Time.timeToTimeOfDay $ Time.secondsToDiffTime 32)+          }+    )+  ,+    ( String.fromString "Testing the decode of TIMESTAMP WITHOUT TIME ZONE with value '2020-12-21 00:00:32.000'"+    , runDecodingTest pool $+        DecodingTest+          { sqlTypeDDL = "TIMESTAMP WITHOUT TIME ZONE"+          , rawSqlValue = Just $ B8.pack "'2020-12-21 00:00:32.000'"+          , sqlType = SqlType.timestampWithoutZone+          , expectedValue = Time.LocalTime (Time.fromGregorian 2020 12 21) (Time.timeToTimeOfDay $ Time.secondsToDiffTime 32)+          }+    )+  ,+    ( String.fromString "Testing the decode of TIMESTAMP WITHOUT TIME ZONE with value '2020-12-21 00:00:00.001'"+    , runDecodingTest pool $+        DecodingTest+          { sqlTypeDDL = "TIMESTAMP WITHOUT TIME ZONE"+          , rawSqlValue = Just $ B8.pack "'2020-12-21 00:00:00.001'"+          , sqlType = SqlType.timestampWithoutZone+          , expectedValue = Time.LocalTime (Time.fromGregorian 2020 12 21) (Time.timeToTimeOfDay $ Time.picosecondsToDiffTime (1 * 10 ^ (9 :: Int)))+          }+    )+  ,+    ( String.fromString "Testing the decode of TIMESTAMP WITHOUT TIME ZONE with value '2020-12-21 10:00:32'"+    , runDecodingTest pool $+        DecodingTest+          { sqlTypeDDL = "TIMESTAMP WITHOUT TIME ZONE"+          , rawSqlValue = Just $ B8.pack "'2020-12-21 10:00:32'"+          , sqlType = SqlType.timestampWithoutZone+          , expectedValue = Time.LocalTime (Time.fromGregorian 2020 12 21) (Time.timeToTimeOfDay $ Time.secondsToDiffTime (60 * 60 * 10 + 32))+          }+    )+  ,+    ( String.fromString "Testing the decode of TIMESTAMP WITHOUT TIME ZONE with value '2020-12-21 00:10:32'"+    , runDecodingTest pool $+        DecodingTest+          { sqlTypeDDL = "TIMESTAMP WITHOUT TIME ZONE"+          , rawSqlValue = Just $ B8.pack "'2020-12-21 00:10:32'"+          , sqlType = SqlType.timestampWithoutZone+          , expectedValue = Time.LocalTime (Time.fromGregorian 2020 12 21) (Time.timeToTimeOfDay $ Time.secondsToDiffTime (60 * 10 + 32))+          }+    )+  ,+    ( String.fromString "Testing the decode of TIMESTAMP WITHOUT TIME ZONE with value '10000-12-21 00:00:32'"+    , runDecodingTest pool $+        DecodingTest+          { sqlTypeDDL = "TIMESTAMP WITHOUT TIME ZONE"+          , rawSqlValue = Just $ B8.pack "'10000-12-21 00:00:32'"+          , sqlType = SqlType.timestampWithoutZone+          , expectedValue = Time.LocalTime (Time.fromGregorian 10000 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'"+    , runDecodingTest pool $+        DecodingTest+          { sqlTypeDDL = "TIMESTAMP WITHOUT TIME ZONE"+          , rawSqlValue = Just $ B8.pack "'0001-12-21 00:00:32'"+          , sqlType = SqlType.timestampWithoutZone+          , expectedValue = Time.LocalTime (Time.fromGregorian 1 12 21) (Time.timeToTimeOfDay $ Time.secondsToDiffTime 32)+          }+    )+  ]++data DecodingTest a = DecodingTest+  { sqlTypeDDL :: String+  , rawSqlValue :: Maybe B8.ByteString+  , sqlType :: SqlType.SqlType a+  , expectedValue :: a+  }++runDecodingTest :: (Show a, Eq a) => Orville.ConnectionPool -> DecodingTest a -> HH.Property+runDecodingTest pool test =+  Property.singletonProperty $ do+    rows <- MIO.liftIO . Conn.withPoolConnection pool $ \connection -> do+      dropAndRecreateTable connection "decoding_test" (sqlTypeDDL test)++      let+        tableName = Expr.qualifyTable Nothing (Expr.tableName "decoding_test")++      RawSql.executeVoid connection $+        Expr.insertExpr+          tableName+          Nothing+          (Expr.insertSqlValues [[SqlValue.fromRawBytesNullable (rawSqlValue test)]])+          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)++      Execution.readRows result++    let+      actual = map (decodeSingleValue (sqlType test)) rows++    actual === [Right $ expectedValue test]++dropAndRecreateTable :: Orville.Connection -> String -> String -> IO ()+dropAndRecreateTable connection tableName columnTypeDDL = do+  RawSql.executeVoid connection (RawSql.fromString $ "DROP TABLE IF EXISTS " <> tableName)+  RawSql.executeVoid connection (RawSql.fromString $ "CREATE TABLE " <> tableName <> "(foo " <> columnTypeDDL <> ")")++decodeSingleValue :: SqlType.SqlType a -> [(key, SqlValue.SqlValue)] -> Either String a+decodeSingleValue valueType row =+  case row of+    [] ->+      Left "Unable to decode single value from empty row"+    (_, sqlValue) : _ ->+      SqlType.sqlTypeFromSql valueType sqlValue
+ test/Test/TableDefinition.hs view
@@ -0,0 +1,184 @@+module Test.TableDefinition+  ( tableDefinitionTests+  )+where++import qualified Control.Exception as E+import qualified Control.Monad.IO.Class as MIO+import qualified Data.ByteString.Char8 as B8+import Data.List.NonEmpty (NonEmpty ((:|)))+import qualified Data.Set as Set+import qualified Data.Text as T+import Hedgehog ((===))+import qualified Hedgehog as HH++import qualified Orville.PostgreSQL as Orville+import qualified Orville.PostgreSQL.Execution.ReturningOption as ReturningOption+import qualified Orville.PostgreSQL.Execution.Select as Select+import qualified Orville.PostgreSQL.Raw.Connection as Conn+import qualified Orville.PostgreSQL.Raw.RawSql as RawSql+import qualified Orville.PostgreSQL.Schema.ConstraintDefinition as ConstraintDefinition+import qualified Orville.PostgreSQL.Schema.TableDefinition as TableDefinition++import qualified Test.Entities.Bar as Bar+import qualified Test.Entities.Foo as Foo+import qualified Test.Property as Property+import qualified Test.TestTable as TestTable++tableDefinitionTests :: Orville.ConnectionPool -> Property.Group+tableDefinitionTests pool =+  Property.group+    "TableDefinition"+    [ prop_roundTrip pool+    , prop_readOnlyFields pool+    , prop_primaryKey pool+    , prop_uniqueConstraint pool+    , prop_fieldConstraints+    ]++prop_roundTrip :: Property.NamedDBProperty+prop_roundTrip =+  Property.namedDBProperty "Creates a table that can round trip an entity through it" $ \pool -> do+    originalFoo <- HH.forAll Foo.generate++    let+      insertFoo =+        TableDefinition.mkInsertExpr+          ReturningOption.WithoutReturning+          Foo.table+          (originalFoo :| [])++      selectFoos =+        Select.selectTable Foo.table mempty++    foosFromDB <-+      MIO.liftIO . Orville.runOrville pool $ do+        Orville.withConnection $ \connection -> do+          MIO.liftIO $ TestTable.dropAndRecreateTableDef connection Foo.table+        Orville.executeVoid Orville.InsertQuery insertFoo+        Select.executeSelect selectFoos++    foosFromDB === [originalFoo]++prop_readOnlyFields :: Property.NamedDBProperty+prop_readOnlyFields =+  Property.namedDBProperty "Creates a table that can read from read only fields" $ \pool -> do+    originalBar <- HH.forAll Bar.generate++    let+      insertBar =+        TableDefinition.mkInsertExpr ReturningOption.WithoutReturning Bar.table (originalBar :| [])++      selectBars =+        Select.selectTable Bar.table mempty++    barsFromDB <-+      MIO.liftIO . Orville.runOrville pool $ do+        Orville.withConnection $ \connection -> do+          MIO.liftIO $ TestTable.dropAndRecreateTableDef connection Bar.table+        Orville.executeVoid Orville.InsertQuery insertBar+        Select.executeSelect selectBars++    fmap Bar.barName barsFromDB === [Bar.barName originalBar]++prop_primaryKey :: Property.NamedDBProperty+prop_primaryKey =+  Property.singletonNamedDBProperty "Creates a primary key that rejects duplicate records" $ \pool -> do+    originalFoo <- HH.forAll Foo.generate++    let+      conflictingFoo =+        originalFoo {Foo.fooName = T.reverse $ Foo.fooName originalFoo}++      insertFoos =+        TableDefinition.mkInsertExpr+          ReturningOption.WithoutReturning+          Foo.table+          (originalFoo :| [conflictingFoo])++    result <- MIO.liftIO . E.try . Conn.withPoolConnection pool $ \connection -> do+      TestTable.dropAndRecreateTableDef connection Foo.table+      RawSql.executeVoid connection insertFoos++    case result of+      Right () -> do+        HH.footnote "Expected 'executeVoid' to return failure, but it did not"+        HH.failure+      Left err ->+        Conn.sqlExecutionErrorSqlState err === Just (B8.pack "23505")++prop_uniqueConstraint :: Property.NamedDBProperty+prop_uniqueConstraint =+  Property.singletonNamedDBProperty "Creates a unique constraint that rejects duplicate records" $ \pool -> do+    originalFoo <- HH.forAll Foo.generate++    let+      fooTableWithUniqueNameConstraint =+        Orville.addTableConstraints+          [Orville.uniqueConstraint (Orville.fieldName Foo.fooNameField :| [])]+          Foo.table++      conflictingFoo =+        originalFoo {Foo.fooId = 1 + Foo.fooId originalFoo}++      insertFoos =+        TableDefinition.mkInsertExpr+          ReturningOption.WithoutReturning+          Foo.table+          (originalFoo :| [conflictingFoo])++    result <- MIO.liftIO . E.try . Conn.withPoolConnection pool $ \connection -> do+      TestTable.dropAndRecreateTableDef connection fooTableWithUniqueNameConstraint+      RawSql.executeVoid connection insertFoos++    case result of+      Right () -> do+        HH.footnote "Expected 'executeVoid' to return failure, but it did not"+        HH.failure+      Left err ->+        Conn.sqlExecutionErrorSqlState err === Just (B8.pack "23505")++prop_fieldConstraints :: Property.NamedProperty+prop_fieldConstraints =+  Property.singletonNamedProperty "Includes field constraints in table constraints" $ do+    let+      foreignTableId =+        Orville.unqualifiedNameToTableId "foreign_table"++      foreignFieldName =+        Orville.stringToFieldName "foreign_field"++      fieldWithoutConstraints =+        Orville.integerField "foo"++      fieldWithConstraints =+        Orville.addForeignKeyConstraint foreignTableId foreignFieldName+          . Orville.addUniqueConstraint+          $ fieldWithoutConstraints++      tableWithFieldConstraints =+        Orville.mkTableDefinitionWithoutKey+          "test_table"+          (Orville.marshallField id fieldWithConstraints)++      fieldName =+        Orville.fieldName fieldWithoutConstraints++      tableWithTableConstraints =+        Orville.addTableConstraints+          [ Orville.foreignKeyConstraint+              foreignTableId+              (Orville.foreignReference fieldName foreignFieldName :| [])+          , Orville.uniqueConstraint (fieldName :| [])+          ]+          $ Orville.mkTableDefinitionWithoutKey+            "test_table"+            (Orville.marshallField id fieldWithoutConstraints)++      tableConstraintKeys ::+        Orville.TableDefinition hasKey writeEntity readEntity ->+        Set.Set Orville.ConstraintMigrationKey+      tableConstraintKeys =+        ConstraintDefinition.tableConstraintKeys . Orville.tableConstraints++    tableConstraintKeys tableWithFieldConstraints === tableConstraintKeys tableWithTableConstraints
+ test/Test/TestTable.hs view
@@ -0,0 +1,45 @@+module Test.TestTable+  ( dropAndRecreateTableDef+  , dropTableDef+  , dropTableDefSql+  , dropTableNameSql+  )+where++import qualified Orville.PostgreSQL.Expr as Expr+import Orville.PostgreSQL.Raw.Connection (Connection)+import qualified Orville.PostgreSQL.Raw.RawSql as RawSql+import Orville.PostgreSQL.Schema (TableDefinition, mkCreateTableExpr, tableName)++dropTableDef ::+  Connection ->+  TableDefinition key writeEntity readEntity ->+  IO ()+dropTableDef connection tableDef = do+  RawSql.executeVoid connection (dropTableDefSql tableDef)++dropAndRecreateTableDef ::+  Connection ->+  TableDefinition key writeEntity readEntity ->+  IO ()+dropAndRecreateTableDef connection tableDef = do+  dropTableDef connection tableDef+  RawSql.executeVoid connection (mkCreateTableExpr tableDef)++dropTableDefSql ::+  TableDefinition key writeEntity readEntity ->+  RawSql.RawSql+dropTableDefSql =+  dropTableNameExprSql . tableName++dropTableNameSql ::+  String ->+  RawSql.RawSql+dropTableNameSql =+  dropTableNameExprSql . Expr.qualifyTable Nothing . Expr.tableName++dropTableNameExprSql ::+  Expr.Qualified Expr.TableName ->+  RawSql.RawSql+dropTableNameExprSql name =+  RawSql.fromString "DROP TABLE IF EXISTS " <> RawSql.toRawSql name
+ test/Test/Transaction.hs view
@@ -0,0 +1,238 @@+module Test.Transaction+  ( transactionTests+  )+where++import qualified Control.Monad as Monad+import qualified Data.ByteString as BS+import qualified Data.IORef as IORef+import qualified Data.Text as T+import Hedgehog ((===))+import qualified Hedgehog as HH+import qualified Hedgehog.Gen as Gen++import qualified Orville.PostgreSQL as Orville+import qualified Orville.PostgreSQL.Expr as Expr+import qualified Orville.PostgreSQL.OrvilleState as OrvilleState+import qualified Orville.PostgreSQL.Raw.Connection as Conn+import qualified Orville.PostgreSQL.Raw.RawSql as RawSql++import qualified Test.Property as Property+import qualified Test.TestTable as TestTable+import qualified Test.Transaction.Util as TransactionUtil++transactionTests :: Orville.ConnectionPool -> Property.Group+transactionTests pool =+  Property.group "Transaction" $+    [ prop_transactionsWithoutExceptionsCommit pool+    , prop_exceptionsLeadToTransactionRollback pool+    , prop_savepointsRollbackInnerTransactions pool+    , prop_callbacksMadeForTransactionCommit pool+    , prop_callbacksMadeForTransactionRollback pool+    , prop_usesCustomBeginTransactionSql pool+    ]++prop_transactionsWithoutExceptionsCommit :: Property.NamedDBProperty+prop_transactionsWithoutExceptionsCommit =+  Property.namedDBProperty "Transactions without exceptions perform a 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.runNestedTransactions nestingLevel $ \_ ->+            Monad.void $ Orville.insertEntity tracerTable Tracer+          Orville.findEntitiesBy tracerTable mempty++    length tracers === nestingLevel++prop_exceptionsLeadToTransactionRollback :: Property.NamedDBProperty+prop_exceptionsLeadToTransactionRollback =+  Property.namedDBProperty "Exceptions within transaction blocks execute rollbock" $ \pool -> do+    nestingLevel <- HH.forAll TransactionUtil.genNestingLevel++    tracers <-+      HH.evalIO $ do+        Conn.withPoolConnection pool $ \connection ->+          TestTable.dropAndRecreateTableDef connection tracerTable++        Orville.runOrville pool $ do+          TransactionUtil.silentlyHandleTestError $+            TransactionUtil.runNestedTransactions nestingLevel $ \level -> do+              _ <- Orville.insertEntity tracerTable Tracer+              Monad.when (level >= nestingLevel) TransactionUtil.throwTestError++          Orville.findEntitiesBy tracerTable mempty++    length tracers === 0++prop_savepointsRollbackInnerTransactions :: Property.NamedDBProperty+prop_savepointsRollbackInnerTransactions =+  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.runNestedTransactions innerNestingLevel $ \level -> do+          _ <- Orville.insertEntity tracerTable Tracer+          Monad.when (level >= innerNestingLevel) TransactionUtil.throwTestError++      outerActions =+        TransactionUtil.runNestedTransactions outerNestingLevel $ \level -> do+          _ <- Orville.insertEntity tracerTable Tracer+          Monad.when (level >= outerNestingLevel) $+            TransactionUtil.silentlyHandleTestError 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+    nestingLevel <- HH.forAll TransactionUtil.genNestingLevel++    allEvents <-+      captureTransactionCallbackEvents pool $+        TransactionUtil.runNestedTransactions nestingLevel (\_ -> pure ())++    let+      expectedEvents =+        mkExpectedEventsForNestedActions nestingLevel $ \maybeSavepoint ->+          case maybeSavepoint of+            Nothing -> (Orville.BeginTransaction, Orville.CommitTransaction)+            Just savepoint -> (Orville.NewSavepoint savepoint, Orville.ReleaseSavepoint savepoint)++    allEvents === expectedEvents++prop_callbacksMadeForTransactionRollback :: Property.NamedDBProperty+prop_callbacksMadeForTransactionRollback =+  Property.namedDBProperty "Callbacks are delivered for a transaction this is rolled back" $ \pool -> do+    nestingLevel <- HH.forAll TransactionUtil.genNestingLevel++    allEvents <- captureTransactionCallbackEvents pool $+      TransactionUtil.runNestedTransactions nestingLevel $ \level ->+        Monad.when (level >= nestingLevel) (TransactionUtil.throwTestError)++    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+    customExpr <-+      HH.forAllWith (show . RawSql.toExampleBytes) $+        Gen.element+          [ Expr.beginTransaction Nothing+          , Expr.beginTransaction (Just Expr.readOnly)+          , Expr.beginTransaction (Just Expr.readWrite)+          , Expr.beginTransaction (Just Expr.deferrable)+          , Expr.beginTransaction (Just Expr.notDeferrable)+          , Expr.beginTransaction (Just (Expr.isolationLevel Expr.serializable))+          , Expr.beginTransaction (Just (Expr.isolationLevel Expr.repeatableRead))+          , Expr.beginTransaction (Just (Expr.isolationLevel Expr.readCommitted))+          , Expr.beginTransaction (Just (Expr.isolationLevel Expr.readUncommitted))+          ]++    sqlTrace <-+      captureSqlTrace pool $ do+        Orville.localOrvilleState+          (Orville.setBeginTransactionExpr customExpr)+          (Orville.withTransaction $ pure ())++    sqlTrace+      === [ (Orville.OtherQuery, RawSql.toExampleBytes Expr.commit)+          , (Orville.OtherQuery, RawSql.toExampleBytes customExpr)+          ]++captureTransactionCallbackEvents ::+  Orville.ConnectionPool ->+  Orville.Orville () ->+  HH.PropertyT IO [Orville.TransactionEvent]+captureTransactionCallbackEvents pool actions = do+  callbackEventsRef <- HH.evalIO $ IORef.newIORef []++  let+    captureEvent event =+      IORef.modifyIORef callbackEventsRef (event :)++    addEventCaptureCallback =+      Orville.addTransactionCallback captureEvent++  HH.evalIO $ do+    Orville.runOrville pool $+      TransactionUtil.silentlyHandleTestError $+        Orville.localOrvilleState addEventCaptureCallback actions++    reverse <$> IORef.readIORef callbackEventsRef++mkExpectedEventsForNestedActions ::+  Int ->+  (Maybe Orville.Savepoint -> (Orville.TransactionEvent, Orville.TransactionEvent)) ->+  [Orville.TransactionEvent]+mkExpectedEventsForNestedActions nestingLevel mkEventsForLevel =+  let+    appendEvents mbSavepoint (befores, afters) =+      let+        (before, after) = mkEventsForLevel mbSavepoint+      in+        (before : befores, after : afters)++    savepoints =+      iterate OrvilleState.nextSavepoint OrvilleState.initialSavepoint++    (allBefores, allAfters) =+      foldr appendEvents ([], []) $+        take nestingLevel (Nothing : map Just savepoints)+  in+    allBefores ++ reverse allAfters++data Tracer+  = Tracer++tracerTable :: Orville.TableDefinition Orville.NoKey Tracer Tracer+tracerTable =+  Orville.mkTableDefinitionWithoutKey "tracer" tracerMarshaller++tracerMarshaller :: Orville.SqlMarshaller Tracer Tracer+tracerMarshaller =+  const Tracer+    <$> Orville.marshallField (const $ T.pack "tracer") (Orville.unboundedTextField "tracer")++captureSqlTrace ::+  Orville.ConnectionPool ->+  Orville.Orville () ->+  HH.PropertyT IO [(Orville.QueryType, BS.ByteString)]+captureSqlTrace pool actions = do+  queryTraceRef <- HH.evalIO $ IORef.newIORef []++  let+    captureQuery :: Orville.QueryType -> RawSql.RawSql -> IO a -> IO a+    captureQuery queryType sql action = do+      IORef.modifyIORef queryTraceRef ((queryType, RawSql.toExampleBytes sql) :)+      action++  HH.evalIO $ do+    Orville.runOrville pool $+      Orville.localOrvilleState+        (Orville.addSqlExecutionCallback captureQuery)+        actions++    IORef.readIORef queryTraceRef
+ test/Test/Transaction/Util.hs view
@@ -0,0 +1,65 @@+module Test.Transaction.Util+  ( TestError+  , throwTestError+  , silentlyHandleTestError+  , genNestingLevel+  , runNestedTransactions+  , runNestedTransactionItems+  , transationNestingLevelRange+  )+where++import qualified Control.Exception.Safe as ExSafe+import qualified Hedgehog as HH+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import qualified Orville.PostgreSQL as Orville++data TestError+  = TestError+  deriving (Show)++instance ExSafe.Exception TestError++runNestedTransactions ::+  Orville.MonadOrville m =>+  Int ->+  (Int -> m ()) ->+  m ()+runNestedTransactions maxLevel =+  runNestedTransactionItems [1 .. maxLevel]++runNestedTransactionItems ::+  Orville.MonadOrville m =>+  [a] ->+  (a -> m ()) ->+  m ()+runNestedTransactionItems items doLevel =+  let+    go is =+      case is of+        [] ->+          pure ()+        (item : rest) ->+          Orville.withTransaction $ do+            doLevel item+            go rest+  in+    go items++throwTestError :: ExSafe.MonadThrow m => m a+throwTestError =+  ExSafe.throw TestError++silentlyHandleTestError :: ExSafe.MonadCatch m => m () -> m ()+silentlyHandleTestError =+  ExSafe.handle (\TestError -> pure ())++genNestingLevel :: HH.Gen Int+genNestingLevel =+  Gen.integral transationNestingLevelRange++transationNestingLevelRange :: HH.Range Int+transationNestingLevelRange =+  Range.linear 0 6