diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# ChangeLog + +## v1.0.0.0 + +First official release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/orville-postgresql.cabal b/orville-postgresql.cabal new file mode 100644 --- /dev/null +++ b/orville-postgresql.cabal @@ -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 diff --git a/src/Orville/PostgreSQL.hs b/src/Orville/PostgreSQL.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL.hs @@ -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.. + 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 @. + +@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" diff --git a/src/Orville/PostgreSQL/ErrorDetailLevel.hs b/src/Orville/PostgreSQL/ErrorDetailLevel.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/ErrorDetailLevel.hs @@ -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]" diff --git a/src/Orville/PostgreSQL/Execution.hs b/src/Orville/PostgreSQL/Execution.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Execution.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Execution/Cursor.hs b/src/Orville/PostgreSQL/Execution/Cursor.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Execution/Cursor.hs @@ -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) diff --git a/src/Orville/PostgreSQL/Execution/Delete.hs b/src/Orville/PostgreSQL/Execution/Delete.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Execution/Delete.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Execution/EntityOperations.hs b/src/Orville/PostgreSQL/Execution/EntityOperations.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Execution/EntityOperations.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Execution/Execute.hs b/src/Orville/PostgreSQL/Execution/Execute.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Execution/Execute.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Execution/ExecutionResult.hs b/src/Orville/PostgreSQL/Execution/ExecutionResult.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Execution/ExecutionResult.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Execution/Insert.hs b/src/Orville/PostgreSQL/Execution/Insert.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Execution/Insert.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Execution/QueryType.hs b/src/Orville/PostgreSQL/Execution/QueryType.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Execution/QueryType.hs @@ -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 + ) diff --git a/src/Orville/PostgreSQL/Execution/ReturningOption.hs b/src/Orville/PostgreSQL/Execution/ReturningOption.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Execution/ReturningOption.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Execution/Select.hs b/src/Orville/PostgreSQL/Execution/Select.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Execution/Select.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Execution/SelectOptions.hs b/src/Orville/PostgreSQL/Execution/SelectOptions.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Execution/SelectOptions.hs @@ -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) + ) diff --git a/src/Orville/PostgreSQL/Execution/Sequence.hs b/src/Orville/PostgreSQL/Execution/Sequence.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Execution/Sequence.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Execution/Transaction.hs b/src/Orville/PostgreSQL/Execution/Transaction.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Execution/Transaction.hs @@ -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) diff --git a/src/Orville/PostgreSQL/Execution/Update.hs b/src/Orville/PostgreSQL/Execution/Update.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Execution/Update.hs @@ -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) diff --git a/src/Orville/PostgreSQL/Expr.hs b/src/Orville/PostgreSQL/Expr.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Expr/BinaryOperator.hs b/src/Orville/PostgreSQL/Expr/BinaryOperator.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/BinaryOperator.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Expr/ColumnDefinition.hs b/src/Orville/PostgreSQL/Expr/ColumnDefinition.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/ColumnDefinition.hs @@ -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) diff --git a/src/Orville/PostgreSQL/Expr/Count.hs b/src/Orville/PostgreSQL/Expr/Count.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/Count.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Expr/Cursor.hs b/src/Orville/PostgreSQL/Expr/Cursor.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/Cursor.hs @@ -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" diff --git a/src/Orville/PostgreSQL/Expr/DataType.hs b/src/Orville/PostgreSQL/Expr/DataType.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/DataType.hs @@ -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") diff --git a/src/Orville/PostgreSQL/Expr/Delete.hs b/src/Orville/PostgreSQL/Expr/Delete.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/Delete.hs @@ -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 + ] diff --git a/src/Orville/PostgreSQL/Expr/GroupBy.hs b/src/Orville/PostgreSQL/Expr/GroupBy.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/GroupBy.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Expr/IfExists.hs b/src/Orville/PostgreSQL/Expr/IfExists.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/IfExists.hs @@ -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" diff --git a/src/Orville/PostgreSQL/Expr/Index.hs b/src/Orville/PostgreSQL/Expr/Index.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/Index.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Expr/Insert.hs b/src/Orville/PostgreSQL/Expr/Insert.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/Insert.hs @@ -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 + ] diff --git a/src/Orville/PostgreSQL/Expr/Internal/Name/ColumnName.hs b/src/Orville/PostgreSQL/Expr/Internal/Name/ColumnName.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/Internal/Name/ColumnName.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Expr/Internal/Name/ConstraintName.hs b/src/Orville/PostgreSQL/Expr/Internal/Name/ConstraintName.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/Internal/Name/ConstraintName.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Expr/Internal/Name/CursorName.hs b/src/Orville/PostgreSQL/Expr/Internal/Name/CursorName.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/Internal/Name/CursorName.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Expr/Internal/Name/FunctionName.hs b/src/Orville/PostgreSQL/Expr/Internal/Name/FunctionName.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/Internal/Name/FunctionName.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Expr/Internal/Name/Identifier.hs b/src/Orville/PostgreSQL/Expr/Internal/Name/Identifier.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/Internal/Name/Identifier.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Expr/Internal/Name/IndexName.hs b/src/Orville/PostgreSQL/Expr/Internal/Name/IndexName.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/Internal/Name/IndexName.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Expr/Internal/Name/Qualified.hs b/src/Orville/PostgreSQL/Expr/Internal/Name/Qualified.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/Internal/Name/Qualified.hs @@ -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) + ) diff --git a/src/Orville/PostgreSQL/Expr/Internal/Name/SavepointName.hs b/src/Orville/PostgreSQL/Expr/Internal/Name/SavepointName.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/Internal/Name/SavepointName.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Expr/Internal/Name/SchemaName.hs b/src/Orville/PostgreSQL/Expr/Internal/Name/SchemaName.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/Internal/Name/SchemaName.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Expr/Internal/Name/SequenceName.hs b/src/Orville/PostgreSQL/Expr/Internal/Name/SequenceName.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/Internal/Name/SequenceName.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Expr/Internal/Name/TableName.hs b/src/Orville/PostgreSQL/Expr/Internal/Name/TableName.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/Internal/Name/TableName.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Expr/LimitExpr.hs b/src/Orville/PostgreSQL/Expr/LimitExpr.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/LimitExpr.hs @@ -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) diff --git a/src/Orville/PostgreSQL/Expr/Math.hs b/src/Orville/PostgreSQL/Expr/Math.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/Math.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Expr/Name.hs b/src/Orville/PostgreSQL/Expr/Name.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/Name.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Expr/OffsetExpr.hs b/src/Orville/PostgreSQL/Expr/OffsetExpr.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/OffsetExpr.hs @@ -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) diff --git a/src/Orville/PostgreSQL/Expr/OrderBy.hs b/src/Orville/PostgreSQL/Expr/OrderBy.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/OrderBy.hs @@ -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" diff --git a/src/Orville/PostgreSQL/Expr/Query.hs b/src/Orville/PostgreSQL/Expr/Query.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/Query.hs @@ -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 + ] diff --git a/src/Orville/PostgreSQL/Expr/ReturningExpr.hs b/src/Orville/PostgreSQL/Expr/ReturningExpr.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/ReturningExpr.hs @@ -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 @. + +@since 1.0.0.0 +-} +returningExpr :: SelectList -> ReturningExpr +returningExpr selectList = + ReturningExpr $ + RawSql.fromString "RETURNING " + <> RawSql.toRawSql selectList diff --git a/src/Orville/PostgreSQL/Expr/Select.hs b/src/Orville/PostgreSQL/Expr/Select.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/Select.hs @@ -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 -> "" diff --git a/src/Orville/PostgreSQL/Expr/SequenceDefinition.hs b/src/Orville/PostgreSQL/Expr/SequenceDefinition.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/SequenceDefinition.hs @@ -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" diff --git a/src/Orville/PostgreSQL/Expr/TableConstraint.hs b/src/Orville/PostgreSQL/Expr/TableConstraint.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/TableConstraint.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Expr/TableDefinition.hs b/src/Orville/PostgreSQL/Expr/TableDefinition.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/TableDefinition.hs @@ -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) + ] + ) diff --git a/src/Orville/PostgreSQL/Expr/TableReferenceList.hs b/src/Orville/PostgreSQL/Expr/TableReferenceList.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/TableReferenceList.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Expr/Time.hs b/src/Orville/PostgreSQL/Expr/Time.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/Time.hs @@ -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" diff --git a/src/Orville/PostgreSQL/Expr/Transaction.hs b/src/Orville/PostgreSQL/Expr/Transaction.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/Transaction.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Expr/Update.hs b/src/Orville/PostgreSQL/Expr/Update.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/Update.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Expr/ValueExpression.hs b/src/Orville/PostgreSQL/Expr/ValueExpression.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/ValueExpression.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Expr/WhereClause.hs b/src/Orville/PostgreSQL/Expr/WhereClause.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Expr/WhereClause.hs @@ -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 + +@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" diff --git a/src/Orville/PostgreSQL/Internal/Bracket.hs b/src/Orville/PostgreSQL/Internal/Bracket.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Internal/Bracket.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Internal/Extra/NonEmpty.hs b/src/Orville/PostgreSQL/Internal/Extra/NonEmpty.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Internal/Extra/NonEmpty.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Internal/FieldName.hs b/src/Orville/PostgreSQL/Internal/FieldName.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Internal/FieldName.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Internal/IndexDefinition.hs b/src/Orville/PostgreSQL/Internal/IndexDefinition.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Internal/IndexDefinition.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Internal/MigrationLock.hs b/src/Orville/PostgreSQL/Internal/MigrationLock.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Internal/MigrationLock.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Internal/MonadOrville.hs b/src/Orville/PostgreSQL/Internal/MonadOrville.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Internal/MonadOrville.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Internal/OrvilleState.hs b/src/Orville/PostgreSQL/Internal/OrvilleState.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Internal/OrvilleState.hs @@ -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 + } diff --git a/src/Orville/PostgreSQL/Internal/RowCountExpectation.hs b/src/Orville/PostgreSQL/Internal/RowCountExpectation.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Internal/RowCountExpectation.hs @@ -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) diff --git a/src/Orville/PostgreSQL/Marshall.hs b/src/Orville/PostgreSQL/Marshall.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Marshall.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Marshall/DefaultValue.hs b/src/Orville/PostgreSQL/Marshall/DefaultValue.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Marshall/DefaultValue.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Marshall/FieldDefinition.hs b/src/Orville/PostgreSQL/Marshall/FieldDefinition.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Marshall/FieldDefinition.hs @@ -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 + , (. 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 '. 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 +-} +(. NonEmpty a -> Expr.BooleanExpr +(. + 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 diff --git a/src/Orville/PostgreSQL/Marshall/MarshallError.hs b/src/Orville/PostgreSQL/Marshall/MarshallError.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Marshall/MarshallError.hs @@ -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 + , "]" + ] diff --git a/src/Orville/PostgreSQL/Marshall/SqlMarshaller.hs b/src/Orville/PostgreSQL/Marshall/SqlMarshaller.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Marshall/SqlMarshaller.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Marshall/SqlType.hs b/src/Orville/PostgreSQL/Marshall/SqlType.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Marshall/SqlType.hs @@ -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) diff --git a/src/Orville/PostgreSQL/Marshall/SyntheticField.hs b/src/Orville/PostgreSQL/Marshall/SyntheticField.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Marshall/SyntheticField.hs @@ -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)) + } diff --git a/src/Orville/PostgreSQL/Monad.hs b/src/Orville/PostgreSQL/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Monad.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Monad/HasOrvilleState.hs b/src/Orville/PostgreSQL/Monad/HasOrvilleState.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Monad/HasOrvilleState.hs @@ -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) diff --git a/src/Orville/PostgreSQL/Monad/MonadOrville.hs b/src/Orville/PostgreSQL/Monad/MonadOrville.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Monad/MonadOrville.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Monad/Orville.hs b/src/Orville/PostgreSQL/Monad/Orville.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Monad/Orville.hs @@ -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 diff --git a/src/Orville/PostgreSQL/OrvilleState.hs b/src/Orville/PostgreSQL/OrvilleState.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/OrvilleState.hs @@ -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 diff --git a/src/Orville/PostgreSQL/PgCatalog.hs b/src/Orville/PostgreSQL/PgCatalog.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/PgCatalog.hs @@ -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 diff --git a/src/Orville/PostgreSQL/PgCatalog/DatabaseDescription.hs b/src/Orville/PostgreSQL/PgCatalog/DatabaseDescription.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/PgCatalog/DatabaseDescription.hs @@ -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)) diff --git a/src/Orville/PostgreSQL/PgCatalog/OidField.hs b/src/Orville/PostgreSQL/PgCatalog/OidField.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/PgCatalog/OidField.hs @@ -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 diff --git a/src/Orville/PostgreSQL/PgCatalog/PgAttribute.hs b/src/Orville/PostgreSQL/PgCatalog/PgAttribute.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/PgCatalog/PgAttribute.hs @@ -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" diff --git a/src/Orville/PostgreSQL/PgCatalog/PgAttributeDefault.hs b/src/Orville/PostgreSQL/PgCatalog/PgAttributeDefault.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/PgCatalog/PgAttributeDefault.hs @@ -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 diff --git a/src/Orville/PostgreSQL/PgCatalog/PgClass.hs b/src/Orville/PostgreSQL/PgCatalog/PgClass.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/PgCatalog/PgClass.hs @@ -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) diff --git a/src/Orville/PostgreSQL/PgCatalog/PgConstraint.hs b/src/Orville/PostgreSQL/PgCatalog/PgConstraint.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/PgCatalog/PgConstraint.hs @@ -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 '}' diff --git a/src/Orville/PostgreSQL/PgCatalog/PgIndex.hs b/src/Orville/PostgreSQL/PgCatalog/PgIndex.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/PgCatalog/PgIndex.hs @@ -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 diff --git a/src/Orville/PostgreSQL/PgCatalog/PgNamespace.hs b/src/Orville/PostgreSQL/PgCatalog/PgNamespace.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/PgCatalog/PgNamespace.hs @@ -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" diff --git a/src/Orville/PostgreSQL/PgCatalog/PgSequence.hs b/src/Orville/PostgreSQL/PgCatalog/PgSequence.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/PgCatalog/PgSequence.hs @@ -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" diff --git a/src/Orville/PostgreSQL/Plan.hs b/src/Orville/PostgreSQL/Plan.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Plan.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Plan/Explanation.hs b/src/Orville/PostgreSQL/Plan/Explanation.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Plan/Explanation.hs @@ -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 [] diff --git a/src/Orville/PostgreSQL/Plan/Many.hs b/src/Orville/PostgreSQL/Plan/Many.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Plan/Many.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Plan/Operation.hs b/src/Orville/PostgreSQL/Plan/Operation.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Plan/Operation.hs @@ -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) + } diff --git a/src/Orville/PostgreSQL/Plan/Syntax.hs b/src/Orville/PostgreSQL/Plan/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Plan/Syntax.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Raw/Connection.hs b/src/Orville/PostgreSQL/Raw/Connection.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Raw/Connection.hs @@ -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 + . + +@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 + + + 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 -> + "" + 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 diff --git a/src/Orville/PostgreSQL/Raw/PgTextFormatValue.hs b/src/Orville/PostgreSQL/Raw/PgTextFormatValue.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Raw/PgTextFormatValue.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Raw/PgTime.hs b/src/Orville/PostgreSQL/Raw/PgTime.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Raw/PgTime.hs @@ -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)) diff --git a/src/Orville/PostgreSQL/Raw/RawSql.hs b/src/Orville/PostgreSQL/Raw/RawSql.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Raw/RawSql.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Raw/SqlCommenter.hs b/src/Orville/PostgreSQL/Raw/SqlCommenter.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Raw/SqlCommenter.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Raw/SqlValue.hs b/src/Orville/PostgreSQL/Raw/SqlValue.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Raw/SqlValue.hs @@ -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) diff --git a/src/Orville/PostgreSQL/Schema.hs b/src/Orville/PostgreSQL/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Schema.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Schema/ConstraintDefinition.hs b/src/Orville/PostgreSQL/Schema/ConstraintDefinition.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Schema/ConstraintDefinition.hs @@ -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 + } diff --git a/src/Orville/PostgreSQL/Schema/IndexDefinition.hs b/src/Orville/PostgreSQL/Schema/IndexDefinition.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Schema/IndexDefinition.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Schema/PrimaryKey.hs b/src/Orville/PostgreSQL/Schema/PrimaryKey.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Schema/PrimaryKey.hs @@ -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) diff --git a/src/Orville/PostgreSQL/Schema/SequenceDefinition.hs b/src/Orville/PostgreSQL/Schema/SequenceDefinition.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Schema/SequenceDefinition.hs @@ -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) diff --git a/src/Orville/PostgreSQL/Schema/SequenceIdentifier.hs b/src/Orville/PostgreSQL/Schema/SequenceIdentifier.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Schema/SequenceIdentifier.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Schema/TableDefinition.hs b/src/Orville/PostgreSQL/Schema/TableDefinition.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Schema/TableDefinition.hs @@ -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 diff --git a/src/Orville/PostgreSQL/Schema/TableIdentifier.hs b/src/Orville/PostgreSQL/Schema/TableIdentifier.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/Schema/TableIdentifier.hs @@ -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 diff --git a/src/Orville/PostgreSQL/UnliftIO.hs b/src/Orville/PostgreSQL/UnliftIO.hs new file mode 100644 --- /dev/null +++ b/src/Orville/PostgreSQL/UnliftIO.hs @@ -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)) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 diff --git a/test/Test/AutoMigration.hs b/test/Test/AutoMigration.hs new file mode 100644 --- /dev/null +++ b/test/Test/AutoMigration.hs @@ -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 diff --git a/test/Test/Connection.hs b/test/Test/Connection.hs new file mode 100644 --- /dev/null +++ b/test/Test/Connection.hs @@ -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 diff --git a/test/Test/Cursor.hs b/test/Test/Cursor.hs new file mode 100644 --- /dev/null +++ b/test/Test/Cursor.hs @@ -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) diff --git a/test/Test/Entities/Bar.hs b/test/Test/Entities/Bar.hs new file mode 100644 --- /dev/null +++ b/test/Test/Entities/Bar.hs @@ -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 diff --git a/test/Test/Entities/CompositeKeyEntity.hs b/test/Test/Entities/CompositeKeyEntity.hs new file mode 100644 --- /dev/null +++ b/test/Test/Entities/CompositeKeyEntity.hs @@ -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 diff --git a/test/Test/Entities/Foo.hs b/test/Test/Entities/Foo.hs new file mode 100644 --- /dev/null +++ b/test/Test/Entities/Foo.hs @@ -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 diff --git a/test/Test/Entities/FooChild.hs b/test/Test/Entities/FooChild.hs new file mode 100644 --- /dev/null +++ b/test/Test/Entities/FooChild.hs @@ -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 diff --git a/test/Test/Entities/User.hs b/test/Test/Entities/User.hs new file mode 100644 --- /dev/null +++ b/test/Test/Entities/User.hs @@ -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) diff --git a/test/Test/EntityOperations.hs b/test/Test/EntityOperations.hs new file mode 100644 --- /dev/null +++ b/test/Test/EntityOperations.hs @@ -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 === [] diff --git a/test/Test/Execution.hs b/test/Test/Execution.hs new file mode 100644 --- /dev/null +++ b/test/Test/Execution.hs @@ -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 diff --git a/test/Test/Expr/Count.hs b/test/Test/Expr/Count.hs new file mode 100644 --- /dev/null +++ b/test/Test/Expr/Count.hs @@ -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] diff --git a/test/Test/Expr/Cursor.hs b/test/Test/Expr/Cursor.hs new file mode 100644 --- /dev/null +++ b/test/Test/Expr/Cursor.hs @@ -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 diff --git a/test/Test/Expr/GroupBy.hs b/test/Test/Expr/GroupBy.hs new file mode 100644 --- /dev/null +++ b/test/Test/Expr/GroupBy.hs @@ -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)") diff --git a/test/Test/Expr/GroupByOrderBy.hs b/test/Test/Expr/GroupByOrderBy.hs new file mode 100644 --- /dev/null +++ b/test/Test/Expr/GroupByOrderBy.hs @@ -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)") diff --git a/test/Test/Expr/InsertUpdateDelete.hs b/test/Test/Expr/InsertUpdateDelete.hs new file mode 100644 --- /dev/null +++ b/test/Test/Expr/InsertUpdateDelete.hs @@ -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 diff --git a/test/Test/Expr/Math.hs b/test/Test/Expr/Math.hs new file mode 100644 --- /dev/null +++ b/test/Test/Expr/Math.hs @@ -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 diff --git a/test/Test/Expr/OrderBy.hs b/test/Test/Expr/OrderBy.hs new file mode 100644 --- /dev/null +++ b/test/Test/Expr/OrderBy.hs @@ -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) diff --git a/test/Test/Expr/SequenceDefinition.hs b/test/Test/Expr/SequenceDefinition.hs new file mode 100644 --- /dev/null +++ b/test/Test/Expr/SequenceDefinition.hs @@ -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" diff --git a/test/Test/Expr/TableDefinition.hs b/test/Test/Expr/TableDefinition.hs new file mode 100644 --- /dev/null +++ b/test/Test/Expr/TableDefinition.hs @@ -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" diff --git a/test/Test/Expr/TestSchema.hs b/test/Test/Expr/TestSchema.hs new file mode 100644 --- /dev/null +++ b/test/Test/Expr/TestSchema.hs @@ -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))) diff --git a/test/Test/Expr/Time.hs b/test/Test/Expr/Time.hs new file mode 100644 --- /dev/null +++ b/test/Test/Expr/Time.hs @@ -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 + ] diff --git a/test/Test/Expr/Where.hs b/test/Test/Expr/Where.hs new file mode 100644 --- /dev/null +++ b/test/Test/Expr/Where.hs @@ -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) diff --git a/test/Test/FieldDefinition.hs b/test/Test/FieldDefinition.hs new file mode 100644 --- /dev/null +++ b/test/Test/FieldDefinition.hs @@ -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 [] diff --git a/test/Test/MarshallError.hs b/test/Test/MarshallError.hs new file mode 100644 --- /dev/null +++ b/test/Test/MarshallError.hs @@ -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 diff --git a/test/Test/PgAssert.hs b/test/Test/PgAssert.hs new file mode 100644 --- /dev/null +++ b/test/Test/PgAssert.hs @@ -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) diff --git a/test/Test/PgCatalog.hs b/test/Test/PgCatalog.hs new file mode 100644 --- /dev/null +++ b/test/Test/PgCatalog.hs @@ -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 diff --git a/test/Test/PgGen.hs b/test/Test/PgGen.hs new file mode 100644 --- /dev/null +++ b/test/Test/PgGen.hs @@ -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) diff --git a/test/Test/PgTime.hs b/test/Test/PgTime.hs new file mode 100644 --- /dev/null +++ b/test/Test/PgTime.hs @@ -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)) + ) + ] diff --git a/test/Test/Plan.hs b/test/Test/Plan.hs new file mode 100644 --- /dev/null +++ b/test/Test/Plan.hs @@ -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 diff --git a/test/Test/PostgreSQLAxioms.hs b/test/Test/PostgreSQLAxioms.hs new file mode 100644 --- /dev/null +++ b/test/Test/PostgreSQLAxioms.hs @@ -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 diff --git a/test/Test/Property.hs b/test/Test/Property.hs new file mode 100644 --- /dev/null +++ b/test/Test/Property.hs @@ -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 diff --git a/test/Test/RawSql.hs b/test/Test/RawSql.hs new file mode 100644 --- /dev/null +++ b/test/Test/RawSql.hs @@ -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 diff --git a/test/Test/ReservedWords.hs b/test/Test/ReservedWords.hs new file mode 100644 --- /dev/null +++ b/test/Test/ReservedWords.hs @@ -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] + ) + ] diff --git a/test/Test/SelectOptions.hs b/test/Test/SelectOptions.hs new file mode 100644 --- /dev/null +++ b/test/Test/SelectOptions.hs @@ -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 + . 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 ". 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" diff --git a/test/Test/Sequence.hs b/test/Test/Sequence.hs new file mode 100644 --- /dev/null +++ b/test/Test/Sequence.hs @@ -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 diff --git a/test/Test/SqlCommenter.hs b/test/Test/SqlCommenter.hs new file mode 100644 --- /dev/null +++ b/test/Test/SqlCommenter.hs @@ -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") + ] diff --git a/test/Test/SqlMarshaller.hs b/test/Test/SqlMarshaller.hs new file mode 100644 --- /dev/null +++ b/test/Test/SqlMarshaller.hs @@ -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 diff --git a/test/Test/SqlType.hs b/test/Test/SqlType.hs new file mode 100644 --- /dev/null +++ b/test/Test/SqlType.hs @@ -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 diff --git a/test/Test/TableDefinition.hs b/test/Test/TableDefinition.hs new file mode 100644 --- /dev/null +++ b/test/Test/TableDefinition.hs @@ -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 diff --git a/test/Test/TestTable.hs b/test/Test/TestTable.hs new file mode 100644 --- /dev/null +++ b/test/Test/TestTable.hs @@ -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 diff --git a/test/Test/Transaction.hs b/test/Test/Transaction.hs new file mode 100644 --- /dev/null +++ b/test/Test/Transaction.hs @@ -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 diff --git a/test/Test/Transaction/Util.hs b/test/Test/Transaction/Util.hs new file mode 100644 --- /dev/null +++ b/test/Test/Transaction/Util.hs @@ -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