diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,6 @@ +# Changelog + +## 1.0.0.0 — 2026-07-10 + +- Initial stable release of the `ephemeral-pg` helper with fresh Hasql callback connections + and structured startup, migration, callback, and cleanup failures. diff --git a/pg-migrate-test-support.cabal b/pg-migrate-test-support.cabal new file mode 100644 --- /dev/null +++ b/pg-migrate-test-support.cabal @@ -0,0 +1,51 @@ +cabal-version: 3.8 +name: pg-migrate-test-support +version: 1.0.0.0 +synopsis: Ephemeral PostgreSQL helpers for pg-migrate tests +category: Database +maintainer: nadeem@gmail.com +description: + Brackets an ephemeral PostgreSQL instance, applies a validated migration + plan, and supplies a fresh Hasql connection to a test callback. + +license: BSD-3-Clause +build-type: Simple +extra-doc-files: CHANGELOG.md + +common common + default-language: GHC2024 + default-extensions: + DeriveAnyClass + DuplicateRecordFields + MultilineStrings + OverloadedLabels + OverloadedStrings + + ghc-options: -Wall -Wcompat + +library + import: common + hs-source-dirs: src + exposed-modules: Database.PostgreSQL.Migrate.Test + build-depends: + , base >=4.20 && <4.22 + , ephemeral-pg >=0.2 && <0.3 + , hasql >=1.10 && <1.11 + , pg-migrate >=1.0 && <1.1 + +test-suite pg-migrate-test-support-test + import: common + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + , base >=4.20 && <4.22 + , bytestring >=0.12 && <0.13 + , containers >=0.7 && <0.8 + , ephemeral-pg >=0.2 && <0.3 + , hasql >=1.10 && <1.11 + , pg-migrate + , pg-migrate-test-support + , tasty >=1.5 && <1.6 + , tasty-hunit >=0.10 && <0.11 + , text >=2.1 && <2.2 diff --git a/src/Database/PostgreSQL/Migrate/Test.hs b/src/Database/PostgreSQL/Migrate/Test.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Migrate/Test.hs @@ -0,0 +1,83 @@ +-- | Test-only ephemeral PostgreSQL lifecycle. A validated plan is applied before a fresh +-- Hasql connection is bracketed around the caller's assertion callback. +module Database.PostgreSQL.Migrate.Test + ( -- | Structured startup, migration, callback, and cleanup failures. + MigratedDatabaseError (..), + -- | Start a database, apply a plan with default runner options, and run a callback. + withMigratedDatabase, + -- | As 'withMigratedDatabase', with explicit runner options. + withMigratedDatabaseOptions, + -- | Fully configurable ephemeral-database variant. + withMigratedDatabaseConfig, + ) +where + +import Control.Exception (SomeException) +import Control.Exception qualified as Exception +import Database.PostgreSQL.Migrate +import EphemeralPg qualified +import Hasql.Connection qualified as Connection +import Hasql.Errors qualified as Errors + +-- | Structured failures from the ephemeral database, migration, callback, or cleanup stages. +data MigratedDatabaseError + = MigratedDatabaseStartupFailed !EphemeralPg.StartError + | MigratedDatabaseMigrationFailed !MigrationError + | MigratedDatabaseCallbackAcquisitionFailed !Errors.ConnectionError + | MigratedDatabaseCallbackFailed !SomeException + | MigratedDatabaseCallbackCleanupFailed !SomeException + | MigratedDatabaseCallbackAndCleanupFailed !SomeException !SomeException + deriving stock (Show) + +-- | Start a database, migrate it with 'defaultRunOptions', and bracket a callback connection. +withMigratedDatabase :: + MigrationPlan -> + (Connection.Connection -> IO value) -> + IO (Either MigratedDatabaseError value) +withMigratedDatabase = withMigratedDatabaseOptions defaultRunOptions + +-- | Start a database, migrate it with the supplied options, and bracket a callback connection. +withMigratedDatabaseOptions :: + RunOptions -> + MigrationPlan -> + (Connection.Connection -> IO value) -> + IO (Either MigratedDatabaseError value) +withMigratedDatabaseOptions = withMigratedDatabaseConfig EphemeralPg.defaultConfig + +-- | Fully configurable variant accepting both ephemeral database and migration options. +withMigratedDatabaseConfig :: + EphemeralPg.Config -> + RunOptions -> + MigrationPlan -> + (Connection.Connection -> IO value) -> + IO (Either MigratedDatabaseError value) +withMigratedDatabaseConfig config options plan callback = do + started <- + EphemeralPg.withConfig config $ \database -> do + let settings = EphemeralPg.connectionSettings database + migrated <- runMigrationPlan options settings plan + case migrated of + Left migrationError -> pure (Left (MigratedDatabaseMigrationFailed migrationError)) + Right _ -> do + acquired <- Connection.acquire settings + case acquired of + Left connectionError -> pure (Left (MigratedDatabaseCallbackAcquisitionFailed connectionError)) + Right connection -> runCallback connection callback + pure $ case started of + Left startError -> Left (MigratedDatabaseStartupFailed startError) + Right result -> result + +runCallback :: + Connection.Connection -> + (Connection.Connection -> IO value) -> + IO (Either MigratedDatabaseError value) +runCallback connection callback = + Exception.mask $ \restore -> do + callbackResult <- Exception.try (restore (callback connection)) + cleanupResult <- Exception.try (Connection.release connection) + pure $ case (callbackResult, cleanupResult) of + (Right value, Right ()) -> Right value + (Left callbackError, Right ()) -> Left (MigratedDatabaseCallbackFailed callbackError) + (Right _, Left cleanupError) -> Left (MigratedDatabaseCallbackCleanupFailed cleanupError) + (Left callbackError, Left cleanupError) -> + Left (MigratedDatabaseCallbackAndCleanupFailed callbackError cleanupError) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,103 @@ +module Main (main) where + +import Control.Exception qualified as Exception +import Data.Int (Int32) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Set qualified as Set +import Database.PostgreSQL.Migrate +import Database.PostgreSQL.Migrate.Test +import EphemeralPg.Config qualified as EphemeralPg.Config +import Hasql.Connection qualified as Connection +import Hasql.Decoders qualified as Decoders +import Hasql.Encoders qualified as Encoders +import Hasql.Session qualified as Session +import Hasql.Statement (Statement) +import Hasql.Statement qualified as Statement +import Test.Tasty +import Test.Tasty.HUnit + +main :: IO () +main = + defaultMain + ( testGroup + "pg-migrate test support" + [ testCase "plan is migrated before a fresh callback connection" testMigratedDatabase, + testCase "migration failures are structurally distinct" testMigrationFailure, + testCase "callback failures are structurally distinct" testCallbackFailure, + testCase "startup failures are structurally distinct" testStartupFailure + ] + ) + +testMigratedDatabase :: Assertion +testMigratedDatabase = do + result <- + withMigratedDatabase fixturePlan $ \connection -> + Connection.use connection (Session.statement () processIdsStatement) + case result of + Right (Right (migrationPid, callbackPid)) -> + assertBool "callback reused the migration connection" (migrationPid /= callbackPid) + other -> assertFailure ("unexpected migrated database result: " <> show other) + +testMigrationFailure :: Assertion +testMigrationFailure = do + result <- withMigratedDatabase failingPlan (const (pure ())) + case result of + Left MigratedDatabaseMigrationFailed {} -> pure () + other -> assertFailure ("expected migration failure, received: " <> show other) + +testCallbackFailure :: Assertion +testCallbackFailure = do + result <- withMigratedDatabase fixturePlan (const (Exception.throwIO (userError "callback failed") :: IO ())) + case result of + Left MigratedDatabaseCallbackFailed {} -> pure () + other -> assertFailure ("expected callback failure, received: " <> show other) + +testStartupFailure :: Assertion +testStartupFailure = do + let invalidConfig = EphemeralPg.Config.defaultConfig {EphemeralPg.Config.initDbArgs = ["--definitely-invalid-initdb-option"]} + result <- withMigratedDatabaseConfig invalidConfig defaultRunOptions fixturePlan (const (pure ())) + case result of + Left MigratedDatabaseStartupFailed {} -> pure () + other -> assertFailure ("expected startup failure, received: " <> show other) + +fixturePlan :: MigrationPlan +fixturePlan = + expectRight + ( migrationPlan + ( expectRight + ( migrationComponent + "test-support" + Set.empty + ( expectRight + ( sqlMigration + "0001-process" + "CREATE TABLE callback_probe AS SELECT pg_backend_pid()::int4 AS migration_pid" + ) + :| [] + ) + ) + :| [] + ) + ) + +failingPlan :: MigrationPlan +failingPlan = + expectRight + ( migrationPlan + ( expectRight + (migrationComponent "test-support-failure" Set.empty (expectRight (sqlMigration "0001-fail" "SELECT * FROM deliberately_missing_relation") :| [])) + :| [] + ) + ) + +processIdsStatement :: Statement () (Int32, Int32) +processIdsStatement = + Statement.preparable + "SELECT migration_pid, pg_backend_pid()::int4 FROM callback_probe" + Encoders.noParams + (Decoders.singleRow ((,) <$> required Decoders.int4 <*> required Decoders.int4)) + where + required = Decoders.column . Decoders.nonNullable + +expectRight :: (Show error) => Either error value -> value +expectRight = either (error . show) id