diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,17 +1,28 @@ +# 0.5.4.0 + +## Added features + + * Better error messages on column type mismatches (#696). + * Added support for creating and dropping database schemas and associated tables with `createDatabaseSchema`, `dropDatabaseSchema`, `` and `createTableWithSchema` (#716). + +## Documentation + + * Make `runBeamPostgres` and `runBeamPostgresDebug` easier to find (#663). + # 0.5.3.1 -# Added features +## Added features * Loosen some version bounds # 0.5.3.0 -# Bug fixes +## Bug fixes * Make sure lateral join names do not overlap * Fix `bool_or` -# Addded features +## Addded features * Add `runSelectReturningFirst` * `IN (SELECT ...)` syntax via `inQuery_` diff --git a/Database/Beam/Postgres.hs b/Database/Beam/Postgres.hs --- a/Database/Beam/Postgres.hs +++ b/Database/Beam/Postgres.hs @@ -21,6 +21,9 @@ ( -- * Beam Postgres backend Postgres(..), Pg, liftIOWithHandle + -- ** Executing actions against the backend + , runBeamPostgres, runBeamPostgresDebug + -- ** Postgres syntax , PgCommandSyntax, PgSyntax , PgSelectSyntax, PgInsertSyntax @@ -40,8 +43,6 @@ , smallserial, serial, bigserial , module Database.Beam.Postgres.PgSpecific - - , runBeamPostgres, runBeamPostgresDebug -- ** Postgres extension support , PgExtensionEntity, IsPgExtension(..) diff --git a/Database/Beam/Postgres/Connection.hs b/Database/Beam/Postgres/Connection.hs --- a/Database/Beam/Postgres/Connection.hs +++ b/Database/Beam/Postgres/Connection.hs @@ -154,12 +154,14 @@ case pgErr of Pg.ConversionFailed { Pg.errSQLType = sql , Pg.errHaskellType = hs - , Pg.errMessage = msg } -> - pure (ColumnTypeMismatch hs sql msg) + , Pg.errMessage = msg + , Pg.errSQLField = field } -> + pure (ColumnTypeMismatch hs sql ("Conversion failed for field'" <> field <> "': " <> msg)) Pg.Incompatible { Pg.errSQLType = sql , Pg.errHaskellType = hs - , Pg.errMessage = msg } -> - pure (ColumnTypeMismatch hs sql msg) + , Pg.errMessage = msg + , Pg.errSQLField = field } -> + pure (ColumnTypeMismatch hs sql ("Incompatible field: '" <> field <> "': " <> msg)) Pg.UnexpectedNull {} -> pure ColumnUnexpectedNull in pure (Left (BeamRowReadError (Just (fromIntegral curCol)) err)) @@ -307,6 +309,8 @@ -- @beam-postgres@ also provides functions that let you run queries without -- 'MonadBeam'. These functions may be more efficient and offer a conduit -- API. See "Database.Beam.Postgres.Conduit" for more information. +-- +-- You can execute 'Pg' actions using 'runBeamPostgres' or 'runBeamPostgresDebug'. newtype Pg a = Pg { runPg :: F PgF a } deriving (Monad, Applicative, Functor, MonadFree PgF) diff --git a/Database/Beam/Postgres/Full.hs b/Database/Beam/Postgres/Full.hs --- a/Database/Beam/Postgres/Full.hs +++ b/Database/Beam/Postgres/Full.hs @@ -4,6 +4,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeOperators #-} -- | Module providing (almost) full support for Postgres query and data -- manipulation statements. These functions shadow the functions in @@ -64,6 +65,7 @@ import Control.Monad.Free.Church +import Data.Kind (Type) import Data.Proxy (Proxy(..)) import qualified Data.Text as T #if !MIN_VERSION_base(4, 11, 0) @@ -229,7 +231,7 @@ -- | What to do when an @INSERT@ statement inserts a row into the table @tbl@ -- that violates a constraint. -newtype PgInsertOnConflict (tbl :: (* -> *) -> *) = +newtype PgInsertOnConflict (tbl :: (Type -> Type) -> Type) = PgInsertOnConflict (tbl (QField QInternal) -> PgInsertOnConflictSyntax) -- | Postgres @LATERAL JOIN@ support @@ -397,7 +399,7 @@ -- * General @RETURNING@ support class PgReturning cmd where - type PgReturningType cmd :: * -> * + type PgReturningType cmd :: Type -> Type returning :: (Beamable tbl, Projectible Postgres a) => cmd Postgres tbl -> (tbl (QExpr Postgres PostgresInaccessible) -> a) diff --git a/Database/Beam/Postgres/Migrate.hs b/Database/Beam/Postgres/Migrate.hs --- a/Database/Beam/Postgres/Migrate.hs +++ b/Database/Beam/Postgres/Migrate.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -29,7 +31,7 @@ ) where import Database.Beam.Backend.SQL -import Database.Beam.Migrate.Actions (defaultActionProvider) +import Database.Beam.Migrate.Actions (defaultActionProvider, defaultSchemaActionProvider) import qualified Database.Beam.Migrate.Backend as Tool import qualified Database.Beam.Migrate.Checks as Db import qualified Database.Beam.Migrate.SQL as Db @@ -77,6 +79,8 @@ #endif import Data.Word (Word64) +import GHC.Generics ( Generic ) + -- | Top-level migration backend for use by @beam-migrate@ tools migrationBackend :: Tool.BeamMigrationBackend Postgres Pg migrationBackend = Tool.BeamMigrationBackend @@ -95,8 +99,12 @@ postgresDataTypeDeserializers <> Db.beamCheckDeserializers) (BCL.unpack . (<> ";") . pgRenderSyntaxScript . fromPgCommand) "postgres.sql" - pgPredConverter (defaultActionProvider <> pgExtensionActionProvider <> - pgCustomEnumActionProvider) + pgPredConverter (mconcat [ defaultActionProvider + , defaultSchemaActionProvider + , pgExtensionActionProvider + , pgCustomEnumActionProvider + ] + ) (\options action -> bracket (Pg.connectPostgreSQL (fromString options)) Pg.close $ \conn -> left show <$> withPgDebug (\_ -> pure ()) conn action) @@ -321,27 +329,37 @@ PgDataTypeSyntax (PgDataTypeDescrOid oid pgMod) (emit "{- UNKNOWN -}") (pgDataTypeJSON (object [ "oid" .= (fromIntegral oid' :: Word), "mod" .= pgMod ])) --- * Create constraints from a connection +newtype SchemaName = MkSchemaName T.Text + deriving (Generic, Pg.FromRow) + +-- * Create constraints from a connection getDbConstraints :: Pg.Connection -> IO [ Db.SomeDatabasePredicate ] -getDbConstraints = getDbConstraintsForSchemas Nothing +getDbConstraints conn = do + schemata <- Pg.query_ conn "SELECT schema_name FROM information_schema.schemata WHERE schema_name NOT LIKE '%pg_%' AND schema_name <> 'information_schema' AND schema_name <> 'public';" + case schemata of + [] -> getDbConstraintsForSchemas Nothing conn + schemata' -> + (++) <$> getDbConstraintsForSchemas (Just ((\(MkSchemaName nm) -> T.unpack nm) <$> schemata')) conn + <*> getDbConstraintsForSchemas Nothing conn getDbConstraintsForSchemas :: Maybe [String] -> Pg.Connection -> IO [ Db.SomeDatabasePredicate ] getDbConstraintsForSchemas subschemas conn = - do tbls <- case subschemas of - Nothing -> Pg.query_ conn "SELECT cl.oid, relname FROM pg_catalog.pg_class \"cl\" join pg_catalog.pg_namespace \"ns\" on (ns.oid = relnamespace) where nspname = any (current_schemas(false)) and relkind='r'" - Just ss -> Pg.query conn "SELECT cl.oid, relname FROM pg_catalog.pg_class \"cl\" join pg_catalog.pg_namespace \"ns\" on (ns.oid = relnamespace) where nspname IN ? and relkind='r'" (Pg.Only (Pg.In ss)) - let tblsExist = map (\(_, tbl) -> Db.SomeDatabasePredicate (Db.TableExistsPredicate (Db.QualifiedName Nothing tbl))) tbls - + do (tbls :: [(Pg.Oid, Maybe T.Text, T.Text)]) <- case subschemas of + Nothing -> Pg.query_ conn "SELECT cl.oid, NULL, relname FROM pg_catalog.pg_class \"cl\" join pg_catalog.pg_namespace \"ns\" on (ns.oid = relnamespace) where nspname = any (current_schemas(false)) and relkind='r'" + Just ss -> Pg.query conn "SELECT cl.oid, nspname, relname FROM pg_catalog.pg_class \"cl\" join pg_catalog.pg_namespace \"ns\" on (ns.oid = relnamespace) where nspname IN ? and relkind='r'" (Pg.Only (Pg.In ss)) + let tblsExist = map (\(_, mschema, tbl) -> Db.SomeDatabasePredicate (Db.TableExistsPredicate (Db.QualifiedName mschema tbl))) tbls + schemaChecks = fromMaybe [] $ (fmap (Db.SomeDatabasePredicate . Db.SchemaExistsPredicate . T.pack)) <$> subschemas enumerationData <- Pg.query_ conn (fromString (unlines [ "SELECT t.typname, t.oid, array_agg(e.enumlabel ORDER BY e.enumsortorder)" , "FROM pg_enum e JOIN pg_type t ON t.oid = e.enumtypid" - , "GROUP BY t.typname, t.oid" ])) + , "GROUP BY t.typname, t.oid" + ])) columnChecks <- - fmap mconcat . forM tbls $ \(oid, tbl) -> + fmap mconcat . forM tbls $ \(oid, mschema, tbl) -> do columns <- Pg.query conn "SELECT attname, atttypid, atttypmod, attnotnull, pg_catalog.format_type(atttypid, atttypmod) FROM pg_catalog.pg_attribute att WHERE att.attrelid=? AND att.attnum>0 AND att.attisdropped='f'" (Pg.Only (oid :: Pg.Oid)) let columnChecks = map (\(nm, typId :: Pg.Oid, typmod, _, typ :: ByteString) -> @@ -351,24 +369,26 @@ pgDataTypeFromAtt typ typId typmod' <|> pgEnumerationTypeFromAtt enumerationData typ typId typmod' - in Db.SomeDatabasePredicate (Db.TableHasColumn (Db.QualifiedName Nothing tbl) nm pgDataType :: Db.TableHasColumn Postgres)) columns + in Db.SomeDatabasePredicate (Db.TableHasColumn (Db.QualifiedName mschema tbl) nm pgDataType :: Db.TableHasColumn Postgres)) columns notNullChecks = concatMap (\(nm, _, _, isNotNull, _) -> if isNotNull then - [Db.SomeDatabasePredicate (Db.TableColumnHasConstraint (Db.QualifiedName Nothing tbl) nm (Db.constraintDefinitionSyntax Nothing Db.notNullConstraintSyntax Nothing) + [Db.SomeDatabasePredicate (Db.TableColumnHasConstraint (Db.QualifiedName mschema tbl) nm (Db.constraintDefinitionSyntax Nothing Db.notNullConstraintSyntax Nothing) :: Db.TableColumnHasConstraint Postgres)] else [] ) columns - pure (columnChecks ++ notNullChecks) + pure (columnChecks ++ notNullChecks ++ schemaChecks) primaryKeys <- - map (\(relnm, cols) -> Db.SomeDatabasePredicate (Db.TableHasPrimaryKey (Db.QualifiedName Nothing relnm) (V.toList cols))) <$> - Pg.query_ conn (fromString (unlines [ "SELECT c.relname, array_agg(a.attname ORDER BY k.n ASC)" + map (\(schema, relnm, cols) -> Db.SomeDatabasePredicate (Db.TableHasPrimaryKey (Db.QualifiedName schema relnm) (V.toList cols))) <$> + -- We nullify the 'public' schema, which is the implicit default in Postgres + Pg.query_ conn (fromString (unlines [ "SELECT NULLIF(ns.nspname, 'public'), c.relname, array_agg(a.attname ORDER BY k.n ASC)" , "FROM pg_index i" , "CROSS JOIN unnest(i.indkey) WITH ORDINALITY k(attid, n)" , "JOIN pg_attribute a ON a.attnum=k.attid AND a.attrelid=i.indrelid" , "JOIN pg_class c ON c.oid=i.indrelid" , "JOIN pg_namespace ns ON ns.oid=c.relnamespace" - , "WHERE ns.nspname = any (current_schemas(false)) AND c.relkind='r' AND i.indisprimary GROUP BY relname, i.indrelid" ])) + -- Recall that schema of the form 'pg_' are Postgres internal tables that should not be taken into account + , "WHERE nspname NOT LIKE '%pg_%' AND c.relkind='r' AND i.indisprimary GROUP BY nspname, relname, i.indrelid" ])) let enumerations = map (\(enumNm, _, options) -> Db.SomeDatabasePredicate (PgHasEnum enumNm (V.toList options))) enumerationData diff --git a/Database/Beam/Postgres/PgSpecific.hs b/Database/Beam/Postgres/PgSpecific.hs --- a/Database/Beam/Postgres/PgSpecific.hs +++ b/Database/Beam/Postgres/PgSpecific.hs @@ -141,6 +141,7 @@ import Data.Functor import Data.Hashable import Data.Int +import Data.Kind (Type) import qualified Data.List.NonEmpty as NE import Data.Proxy import Data.Scientific (Scientific, formatScientific, FPFormat(Fixed)) @@ -308,10 +309,10 @@ -> QGenExpr context Postgres s text arrayDims_ (QExpr v) = QExpr (fmap (\(PgExpressionSyntax v') -> PgExpressionSyntax (emit "array_dims(" <> v' <> emit ")")) v) -type family CountDims (v :: *) :: Nat where +type family CountDims (v :: Type) :: Nat where CountDims (V.Vector a) = 1 + CountDims a CountDims a = 0 -type family WithinBounds (dim :: Nat) (v :: *) :: Constraint where +type family WithinBounds (dim :: Nat) (v :: Type) :: Constraint where WithinBounds dim v = If ((dim <=? CountDims v) && (1 <=? dim)) (() :: Constraint) @@ -486,7 +487,7 @@ -- -- A reasonable example might be @Range PgInt8Range Int64@. -- This represents a range of Haskell @Int64@ values stored as a range of 'bigint' in Postgres. -data PgRange (n :: *) a +data PgRange (n :: Type) a = PgEmptyRange | PgRange (PgRangeBound a) (PgRangeBound a) deriving (Eq, Show, Generic) @@ -789,7 +790,7 @@ -- section on -- . -- -class IsPgJSON (json :: * -> *) where +class IsPgJSON (json :: Type -> Type) where -- | The @json_each@ or @jsonb_each@ function. Values returned as @json@ or -- @jsonb@ respectively. Use 'pgUnnest' to join against the result pgJsonEach :: QGenExpr ctxt Postgres s (json a) @@ -1392,7 +1393,7 @@ -- ** Set-valued functions -data PgSetOf (tbl :: (* -> *) -> *) +data PgSetOf (tbl :: (Type -> Type) -> Type) pgUnnest' :: forall tbl db s . Beamable tbl diff --git a/Database/Beam/Postgres/Syntax.hs b/Database/Beam/Postgres/Syntax.hs --- a/Database/Beam/Postgres/Syntax.hs +++ b/Database/Beam/Postgres/Syntax.hs @@ -251,6 +251,7 @@ newtype PgAggregationSetQuantifierSyntax = PgAggregationSetQuantifierSyntax { fromPgAggregationSetQuantifier :: PgSyntax } newtype PgSelectSetQuantifierSyntax = PgSelectSetQuantifierSyntax { fromPgSelectSetQuantifier :: PgSyntax } newtype PgFromSyntax = PgFromSyntax { fromPgFrom :: PgSyntax } +newtype PgSchemaNameSyntax = PgSchemaNameSyntax { fromPgSchemaName :: PgSyntax } newtype PgTableNameSyntax = PgTableNameSyntax { fromPgTableName :: PgSyntax } newtype PgComparisonQuantifierSyntax = PgComparisonQuantifierSyntax { fromPgComparisonQuantifier :: PgSyntax } newtype PgExtractFieldSyntax = PgExtractFieldSyntax { fromPgExtractField :: PgSyntax } @@ -335,6 +336,9 @@ hashWithSalt salt (PgDataTypeDescrDomain t) = hashWithSalt salt (1 :: Int, t) +newtype PgCreateSchemaSyntax = PgCreateSchemaSyntax { fromPgCreateSchema :: PgSyntax } +newtype PgDropSchemaSyntax = PgDropSchemaSyntax { fromPgDropSchema :: PgSyntax } + newtype PgCreateTableSyntax = PgCreateTableSyntax { fromPgCreateTable :: PgSyntax } data PgTableOptionsSyntax = PgTableOptionsSyntax PgSyntax PgSyntax newtype PgColumnSchemaSyntax = PgColumnSchemaSyntax { fromPgColumnSchema :: PgSyntax } deriving (Show, Eq) @@ -410,6 +414,13 @@ deleteCmd = PgCommandSyntax PgCommandTypeDataUpdate . coerce updateCmd = PgCommandSyntax PgCommandTypeDataUpdate . coerce +instance IsSql92DdlSchemaCommandSyntax PgCommandSyntax where + type Sql92DdlCommandCreateSchemaSyntax PgCommandSyntax = PgCreateSchemaSyntax + type Sql92DdlCommandDropSchemaSyntax PgCommandSyntax = PgDropSchemaSyntax + + createSchemaCmd = PgCommandSyntax PgCommandTypeDdl . coerce + dropSchemaCmd = PgCommandSyntax PgCommandTypeDdl . coerce + instance IsSql92DdlCommandSyntax PgCommandSyntax where type Sql92DdlCommandCreateTableSyntax PgCommandSyntax = PgCreateTableSyntax type Sql92DdlCommandDropTableSyntax PgCommandSyntax = PgDropTableSyntax @@ -419,6 +430,9 @@ dropTableCmd = PgCommandSyntax PgCommandTypeDdl . coerce alterTableCmd = PgCommandSyntax PgCommandTypeDdl . coerce +instance IsSql92SchemaNameSyntax PgSchemaNameSyntax where + schemaName s = PgSchemaNameSyntax (pgQuotedIdentifier s) + instance IsSql92TableNameSyntax PgTableNameSyntax where tableName Nothing t = PgTableNameSyntax (pgQuotedIdentifier t) tableName (Just s) t = PgTableNameSyntax (pgQuotedIdentifier s <> emit "." <> pgQuotedIdentifier t) @@ -677,13 +691,10 @@ instance IsCustomSqlSyntax PgExpressionSyntax where newtype CustomSqlSyntax PgExpressionSyntax = PgCustomExpressionSyntax { fromPgCustomExpression :: PgSyntax } - deriving Monoid + deriving (Semigroup, Monoid) customExprSyntax = PgExpressionSyntax . fromPgCustomExpression renderSyntax = PgCustomExpressionSyntax . pgParens . fromPgExpression -instance Semigroup (CustomSqlSyntax PgExpressionSyntax) where - (<>) = mappend - instance IsString (CustomSqlSyntax PgExpressionSyntax) where fromString = PgCustomExpressionSyntax . emit . fromString @@ -1043,6 +1054,18 @@ instance IsSql92AlterColumnActionSyntax PgAlterColumnActionSyntax where setNullSyntax = PgAlterColumnActionSyntax (emit "DROP NOT NULL") setNotNullSyntax = PgAlterColumnActionSyntax (emit "SET NOT NULL") + +instance IsSql92SchemaNameSyntax PgSchemaNameSyntax => IsSql92CreateSchemaSyntax PgCreateSchemaSyntax where + type Sql92CreateSchemaSchemaNameSyntax PgCreateSchemaSyntax = PgSchemaNameSyntax + + createSchemaSyntax schemaName = PgCreateSchemaSyntax $ + emit "CREATE SCHEMA " <> fromPgSchemaName schemaName + +instance IsSql92SchemaNameSyntax PgSchemaNameSyntax => IsSql92DropSchemaSyntax PgDropSchemaSyntax where + type Sql92DropSchemaSchemaNameSyntax PgDropSchemaSyntax = PgSchemaNameSyntax + + dropSchemaSyntax schemaName = PgDropSchemaSyntax $ + emit "DROP SCHEMA " <> fromPgSchemaName schemaName instance IsSql92CreateTableSyntax PgCreateTableSyntax where type Sql92CreateTableTableNameSyntax PgCreateTableSyntax = PgTableNameSyntax diff --git a/beam-postgres.cabal b/beam-postgres.cabal --- a/beam-postgres.cabal +++ b/beam-postgres.cabal @@ -1,5 +1,5 @@ name: beam-postgres -version: 0.5.3.1 +version: 0.5.4.0 synopsis: Connection layer between beam and postgres description: Beam driver for , an advanced open-source RDBMS homepage: https://haskell-beam.github.io/beam/user-guide/backends/beam-postgres @@ -36,11 +36,11 @@ beam-core >=0.10 && <0.11, beam-migrate >=0.5 && <0.6, - postgresql-libpq >=0.8 && <0.10, - postgresql-simple >=0.5 && <0.7, + postgresql-libpq >=0.8 && <0.12, + postgresql-simple >=0.5 && <0.8, - text >=1.0 && <2.1, - bytestring >=0.10 && <0.12, + text >=1.0 && <2.2, + bytestring >=0.10 && <0.13, attoparsec >=0.13 && <0.15, hashable >=1.1 && <1.5, @@ -48,9 +48,9 @@ free >=4.12 && <5.3, time >=1.6 && <1.13, monad-control >=1.0 && <1.1, - mtl >=2.1 && <2.3, + mtl >=2.1 && <2.4, conduit >=1.2 && <1.4, - aeson >=0.11 && <2.2, + aeson >=0.11 && <2.3, uuid-types >=1.0 && <1.1, case-insensitive >=1.2 && <1.3, scientific >=0.3 && <0.4, @@ -90,7 +90,7 @@ tasty-hunit, tasty, text, - tmp-postgres, + testcontainers, uuid, vector default-language: Haskell2010 diff --git a/test/Database/Beam/Postgres/Test/Migrate.hs b/test/Database/Beam/Postgres/Test/Migrate.hs --- a/test/Database/Beam/Postgres/Test/Migrate.hs +++ b/test/Database/Beam/Postgres/Test/Migrate.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} module Database.Beam.Postgres.Test.Migrate where import Database.Beam @@ -22,6 +23,8 @@ , charWidthVerification postgresConn "CHAR" char , charNoWidthVerification postgresConn "CHAR" char , extensionVerification postgresConn + , createTableWithSchemaWorks postgresConn + , dropSchemaWorks postgresConn ] data CharT f @@ -96,3 +99,41 @@ case resAfter of VerificationSucceeded -> return () VerificationFailed failures -> fail ("Verification failed: " ++ show failures) + + +-- | Verifies that 'createTableWithSchema' correctly creates a table +-- with a schema. +createTableWithSchemaWorks :: IO ByteString -> TestTree +createTableWithSchemaWorks pgConn = + testCase ("createTableWithSchema works correctly") $ do + withTestPostgres "create_table_with_schema" pgConn $ \conn -> do + res <- runBeamPostgres conn $ do + db <- executeMigration runNoReturn $ do + internalSchema <- createDatabaseSchema "internal_schema" + (CharDb <$> createTableWithSchema (Just internalSchema) "char_test" + (CharT (field "key" (varchar Nothing) notNull))) + + verifySchema migrationBackend db + + case res of + VerificationSucceeded -> return () + VerificationFailed failures -> fail ("Verification failed: " ++ show failures) + + +-- | Verifies that creating a schema and dropping it works +dropSchemaWorks :: IO ByteString -> TestTree +dropSchemaWorks pgConn = + testCase ("dropDatabaseSchema works correctly") $ do + withTestPostgres "drop_schema" pgConn $ \conn -> do + runBeamPostgres conn $ do + db <- executeMigration runNoReturn $ do + internalSchema <- createDatabaseSchema "internal_schema" + willBeDroppedSchema <- createDatabaseSchema "will_be_dropped" + db <- (CharDb <$> createTableWithSchema (Just internalSchema) "char_test" + (CharT (field "key" (varchar Nothing) notNull))) + dropDatabaseSchema willBeDroppedSchema + pure db + + verifySchema migrationBackend db >>= \case + VerificationFailed failures -> fail ("Verification failed: " ++ show failures) + VerificationSucceeded -> pure () diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,23 +1,50 @@ module Main where -import qualified Database.Postgres.Temp as TempDb +import Data.ByteString ( ByteString ) +import Data.Text ( unpack ) +import qualified Data.Text.Lazy as TL + import Test.Tasty +import qualified TestContainers.Tasty as TC import qualified Database.Beam.Postgres.Test.Select as Select import qualified Database.Beam.Postgres.Test.Marshal as Marshal import qualified Database.Beam.Postgres.Test.DataTypes as DataType import qualified Database.Beam.Postgres.Test.Migrate as Migrate +import Database.PostgreSQL.Simple ( ConnectInfo(..), defaultConnectInfo ) +import qualified Database.PostgreSQL.Simple as Postgres main :: IO () -main = defaultMain $ withDb $ \getDb -> - let getConnStr = TempDb.toConnectionString <$> getDb - in testGroup "beam-postgres tests" - [ Marshal.tests getConnStr - , Select.tests getConnStr - , DataType.tests getConnStr - , Migrate.tests getConnStr - ] - where - withDb = withResource - (either (\e -> error $ "Failed to start DB: " <> show e) pure =<< TempDb.startConfig mempty) - TempDb.stop +main = defaultMain + $ TC.withContainers setupTempPostgresDB + $ \getConnStr -> + testGroup "beam-postgres tests" + [ Marshal.tests getConnStr + , Select.tests getConnStr + , DataType.tests getConnStr + , Migrate.tests getConnStr + ] + + +setupTempPostgresDB :: TC.MonadDocker m => m ByteString +setupTempPostgresDB = do + let user = "postgres" + password = "root" + db = "testdb" + + timescaleContainer <- TC.run $ TC.containerRequest (TC.fromTag "postgres:16.4") + TC.& TC.setExpose [ 5432 ] + TC.& TC.setEnv [ ("POSTGRES_USER", user) + , ("POSTGRES_PASSWORD", password) + , ("POSTGRES_DB", db) + ] + TC.& TC.setWaitingFor (TC.waitForLogLine TC.Stderr ("database system is ready to accept connections" `TL.isInfixOf`)) + + pure $ Postgres.postgreSQLConnectionString + ( defaultConnectInfo { connectHost = "localhost" + , connectUser = unpack user + , connectPassword = unpack password + , connectDatabase = unpack db + , connectPort = fromIntegral $ TC.containerPort timescaleContainer 5432 + } + )