pg-migrate-test-support (empty) → 1.0.0.0

raw patch · 4 files changed

+243/−0 lines, 4 filesdep +basedep +bytestringdep +containers

Dependencies added: base, bytestring, containers, ephemeral-pg, hasql, pg-migrate, pg-migrate-test-support, tasty, tasty-hunit, text

Files

• CHANGELOG.md +6/−0
• pg-migrate-test-support.cabal +51/−0
• src/Database/PostgreSQL/Migrate/Test.hs +83/−0
• test/Main.hs +103/−0

@@ -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.

@@ -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

@@ -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)

@@ -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