packages feed

pg-migrate (empty) → 1.0.0.0

raw patch · 34 files changed

+7454/−0 lines, 34 filesdep +aesondep +basedep +bytestring

Dependencies added: aeson, base, bytestring, containers, contravariant, crypton, hasql, hasql-transaction, pg-migrate, process, ram, tasty, tasty-hunit, tasty-quickcheck, text, time, unix

Files

+ CHANGELOG.md view
@@ -0,0 +1,6 @@+# Changelog++## 1.0.0.0 — 2026-07-10++- Initial stable release of the validated plan model, ledger schema v1, transactional and+  nontransactional runner, repair audit, inspection API, and generic history importer.
+ pg-migrate.cabal view
@@ -0,0 +1,128 @@+cabal-version:   3.8+name:            pg-migrate+version:         1.0.0.0+synopsis:        Hasql-native PostgreSQL migration engine+category:        Database+maintainer:      nadeem@gmail.com+description:+  Libraries own ordered migration components and applications compose them into+  validated plans with stable v1 ledger and public API contracts.++extra-doc-files: CHANGELOG.md+license:         BSD-3-Clause+build-type:      Simple++common common+  default-language:   GHC2024+  default-extensions:+    DeriveAnyClass+    DuplicateRecordFields+    MultilineStrings+    OverloadedLabels+    OverloadedStrings++  ghc-options:        -Wall -Wcompat++library+  import:          common+  hs-source-dirs:  src+  autogen-modules: Paths_pg_migrate+  exposed-modules:+    Database.PostgreSQL.Migrate+    Database.PostgreSQL.Migrate.History+    Database.PostgreSQL.Migrate.Internal+    PgMigrate.Prelude++  other-modules:+    Database.PostgreSQL.Migrate.Definition+    Database.PostgreSQL.Migrate.History.Types+    Database.PostgreSQL.Migrate.History.Validation+    Database.PostgreSQL.Migrate.Inspection+    Database.PostgreSQL.Migrate.Ledger+    Database.PostgreSQL.Migrate.Ledger.Migrations+    Database.PostgreSQL.Migrate.Ledger.Sql+    Database.PostgreSQL.Migrate.Ledger.Types+    Database.PostgreSQL.Migrate.Plan+    Database.PostgreSQL.Migrate.Repair+    Database.PostgreSQL.Migrate.Repair.Types+    Database.PostgreSQL.Migrate.Runner+    Database.PostgreSQL.Migrate.Runner.Connection+    Database.PostgreSQL.Migrate.Runner.Lock+    Database.PostgreSQL.Migrate.Runner.Types+    Database.PostgreSQL.Migrate.Sql+    Database.PostgreSQL.Migrate.Sql.Scanner+    Database.PostgreSQL.Migrate.Types+    Paths_pg_migrate++  build-depends:+    , aeson              >=2.2  && <2.3+    , base               >=4.20 && <4.22+    , bytestring         >=0.12 && <0.13+    , containers         >=0.7  && <0.8+    , contravariant      >=1.5  && <1.6+    , crypton            >=1.1  && <1.2+    , hasql              >=1.10 && <1.11+    , hasql-transaction  >=1.2  && <1.3+    , ram                >=0.20 && <0.23+    , text               >=2.1  && <2.2+    , time               >=1.12 && <1.15++test-suite pg-migrate-unit+  import:         common+  type:           exitcode-stdio-1.0+  hs-source-dirs: test/unit+  main-is:        Main.hs+  other-modules:+    Test.Definition+    Test.History+    Test.Ledger+    Test.Plan+    Test.PublicApi+    Test.Runner+    Test.Sql++  build-depends:+    , aeson             >=2.2  && <2.3+    , base              >=4.20 && <4.22+    , bytestring        >=0.12 && <0.13+    , containers        >=0.7  && <0.8+    , pg-migrate+    , tasty             >=1.5  && <1.6+    , tasty-hunit       >=0.10 && <0.11+    , tasty-quickcheck  >=0.11 && <0.13+    , text              >=2.1  && <2.2+    , time              >=1.12 && <1.15++test-suite pg-migrate-integration+  import:             common+  type:               exitcode-stdio-1.0+  ghc-options:        -threaded+  hs-source-dirs:     test/integration+  main-is:            Main.hs+  build-tool-depends: pg-migrate:pg-migrate-crash-helper+  build-depends:+    , aeson              >=2.2  && <2.3+    , base               >=4.20 && <4.22+    , bytestring         >=0.12 && <0.13+    , containers         >=0.7  && <0.8+    , hasql              >=1.10 && <1.11+    , hasql-transaction  >=1.2  && <1.3+    , pg-migrate+    , process            >=1.6  && <1.7+    , tasty              >=1.5  && <1.6+    , tasty-hunit        >=0.10 && <0.11+    , text               >=2.1  && <2.2+    , time               >=1.12 && <1.15+    , unix               >=2.8  && <2.9++executable pg-migrate-crash-helper+  import:         common+  hs-source-dirs: test/crash-helper+  main-is:        Main.hs+  build-depends:+    , base        >=4.20 && <4.22+    , bytestring  >=0.12 && <0.13+    , containers  >=0.7  && <0.8+    , hasql       >=1.10 && <1.11+    , pg-migrate+    , text        >=2.1  && <2.2
+ src/Database/PostgreSQL/Migrate.hs view
@@ -0,0 +1,224 @@+-- | Safe common facade for defining, inspecting, running, repairing, and importing+-- PostgreSQL migration plans. Smart constructors reject invalid definitions before+-- acquisition; reports and errors describe durable outcomes without exposing actions.+module Database.PostgreSQL.Migrate+  ( ComponentName,+    componentName,+    MigrationName,+    migrationName,+    MigrationId,+    migrationId,+    MigrationChecksum,+    migrationFingerprint,+    Migration,+    sqlMigration,+    transactionMigration,+    sessionMigration,+    MigrationComponent,+    migrationComponent,+    migrationComponentFromEmbeddedSql,+    MigrationPlan,+    migrationPlan,+    resolveMigrationPlan,+    LedgerConfig,+    defaultLedgerConfig,+    ledgerConfig,+    ledgerSchemaVersion,+    MigrationStatus (..),+    UnknownMigrationsPolicy (..),+    StoredMigration (..),+    VerificationIssue (..),+    VerificationReport (..),+    StatusReport (..),+    RunOptions,+    defaultRunOptions,+    withLedger,+    withLockWait,+    withStatementTimeout,+    withUnknownMigrationsPolicy,+    withEventHandler,+    LockWait (..),+    MigrationEvent (..),+    MigrationOutcome (..),+    MigrationResult (..),+    MigrationReport (..),+    CleanupIssue (..),+    MigrationError (..),+    ConnectionProvider,+    connectionProvider,+    connectionProviderFromSettings,+    migrationStatus,+    migrationStatusWith,+    verifyMigrationPlan,+    verifyMigrationPlanWith,+    runMigrationPlan,+    runMigrationPlanWith,+    RepairOperation (..),+    Confirmation (..),+    RepairDefinitionError (..),+    RepairRequest,+    repairRequest,+    RepairError (..),+    RepairReport (..),+    repairMigration,+    EvidenceKey,+    evidenceKey,+    EvidenceStrength (..),+    SourceTimestamp (..),+    ImportEvidence,+    ledgerOnlyEvidence,+    sourceManifestVerifiedEvidence,+    sourceLedgerChecksumVerifiedEvidence,+    EvidenceRequirement (..),+    PayloadRelation (..),+    HistoryMapping,+    historyMapping,+    historyMappingPayloadRelation,+    StateValidationError,+    stateValidationError,+    StateValidator,+    stateValidator,+    HistoryImport,+    historyImport,+    HistoryDefinitionError (..),+    EquivalentHistoryPolicy (..),+    ImportOptions,+    defaultImportOptions,+    withEquivalentHistory,+    withImportRunOptions,+    importEquivalentHistoryPolicy,+    HistoryImportOutcome (..),+    HistoryImportResult (..),+    HistoryImportReport (..),+    HistoryValidationError (..),+    validateHistoryMappingTargets,+    HistoryImportError (..),+    importMigrationHistory,+    IdentifierError (..),+    PostgresIdentifierError (..),+    SqlError (..),+    DefinitionError (..),+    PlanError (..),+  )+where++import Database.PostgreSQL.Migrate.Definition+  ( DefinitionError (..),+    IdentifierError (..),+    PostgresIdentifierError (..),+    componentName,+    migrationComponent,+    migrationComponentFromEmbeddedSql,+    migrationFingerprint,+    migrationId,+    migrationName,+    sessionMigration,+    sqlMigration,+    transactionMigration,+  )+import Database.PostgreSQL.Migrate.History+  ( EquivalentHistoryPolicy (..),+    EvidenceKey,+    EvidenceRequirement (..),+    EvidenceStrength (..),+    HistoryDefinitionError (..),+    HistoryImport,+    HistoryImportError (..),+    HistoryImportOutcome (..),+    HistoryImportReport (..),+    HistoryImportResult (..),+    HistoryMapping,+    HistoryValidationError (..),+    ImportEvidence,+    ImportOptions,+    PayloadRelation (..),+    SourceTimestamp (..),+    StateValidationError,+    StateValidator,+    defaultImportOptions,+    evidenceKey,+    historyImport,+    historyMapping,+    historyMappingPayloadRelation,+    importEquivalentHistoryPolicy,+    importMigrationHistory,+    ledgerOnlyEvidence,+    sourceLedgerChecksumVerifiedEvidence,+    sourceManifestVerifiedEvidence,+    stateValidationError,+    stateValidator,+    validateHistoryMappingTargets,+    withEquivalentHistory,+    withImportRunOptions,+  )+import Database.PostgreSQL.Migrate.Inspection+  ( migrationStatus,+    migrationStatusWith,+    verifyMigrationPlan,+    verifyMigrationPlanWith,+  )+import Database.PostgreSQL.Migrate.Ledger.Migrations (ledgerSchemaVersion)+import Database.PostgreSQL.Migrate.Ledger.Types+  ( LedgerConfig,+    MigrationStatus (..),+    StatusReport (..),+    StoredMigration (..),+    UnknownMigrationsPolicy (..),+    VerificationIssue (..),+    VerificationReport (..),+    defaultLedgerConfig,+    ledgerConfig,+  )+import Database.PostgreSQL.Migrate.Plan+  ( PlanError (..),+    migrationPlan,+    resolveMigrationPlan,+  )+import Database.PostgreSQL.Migrate.Repair+  ( repairMigration,+  )+import Database.PostgreSQL.Migrate.Repair.Types+  ( Confirmation (..),+    RepairDefinitionError (..),+    RepairError (..),+    RepairOperation (..),+    RepairReport (..),+    RepairRequest,+    repairRequest,+  )+import Database.PostgreSQL.Migrate.Runner+  ( runMigrationPlan,+    runMigrationPlanWith,+  )+import Database.PostgreSQL.Migrate.Runner.Connection+  ( connectionProviderFromSettings,+  )+import Database.PostgreSQL.Migrate.Runner.Types+  ( CleanupIssue (..),+    ConnectionProvider,+    LockWait (..),+    MigrationError (..),+    MigrationEvent (..),+    MigrationOutcome (..),+    MigrationReport (..),+    MigrationResult (..),+    RunOptions,+    connectionProvider,+    defaultRunOptions,+    withEventHandler,+    withLedger,+    withLockWait,+    withStatementTimeout,+    withUnknownMigrationsPolicy,+  )+import Database.PostgreSQL.Migrate.Sql (SqlError (..))+import Database.PostgreSQL.Migrate.Types+  ( ComponentName,+    Migration,+    MigrationChecksum,+    MigrationComponent,+    MigrationId,+    MigrationName,+    MigrationPlan,+  )+import PgMigrate.Prelude ()
+ src/Database/PostgreSQL/Migrate/Definition.hs view
@@ -0,0 +1,204 @@+module Database.PostgreSQL.Migrate.Definition+  ( IdentifierError (..),+    PostgresIdentifierError (..),+    DefinitionError (..),+    componentName,+    migrationName,+    migrationId,+    migrationFingerprint,+    sqlMigration,+    transactionMigration,+    sessionMigration,+    migrationComponent,+    migrationComponentFromEmbeddedSql,+  )+where++import Crypto.Hash qualified as Hash+import Data.ByteArray qualified as ByteArray+import Data.ByteString qualified as ByteString+import Data.Char qualified as Char+import Data.Set qualified as Set+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text.Encoding+import Database.PostgreSQL.Migrate.Sql+  ( SqlError,+    sqlScanTransactionMode,+    validateSql,+  )+import Database.PostgreSQL.Migrate.Types+import Hasql.Session qualified as Hasql.Session+import Hasql.Transaction qualified as Hasql.Transaction+import PgMigrate.Prelude++-- | Reason a component or migration identifier was rejected.+data IdentifierError+  = EmptyIdentifier+  | IdentifierHasSurroundingWhitespace+  | IdentifierContainsSlash+  | IdentifierTooLong+      { actualBytes :: !Int,+        maximumBytes :: !Int+      }+  | IdentifierContainsNonPrintableAscii !Char+  deriving stock (Generic, Eq, Show)++-- | Reason a PostgreSQL schema identifier was rejected.+data PostgresIdentifierError+  = EmptyPostgresIdentifier+  | PostgresIdentifierContainsNul+  | PostgresIdentifierHasReservedPrefix+  | PostgresIdentifierTooLong+      { actualBytes :: !Int,+        maximumBytes :: !Int+      }+  deriving stock (Generic, Eq, Show)++-- | Structured failure from a public smart constructor.+data DefinitionError+  = InvalidComponentName+      { input :: !Text,+        reason :: !IdentifierError+      }+  | InvalidMigrationName+      { input :: !Text,+        reason :: !IdentifierError+      }+  | InvalidSql !SqlError+  | InvalidEmbeddedMigrationFile+      { file :: !FilePath+      }+  | InvalidLedgerSchema+      { input :: !Text,+        postgresIdentifierReason :: !PostgresIdentifierError+      }+  deriving stock (Generic, Eq, Show)++-- | Validate a component identifier.+componentName :: Text -> Either DefinitionError ComponentName+componentName input =+  ComponentName <$> first (InvalidComponentName input) (validateIdentifier input)++-- | Validate a migration identifier.+migrationName :: Text -> Either DefinitionError MigrationName+migrationName input =+  MigrationName <$> first (InvalidMigrationName input) (validateIdentifier input)++-- | Validate and combine component and migration identifiers.+migrationId :: Text -> Text -> Either DefinitionError MigrationId+migrationId componentInput migrationInput =+  MigrationId+    <$> componentName componentInput+    <*> migrationName migrationInput++-- | Compute the canonical SHA-256 fingerprint of exact payload bytes.+migrationFingerprint :: ByteString -> MigrationChecksum+migrationFingerprint bytes =+  MigrationChecksum+    (ByteArray.convert (Hash.hashWith Hash.SHA256 bytes))++-- | Validate SQL and derive its transaction mode and exact-byte checksum.+sqlMigration :: Text -> ByteString -> Either DefinitionError Migration+sqlMigration nameInput sqlBytes = do+  name <- migrationName nameInput+  sqlScan <- first InvalidSql (validateSql sqlBytes)+  pure+    Migration+      { name,+        description = Nothing,+        mode = sqlScanTransactionMode sqlScan,+        kind = SqlKind,+        checksum = migrationFingerprint sqlBytes,+        action = SqlAction sqlBytes+      }++-- | Define a transactional Haskell migration with an explicit fingerprint.+transactionMigration ::+  Text ->+  MigrationChecksum ->+  Hasql.Transaction.Transaction () ->+  Either DefinitionError Migration+transactionMigration nameInput checksum action = do+  name <- migrationName nameInput+  pure+    Migration+      { name,+        description = Nothing,+        mode = Transactional,+        kind = HaskellKind,+        checksum,+        action = TransactionAction action+      }++-- | Define a nontransactional session migration with an explicit fingerprint.+sessionMigration ::+  Text ->+  MigrationChecksum ->+  Hasql.Session.Session () ->+  Either DefinitionError Migration+sessionMigration nameInput checksum action = do+  name <- migrationName nameInput+  pure+    Migration+      { name,+        description = Nothing,+        mode = NonTransactional,+        kind = HaskellKind,+        checksum,+        action = SessionAction action+      }++-- | Define a component with validated dependency names and ordered migrations.+migrationComponent ::+  Text ->+  Set Text ->+  NonEmpty Migration ->+  Either DefinitionError MigrationComponent+migrationComponent nameInput dependencyInputs migrations = do+  name <- componentName nameInput+  dependencies <-+    Set.fromList <$> traverse componentName (Set.toAscList dependencyInputs)+  pure MigrationComponent {name, dependencies, migrations}++-- | Define a component from ordered @.sql@ names and exact embedded bytes.+migrationComponentFromEmbeddedSql ::+  Text ->+  Set Text ->+  NonEmpty (FilePath, ByteString) ->+  Either DefinitionError MigrationComponent+migrationComponentFromEmbeddedSql nameInput dependencyInputs entries = do+  migrations <- traverse migrationFromEntry entries+  migrationComponent nameInput dependencyInputs migrations+  where+    migrationFromEntry (file, sqlBytes) = do+      localName <-+        maybe+          (Left (InvalidEmbeddedMigrationFile file))+          Right+          (Text.stripSuffix ".sql" (Text.pack file))+      sqlMigration localName sqlBytes++validateIdentifier :: Text -> Either IdentifierError Text+validateIdentifier value+  | Text.null value = Left EmptyIdentifier+  | Text.strip value /= value = Left IdentifierHasSurroundingWhitespace+  | Text.any (== '/') value = Left IdentifierContainsSlash+  | byteLength > maximumIdentifierBytes =+      Left+        IdentifierTooLong+          { actualBytes = byteLength,+            maximumBytes = maximumIdentifierBytes+          }+  | Just invalidCharacter <- Text.find (not . isPrintableAscii) value =+      Left (IdentifierContainsNonPrintableAscii invalidCharacter)+  | otherwise = Right value+  where+    byteLength = ByteString.length (Text.Encoding.encodeUtf8 value)++maximumIdentifierBytes :: Int+maximumIdentifierBytes = 200++isPrintableAscii :: Char -> Bool+isPrintableAscii character =+  let codePoint = Char.ord character+   in codePoint >= 0x20 && codePoint <= 0x7E
+ src/Database/PostgreSQL/Migrate/History.hs view
@@ -0,0 +1,261 @@+-- | Source-agnostic history import. The importer validates evidence and target prefixes+-- under the normal runner lock, then atomically records applied target metadata and audit+-- evidence without executing migration actions.+module Database.PostgreSQL.Migrate.History+  ( EvidenceKey,+    evidenceKey,+    EvidenceStrength (..),+    SourceTimestamp (..),+    ImportEvidence,+    ledgerOnlyEvidence,+    sourceManifestVerifiedEvidence,+    sourceLedgerChecksumVerifiedEvidence,+    EvidenceRequirement (..),+    PayloadRelation (..),+    HistoryMapping,+    historyMapping,+    historyMappingPayloadRelation,+    StateValidationError,+    stateValidationError,+    StateValidator,+    stateValidator,+    HistoryImport,+    historyImport,+    HistoryDefinitionError (..),+    EquivalentHistoryPolicy (..),+    ImportOptions,+    defaultImportOptions,+    withEquivalentHistory,+    withImportRunOptions,+    importEquivalentHistoryPolicy,+    HistoryImportOutcome (..),+    HistoryImportResult (..),+    HistoryImportReport (..),+    HistoryValidationError (..),+    validateHistoryMappingTargets,+    HistoryImportError (..),+    importMigrationHistory,+  )+where++import Data.Aeson qualified as Aeson+import Data.ByteString.Lazy qualified as LazyByteString+import Data.Map.Strict qualified as Map+import Data.Text qualified as Text+import Data.Time (UTCTime, getCurrentTime)+import Data.Version (showVersion)+import Database.PostgreSQL.Migrate.History.Types+import Database.PostgreSQL.Migrate.History.Validation+import Database.PostgreSQL.Migrate.Ledger+import Database.PostgreSQL.Migrate.Ledger.Migrations+import Database.PostgreSQL.Migrate.Ledger.Sql+import Database.PostgreSQL.Migrate.Ledger.Types+import Database.PostgreSQL.Migrate.Plan (planDescription)+import Database.PostgreSQL.Migrate.Runner (withRunLifecycle)+import Database.PostgreSQL.Migrate.Runner.Types+import Database.PostgreSQL.Migrate.Types+import Hasql.Connection qualified as Connection+import Hasql.Session qualified as Session+import Hasql.Transaction qualified as Transaction+import Hasql.Transaction.Sessions qualified as Transaction.Sessions+import Paths_pg_migrate qualified as Package+import PgMigrate.Prelude++data ClassifiedImport+  = ImportPending !ResolvedHistoryMapping+  | ImportExisting !ResolvedHistoryMapping++-- | Validate and atomically record imported target rows without executing actions.+importMigrationHistory ::+  ImportOptions ->+  ConnectionProvider ->+  MigrationPlan ->+  HistoryImport ->+  IO (Either HistoryImportError HistoryImportReport)+importMigrationHistory options provider plan history = do+  result <-+    withRunLifecycle (importRunOptions options) provider $ \connection ->+      Right <$> importLocked options connection plan history+  pure $ case result of+    Left migrationError -> Left (HistoryImportRunnerError migrationError)+    Right imported -> imported++importLocked ::+  ImportOptions ->+  Connection.Connection ->+  MigrationPlan ->+  HistoryImport ->+  IO (Either HistoryImportError HistoryImportReport)+importLocked options connection plan history = do+  initialized <-+    runSession+      connection+      (initializeOrUpgradeLedger activeLedgerConfig historyRunnerVersion)+  case initialized of+    Left migrationError -> pure (Left (HistoryImportRunnerError migrationError))+    Right (Left ledgerError) -> pure (Left (HistoryImportRunnerError (LedgerInitializationFailed ledgerError)))+    Right (Right ()) -> do+      snapshotResult <- runSession connection (loadLedger activeLedgerConfig)+      auditResult <- runSession connection (Session.statement () (loadHistoryImportsStatement activeLedgerConfig))+      case (snapshotResult, auditResult) of+        (Left migrationError, _) -> pure (Left (HistoryImportRunnerError migrationError))+        (_, Left migrationError) -> pure (Left (HistoryImportRunnerError migrationError))+        (Right snapshot, Right storedAudits) ->+          importAgainstSnapshot options connection plan history snapshot storedAudits+  where+    activeLedgerConfig = runLedgerConfig (importRunOptions options)++importAgainstSnapshot ::+  ImportOptions ->+  Connection.Connection ->+  MigrationPlan ->+  HistoryImport ->+  LedgerSnapshot ->+  [StoredHistoryImport] ->+  IO (Either HistoryImportError HistoryImportReport)+importAgainstSnapshot options connection plan history snapshot storedAudits =+  case comparePlanWithLedger RejectUnknownMigrations (planDescription plan) (storedMigrations snapshot) of+    verification@VerificationReport {issues = _ : _} ->+      pure (Left (HistoryImportRunnerError (PlanVerificationFailed verification)))+    VerificationReport {} -> do+      validatedEvidence <- runValidators connection history+      case validatedEvidence of+        Left importError -> pure (Left importError)+        Right availableEvidence ->+          case resolveHistoryImport (equivalentHistoryPolicy options) plan availableEvidence history of+            Left validationError -> pure (Left (HistoryImportValidationFailed validationError))+            Right resolved -> do+              let classified =+                    traverse+                      (classifyImport history snapshot storedAudits)+                      resolved+              case classified of+                Left importError -> pure (Left importError)+                Right imports -> persistImports options connection history imports++runValidators ::+  Connection.Connection ->+  HistoryImport ->+  IO (Either HistoryImportError (Map EvidenceKey ImportEvidence))+runValidators connection history = go (evidence history) (validators history)+  where+    go available [] = pure (Right available)+    go available (validator : rest) = do+      result <-+        Connection.use+          connection+          ( Transaction.Sessions.transactionNoRetry+              Transaction.Sessions.ReadCommitted+              Transaction.Sessions.Read+              (runStateValidator validator)+          )+      case result of+        Left sessionError -> pure (Left (HistoryImportRunnerError (DatabaseSessionFailed sessionError)))+        Right (Left validationError) ->+          pure (Left (HistoryStateValidationFailed (validatorEvidenceKey validator) validationError))+        Right (Right details) ->+          go+            (Map.insert (validatorEvidenceKey validator) (stateVerifiedEvidence (validatorEvidenceKey validator) details) available)+            rest++classifyImport ::+  HistoryImport ->+  LedgerSnapshot ->+  [StoredHistoryImport] ->+  ResolvedHistoryMapping ->+  Either HistoryImportError ClassifiedImport+classifyImport history snapshot storedAudits resolved =+  case (Map.lookup identifier migrationsById, Map.lookup identifier auditsById) of+    (Nothing, Nothing) -> Right (ImportPending resolved)+    (Just storedMigration, Just storedAudit)+      | migrationMatches resolved storedMigration && auditMatches history resolved storedAudit ->+          Right (ImportExisting resolved)+    _ -> Left (HistoryImportConflict identifier)+  where+    identifier = resolvedTarget resolved+    migrationsById = Map.fromList [(storedMigrationId row, row) | row <- storedMigrations snapshot]+    auditsById = Map.fromList [(storedHistoryMigrationId row, row) | row <- storedAudits]++migrationMatches :: ResolvedHistoryMapping -> StoredMigration -> Bool+migrationMatches+  resolved+  StoredMigration+    { position = storedPosition,+      checksum = storedChecksum,+      kind = storedKind,+      transactionMode = storedTransactionMode,+      status = storedStatus+    } =+    storedPosition == fromIntegral (resolvedPosition resolved)+      && storedChecksum == resolvedChecksum resolved+      && storedKind == resolvedKind resolved+      && storedTransactionMode == resolvedTransactionMode resolved+      && storedStatus == Applied++auditMatches :: HistoryImport -> ResolvedHistoryMapping -> StoredHistoryImport -> Bool+auditMatches history resolved stored =+  storedHistorySource stored == source history+    && storedHistoryEvidence stored == resolvedAuditEvidence resolved+    && storedHistoryReason stored == reason history++persistImports ::+  ImportOptions ->+  Connection.Connection ->+  HistoryImport ->+  NonEmpty ClassifiedImport ->+  IO (Either HistoryImportError HistoryImportReport)+persistImports options connection history imports = do+  importedAt <- getCurrentTime+  let pending = [resolved | ImportPending resolved <- toList imports]+      ledgerRows = historyLedgerRow importedAt history <$> pending+      activeLedgerConfig = runLedgerConfig (importRunOptions options)+  written <-+    Connection.use+      connection+      ( Transaction.Sessions.transactionNoRetry+          Transaction.Sessions.ReadCommitted+          Transaction.Sessions.Write+          ( for_ ledgerRows $ \row -> do+              Transaction.statement row (insertImportedMigrationStatement activeLedgerConfig)+              Transaction.statement row (insertHistoryImportAuditStatement activeLedgerConfig)+          )+      )+  pure $ case written of+    Left sessionError -> Left (HistoryImportRunnerError (DatabaseSessionFailed sessionError))+    Right () ->+      Right+        ( HistoryImportReport+            (toResult <$> imports)+        )+  where+    toResult = \case+      ImportPending resolved -> HistoryImportResult (resolvedTarget resolved) Imported+      ImportExisting resolved -> HistoryImportResult (resolvedTarget resolved) AlreadyImported++historyLedgerRow ::+  UTCTime ->+  HistoryImport ->+  ResolvedHistoryMapping ->+  HistoryLedgerRow+historyLedgerRow historyLedgerImportedAt history resolved =+  HistoryLedgerRow+    { historyLedgerMigrationId = resolvedTarget resolved,+      historyLedgerPosition = resolvedPosition resolved,+      historyLedgerChecksum = resolvedChecksum resolved,+      historyLedgerKind = resolvedKind resolved,+      historyLedgerTransactionMode = resolvedTransactionMode resolved,+      historyLedgerImportedAt,+      historyLedgerSource = source history,+      historyLedgerEvidence = LazyByteString.toStrict (Aeson.encode (resolvedAuditEvidence resolved)),+      historyLedgerReason = reason history,+      historyLedgerRunnerVersion = historyRunnerVersion+    }++runSession ::+  Connection.Connection ->+  Session.Session value ->+  IO (Either MigrationError value)+runSession connection session = first DatabaseSessionFailed <$> Connection.use connection session++historyRunnerVersion :: Text+historyRunnerVersion = Text.pack (showVersion Package.version)
+ src/Database/PostgreSQL/Migrate/History/Types.hs view
@@ -0,0 +1,332 @@+{-# LANGUAGE RankNTypes #-}++module Database.PostgreSQL.Migrate.History.Types+  ( EvidenceKey (..),+    evidenceKey,+    EvidenceStrength (..),+    SourceTimestamp (..),+    ImportEvidence (..),+    ledgerOnlyEvidence,+    sourceManifestVerifiedEvidence,+    sourceLedgerChecksumVerifiedEvidence,+    EvidenceRequirement (..),+    PayloadRelation (..),+    HistoryMapping (..),+    historyMapping,+    historyMappingPayloadRelation,+    StateValidationError (..),+    stateValidationError,+    StateValidator (..),+    stateValidator,+    HistoryImport (..),+    historyImport,+    HistoryDefinitionError (..),+    EquivalentHistoryPolicy (..),+    ImportOptions (..),+    defaultImportOptions,+    withEquivalentHistory,+    withImportRunOptions,+    importEquivalentHistoryPolicy,+    HistoryImportOutcome (..),+    HistoryImportResult (..),+    HistoryImportReport (..),+    HistoryValidationError (..),+    HistoryImportError (..),+  )+where++import Data.Aeson (Value)+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Data.Text qualified as Text+import Data.Time (LocalTime, UTCTime)+import Database.PostgreSQL.Migrate.Runner.Types+import Database.PostgreSQL.Migrate.Types+import Hasql.Transaction qualified as Transaction+import PgMigrate.Prelude++-- | Validated key naming one independently checked source fact.+newtype EvidenceKey = EvidenceKey+  { unEvidenceKey :: Text+  }+  deriving stock (Generic, Eq, Ord, Show)++-- | Increasing classes of source-history assurance.+data EvidenceStrength+  = LedgerOnly+  | SourceManifestVerified+  | SourceLedgerChecksumVerified+  | StateVerified+  deriving stock (Generic, Eq, Ord, Show)++-- | Source time preserving whether a timezone was actually available.+data SourceTimestamp+  = AbsoluteTime !UTCTime+  | LocalTimeWithoutZone !LocalTime+  deriving stock (Generic, Eq, Ord, Show)++-- | Auditable source identity, assurance, checksum, and adapter details.+data ImportEvidence = ImportEvidence+  { identity :: !Text,+    appliedAt :: !(Maybe SourceTimestamp),+    strength :: !EvidenceStrength,+    payloadChecksum :: !(Maybe MigrationChecksum),+    details :: !Value+  }+  deriving stock (Generic, Eq, Show)++-- | Boolean evidence expression required by one target mapping.+data EvidenceRequirement+  = Evidence !EvidenceKey+  | AllOf !(NonEmpty EvidenceRequirement)+  | AnyOf !(NonEmpty EvidenceRequirement)+  deriving stock (Generic, Eq, Show)++-- | Whether source bytes match or only verified database state is equivalent.+data PayloadRelation+  = SamePayload !EvidenceKey+  | EquivalentState+  deriving stock (Generic, Eq, Show)++-- | One target migration and the evidence required to import it.+data HistoryMapping = HistoryMapping+  { target :: !MigrationId,+    requirement :: !EvidenceRequirement,+    payload :: !PayloadRelation+  }+  deriving stock (Generic, Eq, Show)++-- | Validated diagnostic returned by a read-only state validator.+newtype StateValidationError = StateValidationError+  { stateValidationErrorText :: Text+  }+  deriving stock (Generic, Eq, Show)++-- | Read-only transaction that produces state evidence or a diagnostic.+data StateValidator = StateValidator+  { validatorEvidenceKey :: !EvidenceKey,+    runStateValidator :: !(Transaction.Transaction (Either StateValidationError Value))+  }++-- | Fully validated source, evidence, mappings, validators, and audit reason.+data HistoryImport = HistoryImport+  { source :: !Text,+    evidence :: !(Map EvidenceKey ImportEvidence),+    validators :: ![StateValidator],+    mappings :: !(NonEmpty HistoryMapping),+    reason :: !Text+  }++-- | Static error in an import definition.+data HistoryDefinitionError+  = EmptyEvidenceKey+  | EmptyEvidenceIdentity+  | EmptyStateValidationError+  | EmptyHistorySource+  | EmptyHistoryReason+  | DuplicateStateValidator !EvidenceKey+  | EvidenceKeyCollision !EvidenceKey+  | DuplicateHistoryTarget !MigrationId+  | UnknownRequirementEvidence !EvidenceKey+  | AmbiguousEvidenceRequirement !EvidenceRequirement+  | SamePayloadEvidenceNotRequired !EvidenceKey+  deriving stock (Generic, Eq, Show)++-- | Whether state-equivalent imports may be considered.+data EquivalentHistoryPolicy+  = RejectEquivalentHistory+  | AllowEquivalentHistory+  deriving stock (Generic, Eq, Ord, Show)++-- | Runner lifecycle and equivalent-history policy for an import.+data ImportOptions = ImportOptions+  { importRunOptions :: !RunOptions,+    equivalentHistoryPolicy :: !EquivalentHistoryPolicy+  }++-- | Whether an audit row was written now or already matched exactly.+data HistoryImportOutcome+  = Imported+  | AlreadyImported+  deriving stock (Generic, Eq, Ord, Show)++-- | Idempotent result for one imported target migration.+data HistoryImportResult = HistoryImportResult+  { importedMigration :: !MigrationId,+    importOutcome :: !HistoryImportOutcome+  }+  deriving stock (Generic, Eq, Show)++-- | Non-empty successful result set for an import operation.+newtype HistoryImportReport = HistoryImportReport+  { importResults :: NonEmpty HistoryImportResult+  }+  deriving stock (Generic, Eq, Show)++-- | Dynamic inconsistency between source evidence, mappings, policy, and plan.+data HistoryValidationError+  = HistoryTargetUnknown !MigrationId+  | HistoryComponentPrefixGap !ComponentName !Int+  | HistoryRequirementUnsatisfied !MigrationId+  | HistoryRequirementAmbiguous !MigrationId+  | HistoryPayloadEvidenceMissing !MigrationId !EvidenceKey+  | HistoryPayloadChecksumMissing !MigrationId !EvidenceKey+  | HistoryPayloadChecksumMismatch !MigrationId !EvidenceKey+  | HistorySamePayloadForHaskell !MigrationId+  | HistoryEquivalentStateDisallowed !MigrationId+  | HistoryEquivalentStateUnverified !MigrationId+  deriving stock (Generic, Eq, Show)++-- | Structured runner, validator, mapping, conflict, or transition failure.+data HistoryImportError+  = HistoryImportRunnerError !MigrationError+  | HistoryStateValidationFailed !EvidenceKey !StateValidationError+  | HistoryImportValidationFailed !HistoryValidationError+  | HistoryImportConflict !MigrationId+  | HistoryImportTransitionFailed !MigrationId+  deriving stock (Generic, Show)++-- | Validate a non-empty evidence key.+evidenceKey :: Text -> Either HistoryDefinitionError EvidenceKey+evidenceKey value+  | Text.null (Text.strip value) = Left EmptyEvidenceKey+  | otherwise = Right (EvidenceKey value)++-- | Construct evidence based only on the predecessor ledger row.+ledgerOnlyEvidence ::+  Text ->+  Maybe SourceTimestamp ->+  Maybe MigrationChecksum ->+  Value ->+  Either HistoryDefinitionError ImportEvidence+ledgerOnlyEvidence = staticEvidence LedgerOnly++-- | Construct evidence whose selected payload was verified against a source manifest.+sourceManifestVerifiedEvidence ::+  Text ->+  Maybe SourceTimestamp ->+  Maybe MigrationChecksum ->+  Value ->+  Either HistoryDefinitionError ImportEvidence+sourceManifestVerifiedEvidence = staticEvidence SourceManifestVerified++-- | Construct evidence whose payload reproduced the predecessor checksum.+sourceLedgerChecksumVerifiedEvidence ::+  Text ->+  Maybe SourceTimestamp ->+  Maybe MigrationChecksum ->+  Value ->+  Either HistoryDefinitionError ImportEvidence+sourceLedgerChecksumVerifiedEvidence = staticEvidence SourceLedgerChecksumVerified++staticEvidence ::+  EvidenceStrength ->+  Text ->+  Maybe SourceTimestamp ->+  Maybe MigrationChecksum ->+  Value ->+  Either HistoryDefinitionError ImportEvidence+staticEvidence strength identity appliedAt payloadChecksum details+  | Text.null (Text.strip identity) = Left EmptyEvidenceIdentity+  | otherwise = Right ImportEvidence {identity, appliedAt, strength, payloadChecksum, details}++-- | Associate one target migration with evidence and payload semantics.+historyMapping :: MigrationId -> EvidenceRequirement -> PayloadRelation -> HistoryMapping+historyMapping target requirement payload = HistoryMapping {target, requirement, payload}++-- | Inspect the declared payload relationship without exposing record construction.+historyMappingPayloadRelation :: HistoryMapping -> PayloadRelation+historyMappingPayloadRelation HistoryMapping {payload} = payload++-- | Validate a non-empty state-validation diagnostic.+stateValidationError :: Text -> Either HistoryDefinitionError StateValidationError+stateValidationError value+  | Text.null (Text.strip value) = Left EmptyStateValidationError+  | otherwise = Right (StateValidationError value)++-- | Define read-only state evidence produced under the importer transaction mode.+stateValidator ::+  EvidenceKey ->+  Transaction.Transaction (Either StateValidationError Value) ->+  StateValidator+stateValidator validatorEvidenceKey runStateValidator =+  StateValidator {validatorEvidenceKey, runStateValidator}++-- | Validate a complete source history import definition.+historyImport ::+  Text ->+  Map EvidenceKey ImportEvidence ->+  [StateValidator] ->+  NonEmpty HistoryMapping ->+  Text ->+  Either HistoryDefinitionError HistoryImport+historyImport source evidence validators mappings reason = do+  when (Text.null (Text.strip source)) (Left EmptyHistorySource)+  when (Text.null (Text.strip reason)) (Left EmptyHistoryReason)+  validateUnique validatorEvidenceKey DuplicateStateValidator validators+  for_ validators $ \validator ->+    when+      (Map.member (validatorEvidenceKey validator) evidence)+      (Left (EvidenceKeyCollision (validatorEvidenceKey validator)))+  validateUnique target DuplicateHistoryTarget (toList mappings)+  let knownKeys = Map.keysSet evidence <> Set.fromList (validatorEvidenceKey <$> validators)+  for_ mappings $ \mapping -> do+    validateRequirementReferences knownKeys (requirement mapping)+    case payload mapping of+      SamePayload key ->+        unless (requirementContains key (requirement mapping)) (Left (SamePayloadEvidenceNotRequired key))+      EquivalentState -> Right ()+  Right HistoryImport {source, evidence, validators, mappings, reason}++validateUnique ::+  (Ord key) =>+  (value -> key) ->+  (key -> HistoryDefinitionError) ->+  [value] ->+  Either HistoryDefinitionError ()+validateUnique keyOf duplicateError = go Set.empty+  where+    go _ [] = Right ()+    go seen (value : rest)+      | Set.member key seen = Left (duplicateError key)+      | otherwise = go (Set.insert key seen) rest+      where+        key = keyOf value++validateRequirementReferences ::+  Set EvidenceKey ->+  EvidenceRequirement ->+  Either HistoryDefinitionError ()+validateRequirementReferences knownKeys requirement =+  case requirement of+    Evidence key+      | Set.member key knownKeys -> Right ()+      | otherwise -> Left (UnknownRequirementEvidence key)+    AllOf requirements -> traverse_ (validateRequirementReferences knownKeys) requirements+    AnyOf requirements -> traverse_ (validateRequirementReferences knownKeys) requirements++requirementContains :: EvidenceKey -> EvidenceRequirement -> Bool+requirementContains wanted = \case+  Evidence key -> key == wanted+  AllOf requirements -> any (requirementContains wanted) requirements+  AnyOf requirements -> any (requirementContains wanted) requirements++-- | Use strict runner defaults and reject state-equivalent history.+defaultImportOptions :: ImportOptions+defaultImportOptions =+  ImportOptions+    { importRunOptions = defaultRunOptions,+      equivalentHistoryPolicy = RejectEquivalentHistory+    }++-- | Select the equivalent-history policy.+withEquivalentHistory :: EquivalentHistoryPolicy -> ImportOptions -> ImportOptions+withEquivalentHistory equivalentHistoryPolicy options = options {equivalentHistoryPolicy}++-- | Select the runner lock, timeout, ledger, and event configuration.+withImportRunOptions :: RunOptions -> ImportOptions -> ImportOptions+withImportRunOptions importRunOptions options = options {importRunOptions}++-- | Inspect the configured equivalent-history policy.+importEquivalentHistoryPolicy :: ImportOptions -> EquivalentHistoryPolicy+importEquivalentHistoryPolicy ImportOptions {equivalentHistoryPolicy} = equivalentHistoryPolicy
+ src/Database/PostgreSQL/Migrate/History/Validation.hs view
@@ -0,0 +1,315 @@+module Database.PostgreSQL.Migrate.History.Validation+  ( ResolvedHistoryMapping (..),+    resolveHistoryImport,+    validateHistoryMappingTargets,+    stateVerifiedEvidence,+  )+where++import Data.Aeson (Value, object, (.=))+import Data.ByteString qualified as ByteString+import Data.Int (Int32)+import Data.List qualified as List+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Data.Text qualified as Text+import Database.PostgreSQL.Migrate.History.Types+import Database.PostgreSQL.Migrate.Types+import Numeric (showHex)+import PgMigrate.Prelude++data ResolvedHistoryMapping = ResolvedHistoryMapping+  { resolvedTarget :: !MigrationId,+    resolvedPosition :: !Int32,+    resolvedChecksum :: !MigrationChecksum,+    resolvedKind :: !MigrationKind,+    resolvedTransactionMode :: !TransactionMode,+    resolvedAuditEvidence :: !Value+  }+  deriving stock (Generic, Eq, Show)++data PlannedTarget = PlannedTarget+  { plannedComponent :: !ComponentName,+    plannedPosition :: !Int32,+    plannedMigration :: !Migration+  }++data RequirementResult+  = RequirementUnsatisfied+  | RequirementSatisfied !(Set EvidenceKey)+  | RequirementAmbiguous++resolveHistoryImport ::+  EquivalentHistoryPolicy ->+  MigrationPlan ->+  Map EvidenceKey ImportEvidence ->+  HistoryImport ->+  Either HistoryValidationError (NonEmpty ResolvedHistoryMapping)+resolveHistoryImport policy plan availableEvidence history = do+  targets <- resolveTargets plan (mappings history)+  traverse (resolveMapping policy availableEvidence history) targets++-- | Validate that mappings name known, gap-free target prefixes before source reads.+validateHistoryMappingTargets ::+  MigrationPlan ->+  NonEmpty HistoryMapping ->+  Either HistoryValidationError ()+validateHistoryMappingTargets plan historyMappings = do+  _ <- resolveTargets plan historyMappings+  Right ()++resolveTargets ::+  MigrationPlan ->+  NonEmpty HistoryMapping ->+  Either HistoryValidationError (NonEmpty (HistoryMapping, PlannedTarget))+resolveTargets plan historyMappings = do+  targets <- traverse (lookupTarget (flattenPlan plan)) historyMappings+  validatePrefixes targets+  Right targets++stateVerifiedEvidence :: EvidenceKey -> Value -> ImportEvidence+stateVerifiedEvidence key details =+  ImportEvidence+    { identity = unEvidenceKey key,+      appliedAt = Nothing,+      strength = StateVerified,+      payloadChecksum = Nothing,+      details+    }++flattenPlan :: MigrationPlan -> Map MigrationId PlannedTarget+flattenPlan plan =+  Map.fromList+    [ ( MigrationId (componentNameOf component) (migrationNameOf migration),+        PlannedTarget+          { plannedComponent = componentNameOf component,+            plannedPosition = position,+            plannedMigration = migration+          }+      )+    | component <- toList (planComponentsOf plan),+      (position, migration) <- zip [1 ..] (toList (componentMigrationsOf component))+    ]++lookupTarget ::+  Map MigrationId PlannedTarget ->+  HistoryMapping ->+  Either HistoryValidationError (HistoryMapping, PlannedTarget)+lookupTarget plannedTargets mapping =+  case Map.lookup (target mapping) plannedTargets of+    Nothing -> Left (HistoryTargetUnknown (target mapping))+    Just planned -> Right (mapping, planned)++validatePrefixes ::+  NonEmpty (HistoryMapping, PlannedTarget) ->+  Either HistoryValidationError ()+validatePrefixes targets =+  for_ (Map.toAscList positionsByComponent) $ \(component, positions) ->+    case firstMissingPrefixPosition (List.sort positions) of+      Nothing -> Right ()+      Just missing -> Left (HistoryComponentPrefixGap component missing)+  where+    positionsByComponent =+      Map.fromListWith+        (<>)+        [ (plannedComponent planned, [fromIntegral (plannedPosition planned)])+        | (_, planned) <- toList targets+        ]++firstMissingPrefixPosition :: [Int] -> Maybe Int+firstMissingPrefixPosition positions =+  find (\expected -> expected `notElem` positions) [1 .. maximum positions]++resolveMapping ::+  EquivalentHistoryPolicy ->+  Map EvidenceKey ImportEvidence ->+  HistoryImport ->+  (HistoryMapping, PlannedTarget) ->+  Either HistoryValidationError ResolvedHistoryMapping+resolveMapping policy availableEvidence history (mapping, planned) = do+  usedKeys <-+    case evaluateRequirement availableEvidence (requirement mapping) of+      RequirementUnsatisfied -> Left (HistoryRequirementUnsatisfied (target mapping))+      RequirementAmbiguous -> Left (HistoryRequirementAmbiguous (target mapping))+      RequirementSatisfied keys -> Right keys+  validatePayload policy availableEvidence mapping planned usedKeys+  let migration = plannedMigration planned+  Right+    ResolvedHistoryMapping+      { resolvedTarget = target mapping,+        resolvedPosition = plannedPosition planned,+        resolvedChecksum = migrationChecksumOf migration,+        resolvedKind = migrationKindOf migration,+        resolvedTransactionMode = migrationModeOf migration,+        resolvedAuditEvidence = auditEvidence history mapping planned availableEvidence usedKeys+      }++evaluateRequirement ::+  Map EvidenceKey ImportEvidence ->+  EvidenceRequirement ->+  RequirementResult+evaluateRequirement available = \case+  Evidence key ->+    if Map.member key available+      then RequirementSatisfied (Set.singleton key)+      else RequirementUnsatisfied+  AllOf requirements ->+    combineAll (evaluateRequirement available <$> toList requirements)+  AnyOf requirements ->+    combineAny (evaluateRequirement available <$> toList requirements)++combineAll :: [RequirementResult] -> RequirementResult+combineAll results+  | any isAmbiguous results = RequirementAmbiguous+  | any isUnsatisfied results = RequirementUnsatisfied+  | otherwise = RequirementSatisfied (Set.unions [keys | RequirementSatisfied keys <- results])++combineAny :: [RequirementResult] -> RequirementResult+combineAny results =+  case [keys | RequirementSatisfied keys <- results] of+    []+      | any isAmbiguous results -> RequirementAmbiguous+      | otherwise -> RequirementUnsatisfied+    [keys]+      | any isAmbiguous results -> RequirementAmbiguous+      | otherwise -> RequirementSatisfied keys+    _ -> RequirementAmbiguous++isUnsatisfied :: RequirementResult -> Bool+isUnsatisfied RequirementUnsatisfied = True+isUnsatisfied _ = False++isAmbiguous :: RequirementResult -> Bool+isAmbiguous RequirementAmbiguous = True+isAmbiguous _ = False++validatePayload ::+  EquivalentHistoryPolicy ->+  Map EvidenceKey ImportEvidence ->+  HistoryMapping ->+  PlannedTarget ->+  Set EvidenceKey ->+  Either HistoryValidationError ()+validatePayload policy available mapping planned usedKeys =+  case payload mapping of+    SamePayload key -> do+      when+        (migrationKindOf (plannedMigration planned) == HaskellKind)+        (Left (HistorySamePayloadForHaskell (target mapping)))+      unless+        (Set.member key usedKeys)+        (Left (HistoryPayloadEvidenceMissing (target mapping) key))+      sourceEvidence <-+        maybe+          (Left (HistoryPayloadEvidenceMissing (target mapping) key))+          Right+          (Map.lookup key available)+      sourceChecksum <-+        maybe+          (Left (HistoryPayloadChecksumMissing (target mapping) key))+          Right+          (payloadChecksum sourceEvidence)+      unless+        (sourceChecksum == migrationChecksumOf (plannedMigration planned))+        (Left (HistoryPayloadChecksumMismatch (target mapping) key))+    EquivalentState -> do+      unless+        (policy == AllowEquivalentHistory)+        (Left (HistoryEquivalentStateDisallowed (target mapping)))+      unless+        ( any+            ((== StateVerified) . strength)+            (mapMaybe (`Map.lookup` available) (Set.toAscList usedKeys))+        )+        (Left (HistoryEquivalentStateUnverified (target mapping)))++auditEvidence ::+  HistoryImport ->+  HistoryMapping ->+  PlannedTarget ->+  Map EvidenceKey ImportEvidence ->+  Set EvidenceKey ->+  Value+auditEvidence history mapping planned available usedKeys =+  object+    [ "source" .= source history,+      "reason" .= reason history,+      "target" .= migrationIdValue (target mapping),+      "position" .= plannedPosition planned,+      "kind" .= kindText (migrationKindOf (plannedMigration planned)),+      "transaction_mode" .= modeText (migrationModeOf (plannedMigration planned)),+      "target_checksum" .= checksumText (migrationChecksumOf (plannedMigration planned)),+      "requirement" .= requirementValue (requirement mapping),+      "payload_relation" .= payloadValue (payload mapping),+      "satisfying_evidence"+        .= [ evidenceValue key sourceEvidence+           | key <- Set.toAscList usedKeys,+             sourceEvidence <- maybeToList (Map.lookup key available)+           ]+    ]++evidenceValue :: EvidenceKey -> ImportEvidence -> Value+evidenceValue key sourceEvidence =+  object+    [ "key" .= unEvidenceKey key,+      "identity" .= identity sourceEvidence,+      "applied_at" .= timestampValue (appliedAt sourceEvidence),+      "strength" .= strengthText (strength sourceEvidence),+      "payload_checksum" .= (checksumText <$> payloadChecksum sourceEvidence),+      "details" .= details sourceEvidence+    ]++requirementValue :: EvidenceRequirement -> Value+requirementValue = \case+  Evidence key -> object ["evidence" .= unEvidenceKey key]+  AllOf requirements -> object ["all_of" .= (requirementValue <$> toList requirements)]+  AnyOf requirements -> object ["any_of" .= (requirementValue <$> toList requirements)]++payloadValue :: PayloadRelation -> Value+payloadValue = \case+  SamePayload key -> object ["same_payload" .= unEvidenceKey key]+  EquivalentState -> object ["equivalent_state" .= True]++migrationIdValue :: MigrationId -> Value+migrationIdValue identifier =+  object+    [ "component" .= componentNameText (migrationIdComponent identifier),+      "migration" .= migrationNameText (migrationIdName identifier)+    ]++timestampValue :: Maybe SourceTimestamp -> Value+timestampValue = \case+  Nothing -> object ["kind" .= ("missing" :: Text)]+  Just (AbsoluteTime timestamp) ->+    object ["kind" .= ("absolute" :: Text), "value" .= show timestamp]+  Just (LocalTimeWithoutZone timestamp) ->+    object ["kind" .= ("local-without-zone" :: Text), "value" .= show timestamp]++strengthText :: EvidenceStrength -> Text+strengthText = \case+  LedgerOnly -> "ledger-only"+  SourceManifestVerified -> "source-manifest-verified"+  SourceLedgerChecksumVerified -> "source-ledger-checksum-verified"+  StateVerified -> "state-verified"++kindText :: MigrationKind -> Text+kindText = \case+  SqlKind -> "sql"+  HaskellKind -> "haskell"++modeText :: TransactionMode -> Text+modeText = \case+  Transactional -> "transactional"+  NonTransactional -> "nontransactional"++checksumText :: MigrationChecksum -> Text+checksumText (MigrationChecksum bytes) =+  Text.concat (twoHexDigits <$> ByteString.unpack bytes)+  where+    twoHexDigits byte =+      let encoded = Text.pack (showHex byte "")+       in if Text.length encoded == 1 then "0" <> encoded else encoded++maybeToList :: Maybe value -> [value]+maybeToList Nothing = []+maybeToList (Just value) = [value]
+ src/Database/PostgreSQL/Migrate/Inspection.hs view
@@ -0,0 +1,82 @@+module Database.PostgreSQL.Migrate.Inspection+  ( migrationStatus,+    migrationStatusWith,+    verifyMigrationPlan,+    verifyMigrationPlanWith,+  )+where++import Database.PostgreSQL.Migrate.Ledger (loadStatus, loadVerification)+import Database.PostgreSQL.Migrate.Ledger.Types (StatusReport, VerificationReport)+import Database.PostgreSQL.Migrate.Runner.Connection+  ( checkServerVersion,+    connectionProviderFromSettings,+  )+import Database.PostgreSQL.Migrate.Runner.Types+  ( ConnectionProvider (..),+    MigrationError (..),+    RunOptions,+    runLedgerConfig,+    runUnknownMigrationsPolicy,+  )+import Database.PostgreSQL.Migrate.Types (MigrationPlan)+import Hasql.Connection qualified as Connection+import Hasql.Connection.Settings qualified as Settings+import Hasql.Session (Session)++-- | Read operational plan status using concrete Hasql settings.+migrationStatus ::+  RunOptions ->+  Settings.Settings ->+  MigrationPlan ->+  IO (Either MigrationError StatusReport)+migrationStatus options settings =+  migrationStatusWith options (connectionProviderFromSettings settings)++-- | Read operational plan status using an application connection provider.+migrationStatusWith ::+  RunOptions ->+  ConnectionProvider ->+  MigrationPlan ->+  IO (Either MigrationError StatusReport)+migrationStatusWith options provider plan =+  runReadOnlySession+    provider+    (loadStatus (runLedgerConfig options) (runUnknownMigrationsPolicy options) plan)++-- | Strictly compare the declared plan with the ledger using concrete settings.+verifyMigrationPlan ::+  RunOptions ->+  Settings.Settings ->+  MigrationPlan ->+  IO (Either MigrationError VerificationReport)+verifyMigrationPlan options settings =+  verifyMigrationPlanWith options (connectionProviderFromSettings settings)++-- | Strictly compare the declared plan with the ledger using a provider.+verifyMigrationPlanWith ::+  RunOptions ->+  ConnectionProvider ->+  MigrationPlan ->+  IO (Either MigrationError VerificationReport)+verifyMigrationPlanWith options provider plan =+  runReadOnlySession provider (loadVerification (runLedgerConfig options) plan)++runReadOnlySession ::+  ConnectionProvider ->+  Session value ->+  IO (Either MigrationError value)+runReadOnlySession ConnectionProvider {useDedicatedConnection} session = do+  acquired <-+    useDedicatedConnection $ \connection -> do+      supported <- checkServerVersion connection+      case supported of+        Left migrationError -> pure (Left migrationError)+        Right _ -> do+          result <- Connection.use connection session+          pure $ case result of+            Left sessionError -> Left (DatabaseSessionFailed sessionError)+            Right value -> Right value+  pure $ case acquired of+    Left connectionError -> Left (ConnectionAcquisitionFailed connectionError)+    Right result -> result
+ src/Database/PostgreSQL/Migrate/Internal.hs view
@@ -0,0 +1,153 @@+{-# OPTIONS_HADDOCK hide #-}++module Database.PostgreSQL.Migrate.Internal+  ( MigrationKind (..),+    TransactionMode (..),+    MigrationDescription (..),+    ComponentDescription (..),+    PlanDescription (..),+    planDescription,+    componentNameText,+    migrationNameText,+    migrationIdComponent,+    migrationIdName,+    migrationChecksumBytes,+    migrationTransactionMode,+    migrationKind,+    migrationSqlBytes,+    PostgresIdentifier (..),+    postgresIdentifier,+    LedgerMetadata (..),+    LedgerSnapshot (..),+    LedgerError (..),+    currentLedgerVersion,+    ledgerMigrationVersions,+    ledgerUpgradePath,+    initializeOrUpgradeLedger,+    quotePostgresIdentifier,+    ledgerVersionOneDdl,+    LedgerConfig (..),+    ledgerSchemaText,+    comparePlanWithLedger,+    loadLedger,+    statusFromSnapshot,+    statusFromSnapshotWith,+    verifyFromSnapshot,+    loadStatus,+    loadVerification,+    runLedgerConfig,+    runLockWait,+    runStatementTimeout,+    runUnknownMigrationsPolicy,+    runEventHandler,+    useConnectionProvider,+    checkServerVersion,+    classifyServerVersion,+    acquireAdvisoryLock,+    releaseAdvisoryLock,+    applyStatementTimeout,+    restoreStatementTimeout,+    readStatementTimeout,+    ResolvedHistoryMapping (..),+    resolveHistoryImport,+    stateVerifiedEvidence,+  )+where++import Database.PostgreSQL.Migrate.History.Validation+  ( ResolvedHistoryMapping (..),+    resolveHistoryImport,+    stateVerifiedEvidence,+  )+import Database.PostgreSQL.Migrate.Ledger+  ( comparePlanWithLedger,+    loadLedger,+    loadStatus,+    loadVerification,+    statusFromSnapshot,+    statusFromSnapshotWith,+    verifyFromSnapshot,+  )+import Database.PostgreSQL.Migrate.Ledger.Migrations+  ( currentLedgerVersion,+    initializeOrUpgradeLedger,+    ledgerMigrationVersions,+    ledgerUpgradePath,+  )+import Database.PostgreSQL.Migrate.Ledger.Sql+  ( ledgerVersionOneDdl,+    quotePostgresIdentifier,+  )+import Database.PostgreSQL.Migrate.Ledger.Types+  ( LedgerConfig (..),+    LedgerError (..),+    LedgerMetadata (..),+    LedgerSnapshot (..),+    PostgresIdentifier (..),+    ledgerSchemaText,+    postgresIdentifier,+  )+import Database.PostgreSQL.Migrate.Plan+  ( ComponentDescription (..),+    MigrationDescription (..),+    PlanDescription (..),+    planDescription,+  )+import Database.PostgreSQL.Migrate.Runner.Connection+  ( checkServerVersion,+    classifyServerVersion,+  )+import Database.PostgreSQL.Migrate.Runner.Lock+  ( acquireAdvisoryLock,+    applyStatementTimeout,+    readStatementTimeout,+    releaseAdvisoryLock,+    restoreStatementTimeout,+  )+import Database.PostgreSQL.Migrate.Runner.Types+  ( ConnectionProvider (..),+    runEventHandler,+    runLedgerConfig,+    runLockWait,+    runStatementTimeout,+    runUnknownMigrationsPolicy,+  )+import Database.PostgreSQL.Migrate.Types+  ( Migration,+    MigrationAction (..),+    MigrationChecksum (..),+    MigrationKind (..),+    TransactionMode (..),+    componentNameText,+    migrationActionOf,+    migrationIdComponent,+    migrationIdName,+    migrationKindOf,+    migrationModeOf,+    migrationNameText,+  )+import Hasql.Connection qualified as Connection+import Hasql.Errors qualified as Errors+import PgMigrate.Prelude++migrationChecksumBytes :: MigrationChecksum -> ByteString+migrationChecksumBytes (MigrationChecksum bytes) = bytes++migrationTransactionMode :: Migration -> TransactionMode+migrationTransactionMode = migrationModeOf++migrationKind :: Migration -> MigrationKind+migrationKind = migrationKindOf++migrationSqlBytes :: Migration -> Maybe ByteString+migrationSqlBytes migration =+  case migrationActionOf migration of+    SqlAction bytes -> Just bytes+    TransactionAction _ -> Nothing+    SessionAction _ -> Nothing++useConnectionProvider ::+  ConnectionProvider ->+  (Connection.Connection -> IO value) ->+  IO (Either Errors.ConnectionError value)+useConnectionProvider ConnectionProvider {useDedicatedConnection} = useDedicatedConnection
+ src/Database/PostgreSQL/Migrate/Ledger.hs view
@@ -0,0 +1,244 @@+module Database.PostgreSQL.Migrate.Ledger+  ( comparePlanWithLedger,+    loadLedger,+    statusFromSnapshot,+    statusFromSnapshotWith,+    verifyFromSnapshot,+    loadStatus,+    loadVerification,+  )+where++import Data.List qualified as List+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Database.PostgreSQL.Migrate.Ledger.Sql+import Database.PostgreSQL.Migrate.Ledger.Types+import Database.PostgreSQL.Migrate.Plan+import Database.PostgreSQL.Migrate.Types+import Hasql.Session (Session)+import Hasql.Session qualified as Session+import PgMigrate.Prelude++comparePlanWithLedger ::+  UnknownMigrationsPolicy ->+  PlanDescription ->+  [StoredMigration] ->+  VerificationReport+comparePlanWithLedger unknownPolicy description storedInput =+  VerificationReport+    { issues =+        duplicateIdentityIssues+          <> duplicatePositionIssues+          <> statusIssues+          <> metadataIssues+          <> prefixIssues+          <> unknownIssues,+      appliedMigrations,+      pendingMigrations,+      unknownMigrations+    }+  where+    target = flattenPlan description+    targetById = Map.fromList ((\migration -> (migrationId migration, migration)) <$> target)+    stored = List.sortOn storedSortKey storedInput+    storedById = firstBy storedMigrationId stored++    duplicateIdentityIssues =+      DuplicateStoredMigration <$> duplicates (storedMigrationId <$> stored)+    duplicatePositionIssues =+      (\(component, position) -> DuplicateStoredPosition component position)+        <$> duplicates (storedPositionKey <$> stored)+    statusIssues = concatMap storedStatusIssues stored+    metadataIssues = concatMap (migrationMetadataIssues storedById) target+    prefixIssues = concatMap (componentPrefixIssues storedById) (planComponents description)++    unknownMigrations =+      filter ((`Map.notMember` targetById) . storedMigrationId) stored+    unknownIssues =+      case unknownPolicy of+        RejectUnknownMigrations -> UnknownStoredMigration . storedMigrationId <$> unknownMigrations+        AllowUnknownMigrations -> []++    appliedMigrations =+      mapMaybe (targetApplied storedById) target+    pendingMigrations =+      mapMaybe (targetPending storedById) target++loadLedger :: LedgerConfig -> Session LedgerSnapshot+loadLedger config = do+  ledgerExists <-+    Session.statement+      (ledgerSchemaText config)+      ledgerMetadataExistsStatement+  if ledgerExists+    then do+      metadata <- Session.statement () (loadLedgerMetadataStatement config)+      storedMigrations <- Session.statement () (loadStoredMigrationsStatement config)+      pure LedgerSnapshot {metadata = Just metadata, storedMigrations}+    else pure LedgerSnapshot {metadata = Nothing, storedMigrations = []}++statusFromSnapshot :: MigrationPlan -> LedgerSnapshot -> StatusReport+statusFromSnapshot = statusFromSnapshotWith AllowUnknownMigrations++statusFromSnapshotWith ::+  UnknownMigrationsPolicy ->+  MigrationPlan ->+  LedgerSnapshot ->+  StatusReport+statusFromSnapshotWith unknownPolicy plan LedgerSnapshot {storedMigrations} =+  case comparePlanWithLedger unknownPolicy (planDescription plan) storedMigrations of+    VerificationReport+      { issues,+        appliedMigrations,+        pendingMigrations,+        unknownMigrations+      } ->+        StatusReport+          { issues,+            appliedMigrations,+            pendingMigrations,+            unknownMigrations+          }++verifyFromSnapshot :: MigrationPlan -> LedgerSnapshot -> VerificationReport+verifyFromSnapshot plan LedgerSnapshot {storedMigrations} =+  case comparePlanWithLedger RejectUnknownMigrations (planDescription plan) storedMigrations of+    VerificationReport+      { issues,+        appliedMigrations,+        pendingMigrations,+        unknownMigrations+      } ->+        VerificationReport+          { issues = issues <> (PendingMigration <$> pendingMigrations),+            appliedMigrations,+            pendingMigrations,+            unknownMigrations+          }++loadStatus ::+  LedgerConfig ->+  UnknownMigrationsPolicy ->+  MigrationPlan ->+  Session StatusReport+loadStatus config unknownPolicy plan =+  statusFromSnapshotWith unknownPolicy plan <$> loadLedger config++loadVerification :: LedgerConfig -> MigrationPlan -> Session VerificationReport+loadVerification config plan = verifyFromSnapshot plan <$> loadLedger config++flattenPlan :: PlanDescription -> [MigrationDescription]+flattenPlan description =+  concatMap (toList . componentMigrations) (planComponents description)++planComponents :: PlanDescription -> [ComponentDescription]+planComponents (PlanDescription components) = toList components++componentMigrations :: ComponentDescription -> NonEmpty MigrationDescription+componentMigrations ComponentDescription {migrations} = migrations++storedSortKey :: StoredMigration -> (Text, Int, Text)+storedSortKey StoredMigration {storedMigrationId, position = storedPosition} =+  ( componentNameText (migrationIdComponent storedMigrationId),+    storedPosition,+    migrationNameText (migrationIdName storedMigrationId)+  )++storedPositionKey :: StoredMigration -> (ComponentName, Int)+storedPositionKey StoredMigration {storedMigrationId, position = storedPosition} =+  (migrationIdComponent storedMigrationId, storedPosition)++firstBy :: (Ord key) => (value -> key) -> [value] -> Map key value+firstBy keyOf =+  foldl+    (\values value -> Map.insertWith (\_ previous -> previous) (keyOf value) value values)+    Map.empty++duplicates :: (Ord value) => [value] -> [value]+duplicates = go Set.empty Set.empty+  where+    go _ _ [] = []+    go seen reported (value : rest)+      | value `Set.member` reported = go seen reported rest+      | value `Set.member` seen = value : go seen (Set.insert value reported) rest+      | otherwise = go (Set.insert value seen) reported rest++storedStatusIssues :: StoredMigration -> [VerificationIssue]+storedStatusIssues stored =+  case status stored of+    Running -> [StoredMigrationRunning (storedMigrationId stored)]+    Applied -> []+    Failed -> [StoredMigrationFailed (storedMigrationId stored)]++migrationMetadataIssues ::+  Map MigrationId StoredMigration ->+  MigrationDescription ->+  [VerificationIssue]+migrationMetadataIssues storedById expected =+  case Map.lookup expectedId storedById of+    Nothing -> []+    Just+      StoredMigration+        { position = actualPosition,+          checksum = actualChecksum,+          kind = actualKind,+          transactionMode = actualMode+        } ->+        concat+          [ [ MigrationPositionMismatch expectedId expectedPosition actualPosition+            | actualPosition /= expectedPosition+            ],+            [ MigrationChecksumMismatch expectedId expectedChecksum actualChecksum+            | actualChecksum /= expectedChecksum+            ],+            [ MigrationKindMismatch expectedId expectedKind actualKind+            | actualKind /= expectedKind+            ],+            [ MigrationTransactionModeMismatch expectedId expectedMode actualMode+            | actualMode /= expectedMode+            ]+          ]+  where+    MigrationDescription+      { migrationId = expectedId,+        position = expectedPosition,+        checksum = expectedChecksum,+        kind = expectedKind,+        transactionMode = expectedMode+      } = expected++componentPrefixIssues ::+  Map MigrationId StoredMigration ->+  ComponentDescription ->+  [VerificationIssue]+componentPrefixIssues storedById ComponentDescription {migrations} =+  snd (foldl step (Nothing, []) (toList migrations))+  where+    step (firstGap, accumulated) MigrationDescription {migrationId}+      | Map.member migrationId storedById =+          case firstGap of+            Nothing -> (Nothing, accumulated)+            Just missing ->+              (Just missing, accumulated <> [AppliedMigrationAfterGap migrationId missing])+      | otherwise = (Just (fromMaybe migrationId firstGap), accumulated)++targetApplied ::+  Map MigrationId StoredMigration ->+  MigrationDescription ->+  Maybe MigrationId+targetApplied storedById MigrationDescription {migrationId} = do+  stored <- Map.lookup migrationId storedById+  case status stored of+    Applied -> Just migrationId+    Running -> Nothing+    Failed -> Nothing++targetPending ::+  Map MigrationId StoredMigration ->+  MigrationDescription ->+  Maybe MigrationId+targetPending storedById MigrationDescription {migrationId} =+  case Map.lookup migrationId storedById of+    Just stored | status stored == Applied -> Nothing+    _ -> Just migrationId
+ src/Database/PostgreSQL/Migrate/Ledger/Migrations.hs view
@@ -0,0 +1,76 @@+module Database.PostgreSQL.Migrate.Ledger.Migrations+  ( LedgerMigration,+    currentLedgerVersion,+    ledgerSchemaVersion,+    ledgerMigrationVersions,+    ledgerUpgradePath,+    initializeOrUpgradeLedger,+  )+where++import Data.Int (Int32)+import Data.Text.Encoding qualified as Text.Encoding+import Database.PostgreSQL.Migrate.Ledger.Sql+import Database.PostgreSQL.Migrate.Ledger.Types+import Hasql.Session (Session)+import Hasql.Session qualified as Session+import Hasql.Transaction (Transaction)+import Hasql.Transaction qualified as Transaction+import Hasql.Transaction.Sessions qualified as Transaction.Sessions+import PgMigrate.Prelude++data LedgerMigration = LedgerMigration+  { targetVersion :: !Int32,+    action :: !(Transaction ())+  }++currentLedgerVersion :: Int32+currentLedgerVersion = 1++-- | Publicly supported on-disk ledger contract version.+ledgerSchemaVersion :: Int+ledgerSchemaVersion = fromIntegral currentLedgerVersion++ledgerMigrationVersions :: [Int32]+ledgerMigrationVersions = [1]++ledgerUpgradePath :: Int32 -> Either LedgerError [Int32]+ledgerUpgradePath databaseVersion+  | databaseVersion < 0 = Left (InvalidLedgerVersion databaseVersion)+  | databaseVersion > currentLedgerVersion =+      Left LedgerTooNew {databaseVersion, supportedVersion = currentLedgerVersion}+  | otherwise = Right (filter (> databaseVersion) ledgerMigrationVersions)++initializeOrUpgradeLedger :: LedgerConfig -> Text -> Session (Either LedgerError ())+initializeOrUpgradeLedger config runnerVersion = do+  ledgerExists <-+    Session.statement+      (ledgerSchemaText config)+      ledgerMetadataExistsStatement+  databaseVersion <-+    if ledgerExists+      then schemaVersion <$> Session.statement () (loadLedgerMetadataStatement config)+      else pure 0+  case ledgerUpgradePath databaseVersion of+    Left ledgerError -> pure (Left ledgerError)+    Right versions -> do+      traverse_ runMigration (migrationForVersion <$> versions)+      pure (Right ())+  where+    runMigration LedgerMigration {action} =+      Transaction.Sessions.transactionNoRetry+        Transaction.Sessions.Serializable+        Transaction.Sessions.Write+        action+    migrationForVersion = \case+      1 -> versionOneMigration config runnerVersion+      unsupported -> error ("missing ledger migration version " <> show unsupported)++versionOneMigration :: LedgerConfig -> Text -> LedgerMigration+versionOneMigration config runnerVersion =+  LedgerMigration+    { targetVersion = 1,+      action = do+        Transaction.sql (Text.Encoding.encodeUtf8 (ledgerVersionOneDdl config))+        Transaction.statement runnerVersion (insertLedgerMetadataStatement config)+    }
+ src/Database/PostgreSQL/Migrate/Ledger/Sql.hs view
@@ -0,0 +1,537 @@+module Database.PostgreSQL.Migrate.Ledger.Sql+  ( quotePostgresIdentifier,+    qualifiedLedgerTable,+    ledgerMetadataExistsStatement,+    loadLedgerMetadataStatement,+    insertLedgerMetadataStatement,+    loadStoredMigrationsStatement,+    AppliedLedgerRow (..),+    FailedLedgerRow (..),+    insertAppliedMigrationStatement,+    insertRunningMigrationStatement,+    markRunningMigrationAppliedStatement,+    markRunningMigrationFailedStatement,+    RepairLedgerRow (..),+    insertRepairAuditStatement,+    prepareMarkAppliedStatement,+    prepareRetryStatement,+    HistoryLedgerRow (..),+    StoredHistoryImport (..),+    loadHistoryImportsStatement,+    insertImportedMigrationStatement,+    insertHistoryImportAuditStatement,+    ledgerVersionOneDdl,+  )+where++import Data.Aeson (Value)+import Data.Aeson qualified as Aeson+import Data.Functor.Contravariant (contramap)+import Data.Int (Int32, Int64)+import Data.Text qualified as Text+import Data.Time (UTCTime)+import Database.PostgreSQL.Migrate.Ledger.Types+import Database.PostgreSQL.Migrate.Types+import Hasql.Decoders qualified as Decoders+import Hasql.Encoders qualified as Encoders+import Hasql.Statement (Statement)+import Hasql.Statement qualified as Statement+import PgMigrate.Prelude++quotePostgresIdentifier :: PostgresIdentifier -> Text+quotePostgresIdentifier identifier =+  "\"" <> Text.replace "\"" "\"\"" (postgresIdentifierText identifier) <> "\""++qualifiedLedgerTable :: LedgerConfig -> Text -> Text+qualifiedLedgerTable config table =+  quotePostgresIdentifier (schema config) <> ".\"" <> table <> "\""++ledgerMetadataExistsStatement :: Statement Text Bool+ledgerMetadataExistsStatement =+  Statement.preparable+    """+    SELECT EXISTS+    (+      SELECT 1+      FROM information_schema.tables+      WHERE table_schema = $1+        AND table_name = 'ledger_metadata'+    )+    """+    (Encoders.param (Encoders.nonNullable Encoders.text))+    (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.bool)))++loadLedgerMetadataStatement :: LedgerConfig -> Statement () LedgerMetadata+loadLedgerMetadataStatement config =+  Statement.unpreparable+    ( "SELECT schema_version, runner_version FROM "+        <> qualifiedLedgerTable config "ledger_metadata"+        <> " WHERE singleton = true"+    )+    Encoders.noParams+    ( Decoders.singleRow+        ( LedgerMetadata+            <$> Decoders.column (Decoders.nonNullable Decoders.int4)+            <*> Decoders.column (Decoders.nonNullable Decoders.text)+        )+    )++insertLedgerMetadataStatement :: LedgerConfig -> Statement Text ()+insertLedgerMetadataStatement config =+  Statement.unpreparable+    ( "INSERT INTO "+        <> qualifiedLedgerTable config "ledger_metadata"+        <> " (singleton, schema_version, runner_version) VALUES (true, 1, $1)"+    )+    (Encoders.param (Encoders.nonNullable Encoders.text))+    Decoders.noResult++loadStoredMigrationsStatement :: LedgerConfig -> Statement () [StoredMigration]+loadStoredMigrationsStatement config =+  Statement.unpreparable+    ( Text.unwords+        [ "SELECT component, migration, position, checksum, kind, transaction_mode,",+          "status, started_at, finished_at, execution_time_ms, error, runner_version",+          "FROM",+          qualifiedLedgerTable config "migrations",+          "ORDER BY component, position"+        ]+    )+    Encoders.noParams+    (Decoders.rowList storedMigrationRow)++storedMigrationRow :: Decoders.Row StoredMigration+storedMigrationRow =+  StoredMigration+    <$> ( MigrationId+            <$> (ComponentName <$> required Decoders.text)+            <*> (MigrationName <$> required Decoders.text)+        )+    <*> (fromIntegral <$> required Decoders.int4)+    <*> (MigrationChecksum <$> required Decoders.bytea)+    <*> required (Decoders.refine decodeMigrationKind Decoders.text)+    <*> required (Decoders.refine decodeTransactionMode Decoders.text)+    <*> required (Decoders.refine decodeMigrationStatus Decoders.text)+    <*> required Decoders.timestamptz+    <*> optional Decoders.timestamptz+    <*> optional Decoders.int8+    <*> optional Decoders.text+    <*> required Decoders.text+  where+    required = Decoders.column . Decoders.nonNullable+    optional = Decoders.column . Decoders.nullable++decodeMigrationKind :: Text -> Either Text MigrationKind+decodeMigrationKind = \case+  "sql" -> Right SqlKind+  "haskell" -> Right HaskellKind+  value -> Left ("unsupported migration kind: " <> value)++decodeTransactionMode :: Text -> Either Text TransactionMode+decodeTransactionMode = \case+  "transactional" -> Right Transactional+  "nontransactional" -> Right NonTransactional+  value -> Left ("unsupported transaction mode: " <> value)++decodeMigrationStatus :: Text -> Either Text MigrationStatus+decodeMigrationStatus = \case+  "running" -> Right Running+  "applied" -> Right Applied+  "failed" -> Right Failed+  value -> Left ("unsupported migration status: " <> value)++data AppliedLedgerRow = AppliedLedgerRow+  { appliedMigrationId :: !MigrationId,+    appliedPosition :: !Int32,+    appliedChecksum :: !MigrationChecksum,+    appliedKind :: !MigrationKind,+    appliedTransactionMode :: !TransactionMode,+    appliedStartedAt :: !UTCTime,+    appliedRunnerVersion :: !Text+  }++data FailedLedgerRow = FailedLedgerRow+  { failedLedgerIdentity :: !AppliedLedgerRow,+    failedLedgerError :: !Text+  }++data RepairLedgerRow = RepairLedgerRow+  { repairLedgerMigrationId :: !MigrationId,+    repairLedgerOperation :: !Text,+    repairLedgerOldStatus :: !MigrationStatus,+    repairLedgerNewStatus :: !MigrationStatus,+    repairLedgerReason :: !Text,+    repairLedgerRunnerVersion :: !Text+  }++data HistoryLedgerRow = HistoryLedgerRow+  { historyLedgerMigrationId :: !MigrationId,+    historyLedgerPosition :: !Int32,+    historyLedgerChecksum :: !MigrationChecksum,+    historyLedgerKind :: !MigrationKind,+    historyLedgerTransactionMode :: !TransactionMode,+    historyLedgerImportedAt :: !UTCTime,+    historyLedgerSource :: !Text,+    historyLedgerEvidence :: !ByteString,+    historyLedgerReason :: !Text,+    historyLedgerRunnerVersion :: !Text+  }++data StoredHistoryImport = StoredHistoryImport+  { storedHistoryMigrationId :: !MigrationId,+    storedHistorySource :: !Text,+    storedHistoryEvidence :: !Value,+    storedHistoryReason :: !Text+  }+  deriving stock (Generic, Eq, Show)++insertAppliedMigrationStatement :: LedgerConfig -> Statement AppliedLedgerRow ()+insertAppliedMigrationStatement config =+  Statement.unpreparable+    ( Text.unwords+        [ "INSERT INTO",+          qualifiedLedgerTable config "migrations",+          "(component, migration, position, checksum, kind, transaction_mode, status,",+          "started_at, finished_at, execution_time_ms, error, runner_version)",+          "VALUES ($1, $2, $3, $4, $5, $6, 'applied', $7, clock_timestamp(),",+          "GREATEST(0, round(extract(epoch FROM (clock_timestamp() - $7)) * 1000))::bigint,",+          "NULL, $8)"+        ]+    )+    appliedLedgerRowEncoder+    Decoders.noResult++insertRunningMigrationStatement :: LedgerConfig -> Statement AppliedLedgerRow ()+insertRunningMigrationStatement config =+  Statement.unpreparable+    ( Text.unwords+        [ "INSERT INTO",+          qualifiedLedgerTable config "migrations",+          "(component, migration, position, checksum, kind, transaction_mode, status,",+          "started_at, finished_at, execution_time_ms, error, runner_version)",+          "VALUES ($1, $2, $3, $4, $5, $6, 'running', $7, NULL, NULL, NULL, $8)"+        ]+    )+    appliedLedgerRowEncoder+    Decoders.noResult++markRunningMigrationAppliedStatement :: LedgerConfig -> Statement AppliedLedgerRow Int64+markRunningMigrationAppliedStatement config =+  Statement.unpreparable+    ( Text.unwords+        [ "UPDATE",+          qualifiedLedgerTable config "migrations",+          "SET status = 'applied', finished_at = clock_timestamp(),",+          "execution_time_ms = GREATEST(0, round(extract(epoch FROM",+          "(clock_timestamp() - started_at)) * 1000))::bigint, error = NULL",+          "WHERE component = $1 AND migration = $2 AND position = $3 AND checksum = $4",+          "AND kind = $5 AND transaction_mode = $6 AND status = 'running'"+        ]+    )+    appliedLedgerIdentityEncoder+    Decoders.rowsAffected++markRunningMigrationFailedStatement :: LedgerConfig -> Statement FailedLedgerRow Int64+markRunningMigrationFailedStatement config =+  Statement.unpreparable+    ( Text.unwords+        [ "UPDATE",+          qualifiedLedgerTable config "migrations",+          "SET status = 'failed', finished_at = clock_timestamp(),",+          "execution_time_ms = GREATEST(0, round(extract(epoch FROM",+          "(clock_timestamp() - started_at)) * 1000))::bigint, error = $7",+          "WHERE component = $1 AND migration = $2 AND position = $3 AND checksum = $4",+          "AND kind = $5 AND transaction_mode = $6 AND status = 'running'"+        ]+    )+    failedLedgerRowEncoder+    Decoders.rowsAffected++insertRepairAuditStatement :: LedgerConfig -> Statement RepairLedgerRow ()+insertRepairAuditStatement config =+  Statement.unpreparable+    ( Text.unwords+        [ "INSERT INTO",+          qualifiedLedgerTable config "repairs",+          "(component, migration, operation, old_status, new_status, reason, runner_version)",+          "VALUES ($1, $2, $3, $4, $5, $6, $7)"+        ]+    )+    repairLedgerRowEncoder+    Decoders.noResult++prepareMarkAppliedStatement :: LedgerConfig -> Statement RepairLedgerRow Int64+prepareMarkAppliedStatement config =+  Statement.unpreparable+    ( Text.unwords+        [ "UPDATE",+          qualifiedLedgerTable config "migrations",+          "SET status = 'applied', finished_at = clock_timestamp(),",+          "execution_time_ms = COALESCE(execution_time_ms,",+          "GREATEST(0, round(extract(epoch FROM (clock_timestamp() - started_at)) * 1000))::bigint),",+          "error = NULL WHERE component = $1 AND migration = $2 AND status = $3"+        ]+    )+    repairTransitionEncoder+    Decoders.rowsAffected++prepareRetryStatement :: LedgerConfig -> Statement RepairLedgerRow Int64+prepareRetryStatement config =+  Statement.unpreparable+    ( Text.unwords+        [ "UPDATE",+          qualifiedLedgerTable config "migrations",+          "SET status = 'running', started_at = clock_timestamp(), finished_at = NULL,",+          "execution_time_ms = NULL, error = NULL, runner_version = $4",+          "WHERE component = $1 AND migration = $2 AND status = $3"+        ]+    )+    repairRetryEncoder+    Decoders.rowsAffected++loadHistoryImportsStatement :: LedgerConfig -> Statement () [StoredHistoryImport]+loadHistoryImportsStatement config =+  Statement.unpreparable+    ( Text.unwords+        [ "SELECT component, migration, source, source_evidence, reason FROM",+          qualifiedLedgerTable config "history_imports",+          "ORDER BY component, migration"+        ]+    )+    Encoders.noParams+    (Decoders.rowList storedHistoryImportRow)++insertImportedMigrationStatement :: LedgerConfig -> Statement HistoryLedgerRow ()+insertImportedMigrationStatement config =+  Statement.unpreparable+    ( Text.unwords+        [ "INSERT INTO",+          qualifiedLedgerTable config "migrations",+          "(component, migration, position, checksum, kind, transaction_mode, status,",+          "started_at, finished_at, execution_time_ms, error, runner_version)",+          "VALUES ($1, $2, $3, $4, $5, $6, 'applied', $7, $7, 0, NULL, $8)"+        ]+    )+    historyMigrationEncoder+    Decoders.noResult++insertHistoryImportAuditStatement :: LedgerConfig -> Statement HistoryLedgerRow ()+insertHistoryImportAuditStatement config =+  Statement.unpreparable+    ( Text.unwords+        [ "INSERT INTO",+          qualifiedLedgerTable config "history_imports",+          "(component, migration, source, source_evidence, reason, imported_at, runner_version)",+          "VALUES ($1, $2, $3, $4, $5, $6, $7)"+        ]+    )+    historyAuditEncoder+    Decoders.noResult++storedHistoryImportRow :: Decoders.Row StoredHistoryImport+storedHistoryImportRow =+  StoredHistoryImport+    <$> ( MigrationId+            <$> (ComponentName <$> required Decoders.text)+            <*> (MigrationName <$> required Decoders.text)+        )+    <*> required Decoders.text+    <*> required (Decoders.jsonbBytes (first Text.pack . Aeson.eitherDecodeStrict'))+    <*> required Decoders.text+  where+    required = Decoders.column . Decoders.nonNullable++appliedLedgerRowEncoder :: Encoders.Params AppliedLedgerRow+appliedLedgerRowEncoder =+  mconcat+    [ contramap appliedComponentText (Encoders.param (Encoders.nonNullable Encoders.text)),+      contramap appliedMigrationText (Encoders.param (Encoders.nonNullable Encoders.text)),+      contramap appliedPosition (Encoders.param (Encoders.nonNullable Encoders.int4)),+      contramap appliedChecksumBytes (Encoders.param (Encoders.nonNullable Encoders.bytea)),+      contramap (encodeMigrationKind . appliedKind) (Encoders.param (Encoders.nonNullable Encoders.text)),+      contramap (encodeTransactionMode . appliedTransactionMode) (Encoders.param (Encoders.nonNullable Encoders.text)),+      contramap appliedStartedAt (Encoders.param (Encoders.nonNullable Encoders.timestamptz)),+      contramap appliedRunnerVersion (Encoders.param (Encoders.nonNullable Encoders.text))+    ]++appliedLedgerIdentityEncoder :: Encoders.Params AppliedLedgerRow+appliedLedgerIdentityEncoder =+  mconcat+    [ contramap appliedComponentText (Encoders.param (Encoders.nonNullable Encoders.text)),+      contramap appliedMigrationText (Encoders.param (Encoders.nonNullable Encoders.text)),+      contramap appliedPosition (Encoders.param (Encoders.nonNullable Encoders.int4)),+      contramap appliedChecksumBytes (Encoders.param (Encoders.nonNullable Encoders.bytea)),+      contramap (encodeMigrationKind . appliedKind) (Encoders.param (Encoders.nonNullable Encoders.text)),+      contramap (encodeTransactionMode . appliedTransactionMode) (Encoders.param (Encoders.nonNullable Encoders.text))+    ]++failedLedgerRowEncoder :: Encoders.Params FailedLedgerRow+failedLedgerRowEncoder =+  contramap failedLedgerIdentity appliedLedgerIdentityEncoder+    <> contramap failedLedgerError (Encoders.param (Encoders.nonNullable Encoders.text))++repairLedgerRowEncoder :: Encoders.Params RepairLedgerRow+repairLedgerRowEncoder =+  mconcat+    [ contramap repairComponentText (Encoders.param (Encoders.nonNullable Encoders.text)),+      contramap repairMigrationText (Encoders.param (Encoders.nonNullable Encoders.text)),+      contramap repairLedgerOperation (Encoders.param (Encoders.nonNullable Encoders.text)),+      contramap (encodeMigrationStatus . repairLedgerOldStatus) (Encoders.param (Encoders.nonNullable Encoders.text)),+      contramap (encodeMigrationStatus . repairLedgerNewStatus) (Encoders.param (Encoders.nonNullable Encoders.text)),+      contramap repairLedgerReason (Encoders.param (Encoders.nonNullable Encoders.text)),+      contramap repairLedgerRunnerVersion (Encoders.param (Encoders.nonNullable Encoders.text))+    ]++repairTransitionEncoder :: Encoders.Params RepairLedgerRow+repairTransitionEncoder =+  mconcat+    [ contramap repairComponentText (Encoders.param (Encoders.nonNullable Encoders.text)),+      contramap repairMigrationText (Encoders.param (Encoders.nonNullable Encoders.text)),+      contramap (encodeMigrationStatus . repairLedgerOldStatus) (Encoders.param (Encoders.nonNullable Encoders.text))+    ]++repairRetryEncoder :: Encoders.Params RepairLedgerRow+repairRetryEncoder =+  repairTransitionEncoder+    <> contramap repairLedgerRunnerVersion (Encoders.param (Encoders.nonNullable Encoders.text))++historyMigrationEncoder :: Encoders.Params HistoryLedgerRow+historyMigrationEncoder =+  mconcat+    [ contramap historyComponentText (Encoders.param (Encoders.nonNullable Encoders.text)),+      contramap historyMigrationText (Encoders.param (Encoders.nonNullable Encoders.text)),+      contramap historyLedgerPosition (Encoders.param (Encoders.nonNullable Encoders.int4)),+      contramap historyChecksumBytes (Encoders.param (Encoders.nonNullable Encoders.bytea)),+      contramap (encodeMigrationKind . historyLedgerKind) (Encoders.param (Encoders.nonNullable Encoders.text)),+      contramap (encodeTransactionMode . historyLedgerTransactionMode) (Encoders.param (Encoders.nonNullable Encoders.text)),+      contramap historyLedgerImportedAt (Encoders.param (Encoders.nonNullable Encoders.timestamptz)),+      contramap historyLedgerRunnerVersion (Encoders.param (Encoders.nonNullable Encoders.text))+    ]++historyAuditEncoder :: Encoders.Params HistoryLedgerRow+historyAuditEncoder =+  mconcat+    [ contramap historyComponentText (Encoders.param (Encoders.nonNullable Encoders.text)),+      contramap historyMigrationText (Encoders.param (Encoders.nonNullable Encoders.text)),+      contramap historyLedgerSource (Encoders.param (Encoders.nonNullable Encoders.text)),+      contramap historyLedgerEvidence (Encoders.param (Encoders.nonNullable Encoders.jsonbBytes)),+      contramap historyLedgerReason (Encoders.param (Encoders.nonNullable Encoders.text)),+      contramap historyLedgerImportedAt (Encoders.param (Encoders.nonNullable Encoders.timestamptz)),+      contramap historyLedgerRunnerVersion (Encoders.param (Encoders.nonNullable Encoders.text))+    ]++historyComponentText :: HistoryLedgerRow -> Text+historyComponentText = componentNameText . migrationIdComponent . historyLedgerMigrationId++historyMigrationText :: HistoryLedgerRow -> Text+historyMigrationText = migrationNameText . migrationIdName . historyLedgerMigrationId++historyChecksumBytes :: HistoryLedgerRow -> ByteString+historyChecksumBytes HistoryLedgerRow {historyLedgerChecksum = MigrationChecksum bytes} = bytes++repairComponentText :: RepairLedgerRow -> Text+repairComponentText = componentNameText . migrationIdComponent . repairLedgerMigrationId++repairMigrationText :: RepairLedgerRow -> Text+repairMigrationText = migrationNameText . migrationIdName . repairLedgerMigrationId++appliedComponentText :: AppliedLedgerRow -> Text+appliedComponentText = componentNameText . migrationIdComponent . appliedMigrationId++appliedMigrationText :: AppliedLedgerRow -> Text+appliedMigrationText = migrationNameText . migrationIdName . appliedMigrationId++appliedChecksumBytes :: AppliedLedgerRow -> ByteString+appliedChecksumBytes AppliedLedgerRow {appliedChecksum = MigrationChecksum bytes} = bytes++encodeMigrationKind :: MigrationKind -> Text+encodeMigrationKind = \case+  SqlKind -> "sql"+  HaskellKind -> "haskell"++encodeTransactionMode :: TransactionMode -> Text+encodeTransactionMode = \case+  Transactional -> "transactional"+  NonTransactional -> "nontransactional"++encodeMigrationStatus :: MigrationStatus -> Text+encodeMigrationStatus = \case+  Running -> "running"+  Applied -> "applied"+  Failed -> "failed"++ledgerVersionOneDdl :: LedgerConfig -> Text+ledgerVersionOneDdl config =+  Text.unlines+    [ "CREATE SCHEMA IF NOT EXISTS " <> quotePostgresIdentifier (schema config) <> ";",+      "CREATE TABLE " <> metadataTable,+      "(",+      "    singleton       boolean     PRIMARY KEY DEFAULT true CHECK (singleton),",+      "    schema_version  integer     NOT NULL CHECK (schema_version > 0),",+      "    updated_at      timestamptz NOT NULL DEFAULT clock_timestamp(),",+      "    runner_version  text        NOT NULL",+      ");",+      "CREATE TABLE " <> migrationsTable,+      "(",+      "    component          text        NOT NULL,",+      "    migration          text        NOT NULL,",+      "    position           integer     NOT NULL CHECK (position > 0),",+      "    checksum           bytea       NOT NULL CHECK (octet_length(checksum) = 32),",+      "    kind               text        NOT NULL CHECK (kind IN ('sql', 'haskell')),",+      "    transaction_mode   text        NOT NULL",+      "        CHECK (transaction_mode IN ('transactional', 'nontransactional')),",+      "    status             text        NOT NULL",+      "        CHECK (status IN ('running', 'applied', 'failed')),",+      "    started_at         timestamptz NOT NULL,",+      "    finished_at        timestamptz,",+      "    execution_time_ms  bigint      CHECK (execution_time_ms >= 0),",+      "    error               text,",+      "    runner_version      text        NOT NULL,",+      "    CHECK (transaction_mode = 'nontransactional' OR status = 'applied'),",+      "    CHECK",+      "    (",+      "        (status = 'running' AND finished_at IS NULL AND error IS NULL)",+      "        OR",+      "        (status = 'applied' AND finished_at IS NOT NULL AND error IS NULL)",+      "        OR",+      "        (status = 'failed' AND finished_at IS NOT NULL AND error IS NOT NULL)",+      "    ),",+      "    PRIMARY KEY (component, migration),",+      "    UNIQUE (component, position)",+      ");",+      "CREATE TABLE " <> historyImportsTable,+      "(",+      "    component       text        NOT NULL,",+      "    migration       text        NOT NULL,",+      "    source          text        NOT NULL,",+      "    source_evidence jsonb       NOT NULL,",+      "    reason          text        NOT NULL,",+      "    imported_at     timestamptz NOT NULL DEFAULT clock_timestamp(),",+      "    imported_by     text        NOT NULL DEFAULT current_user,",+      "    runner_version  text        NOT NULL,",+      "    PRIMARY KEY (component, migration),",+      "    FOREIGN KEY (component, migration)",+      "        REFERENCES " <> migrationsTable <> " (component, migration)",+      ");",+      "CREATE TABLE " <> repairsTable,+      "(",+      "    id              bigint GENERATED ALWAYS AS IDENTITY PRIMARY KEY,",+      "    component       text        NOT NULL,",+      "    migration       text        NOT NULL,",+      "    operation       text        NOT NULL",+      "        CHECK (operation IN ('mark-applied', 'retry')),",+      "    old_status      text        NOT NULL,",+      "    new_status      text        NOT NULL,",+      "    reason          text        NOT NULL,",+      "    repaired_at     timestamptz NOT NULL DEFAULT clock_timestamp(),",+      "    repaired_by     text        NOT NULL DEFAULT current_user,",+      "    runner_version  text        NOT NULL,",+      "    FOREIGN KEY (component, migration)",+      "        REFERENCES " <> migrationsTable <> " (component, migration)",+      ");"+    ]+  where+    metadataTable = qualifiedLedgerTable config "ledger_metadata"+    migrationsTable = qualifiedLedgerTable config "migrations"+    historyImportsTable = qualifiedLedgerTable config "history_imports"+    repairsTable = qualifiedLedgerTable config "repairs"
+ src/Database/PostgreSQL/Migrate/Ledger/Types.hs view
@@ -0,0 +1,169 @@+module Database.PostgreSQL.Migrate.Ledger.Types+  ( PostgresIdentifier (..),+    LedgerConfig (..),+    defaultLedgerConfig,+    ledgerConfig,+    postgresIdentifier,+    postgresIdentifierText,+    ledgerSchemaText,+    ledgerLockKey,+    MigrationStatus (..),+    UnknownMigrationsPolicy (..),+    StoredMigration (..),+    LedgerMetadata (..),+    LedgerSnapshot (..),+    VerificationIssue (..),+    VerificationReport (..),+    StatusReport (..),+    LedgerError (..),+  )+where++import Data.ByteString qualified as ByteString+import Data.Int (Int32, Int64)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text.Encoding+import Data.Time (UTCTime)+import Database.PostgreSQL.Migrate.Definition+  ( DefinitionError (..),+    PostgresIdentifierError (..),+  )+import Database.PostgreSQL.Migrate.Types+import PgMigrate.Prelude++newtype PostgresIdentifier = PostgresIdentifier+  { unPostgresIdentifier :: Text+  }+  deriving stock (Generic, Eq, Ord, Show)++-- | Validated ledger schema and advisory-lock identity.+data LedgerConfig = LedgerConfig+  { schema :: !PostgresIdentifier,+    lockKey :: !Int64+  }+  deriving stock (Generic, Eq, Show)++-- | Durable state recorded for a migration attempt.+data MigrationStatus+  = Running+  | Applied+  | Failed+  deriving stock (Generic, Eq, Ord, Show)++-- | Whether inspection accepts ledger rows absent from the declared plan.+data UnknownMigrationsPolicy+  = RejectUnknownMigrations+  | AllowUnknownMigrations+  deriving stock (Generic, Eq, Ord, Show)++-- | Immutable view of one migration ledger row.+data StoredMigration = StoredMigration+  { storedMigrationId :: !MigrationId,+    position :: !Int,+    checksum :: !MigrationChecksum,+    kind :: !MigrationKind,+    transactionMode :: !TransactionMode,+    status :: !MigrationStatus,+    startedAt :: !UTCTime,+    finishedAt :: !(Maybe UTCTime),+    executionTimeMilliseconds :: !(Maybe Int64),+    errorMessage :: !(Maybe Text),+    runnerVersion :: !Text+  }+  deriving stock (Generic, Eq, Show)++data LedgerMetadata = LedgerMetadata+  { schemaVersion :: !Int32,+    runnerVersion :: !Text+  }+  deriving stock (Generic, Eq, Show)++data LedgerSnapshot = LedgerSnapshot+  { metadata :: !(Maybe LedgerMetadata),+    storedMigrations :: ![StoredMigration]+  }+  deriving stock (Generic, Eq, Show)++-- | A declared-plan versus ledger inconsistency.+data VerificationIssue+  = DuplicateStoredMigration !MigrationId+  | DuplicateStoredPosition !ComponentName !Int+  | StoredMigrationRunning !MigrationId+  | StoredMigrationFailed !MigrationId+  | MigrationPositionMismatch !MigrationId !Int !Int+  | MigrationChecksumMismatch !MigrationId !MigrationChecksum !MigrationChecksum+  | MigrationKindMismatch !MigrationId !MigrationKind !MigrationKind+  | MigrationTransactionModeMismatch !MigrationId !TransactionMode !TransactionMode+  | AppliedMigrationAfterGap !MigrationId !MigrationId+  | UnknownStoredMigration !MigrationId+  | PendingMigration !MigrationId+  deriving stock (Generic, Eq, Show)++-- | Complete strict verification result.+data VerificationReport = VerificationReport+  { issues :: ![VerificationIssue],+    appliedMigrations :: ![MigrationId],+    pendingMigrations :: ![MigrationId],+    unknownMigrations :: ![StoredMigration]+  }+  deriving stock (Generic, Eq, Show)++-- | Operational status summary for applied, pending, and unknown rows.+data StatusReport = StatusReport+  { issues :: ![VerificationIssue],+    appliedMigrations :: ![MigrationId],+    pendingMigrations :: ![MigrationId],+    unknownMigrations :: ![StoredMigration]+  }+  deriving stock (Generic, Eq, Show)++data LedgerError+  = LedgerTooNew+      { databaseVersion :: !Int32,+        supportedVersion :: !Int32+      }+  | InvalidLedgerVersion !Int32+  deriving stock (Generic, Eq, Show)++-- | Use schema @pgmigrate@ and the project-defined advisory lock key.+defaultLedgerConfig :: LedgerConfig+defaultLedgerConfig =+  LedgerConfig+    { schema = PostgresIdentifier "pgmigrate",+      lockKey = 0x70675F6D69677261+    }++-- | Construct a ledger configuration after validating the schema identifier.+ledgerConfig :: Text -> Int64 -> Either DefinitionError LedgerConfig+ledgerConfig schemaInput lockKey = do+  schema <- postgresIdentifier schemaInput+  pure LedgerConfig {schema, lockKey}++postgresIdentifier :: Text -> Either DefinitionError PostgresIdentifier+postgresIdentifier input+  | Text.null input = invalid EmptyPostgresIdentifier+  | Text.any (== '\NUL') input = invalid PostgresIdentifierContainsNul+  | "pg_" `Text.isPrefixOf` input = invalid PostgresIdentifierHasReservedPrefix+  | byteLength > maximumPostgresIdentifierBytes =+      invalid+        PostgresIdentifierTooLong+          { actualBytes = byteLength,+            maximumBytes = maximumPostgresIdentifierBytes+          }+  | otherwise = Right (PostgresIdentifier input)+  where+    byteLength = ByteString.length (Text.Encoding.encodeUtf8 input)+    invalid postgresIdentifierReason =+      Left InvalidLedgerSchema {input, postgresIdentifierReason}++postgresIdentifierText :: PostgresIdentifier -> Text+postgresIdentifierText (PostgresIdentifier value) = value++ledgerSchemaText :: LedgerConfig -> Text+ledgerSchemaText LedgerConfig {schema} = postgresIdentifierText schema++ledgerLockKey :: LedgerConfig -> Int64+ledgerLockKey LedgerConfig {lockKey} = lockKey++maximumPostgresIdentifierBytes :: Int+maximumPostgresIdentifierBytes = 63
+ src/Database/PostgreSQL/Migrate/Plan.hs view
@@ -0,0 +1,172 @@+module Database.PostgreSQL.Migrate.Plan+  ( PlanError (..),+    MigrationDescription (..),+    ComponentDescription (..),+    PlanDescription (..),+    migrationPlan,+    resolveMigrationPlan,+    planDescription,+  )+where++import Data.List.NonEmpty qualified as NonEmpty+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Database.PostgreSQL.Migrate.Types+import PgMigrate.Prelude++-- | Structural reason a component composition is not a valid plan.+data PlanError+  = DuplicateComponentName !ComponentName+  | DuplicateMigrationName !ComponentName !MigrationName+  | MissingComponentDependency !ComponentName !ComponentName+  | DependencyPlacedAfterConsumer !ComponentName !ComponentName+  | ComponentDependencyCycle !(NonEmpty ComponentName)+  deriving stock (Generic, Eq, Show)++data MigrationDescription = MigrationDescription+  { migrationId :: !MigrationId,+    position :: !Int,+    checksum :: !MigrationChecksum,+    kind :: !MigrationKind,+    transactionMode :: !TransactionMode+  }+  deriving stock (Generic, Eq, Show)++data ComponentDescription = ComponentDescription+  { name :: !ComponentName,+    position :: !Int,+    dependencies :: !(Set ComponentName),+    migrations :: !(NonEmpty MigrationDescription)+  }+  deriving stock (Generic, Eq, Show)++newtype PlanDescription = PlanDescription+  { components :: NonEmpty ComponentDescription+  }+  deriving stock (Generic, Eq, Show)++-- | Validate an already dependency-ordered component sequence.+migrationPlan :: NonEmpty MigrationComponent -> Either PlanError MigrationPlan+migrationPlan components = do+  validateUniqueNames components+  validateDependenciesExist components+  _ <- stableTopologicalOrder components+  validateExplicitOrder components+  pure (MigrationPlan components)++-- | Stably topologically order and validate a component sequence.+resolveMigrationPlan :: NonEmpty MigrationComponent -> Either PlanError MigrationPlan+resolveMigrationPlan components = do+  validateUniqueNames components+  validateDependenciesExist components+  MigrationPlan <$> stableTopologicalOrder components++planDescription :: MigrationPlan -> PlanDescription+planDescription (MigrationPlan components) =+  PlanDescription+    ( NonEmpty.zipWith+        describeComponent+        (1 :| [2 ..])+        components+    )++describeComponent :: Int -> MigrationComponent -> ComponentDescription+describeComponent componentPosition component =+  ComponentDescription+    { name = componentNameOf component,+      position = componentPosition,+      dependencies = componentDependenciesOf component,+      migrations =+        NonEmpty.zipWith+          (describeMigration (componentNameOf component))+          (1 :| [2 ..])+          (componentMigrationsOf component)+    }++describeMigration :: ComponentName -> Int -> Migration -> MigrationDescription+describeMigration component migrationPosition migration =+  MigrationDescription+    { migrationId = MigrationId component (migrationNameOf migration),+      position = migrationPosition,+      checksum = migrationChecksumOf migration,+      kind = migrationKindOf migration,+      transactionMode = migrationModeOf migration+    }++validateUniqueNames :: NonEmpty MigrationComponent -> Either PlanError ()+validateUniqueNames components = do+  case firstDuplicate (componentNameOf <$> toList components) of+    Just duplicate -> Left (DuplicateComponentName duplicate)+    Nothing -> pure ()+  traverse_ validateMigrationNames components++validateMigrationNames :: MigrationComponent -> Either PlanError ()+validateMigrationNames component =+  case firstDuplicate (migrationNameOf <$> toList (componentMigrationsOf component)) of+    Just duplicate -> Left (DuplicateMigrationName (componentNameOf component) duplicate)+    Nothing -> pure ()++validateDependenciesExist :: NonEmpty MigrationComponent -> Either PlanError ()+validateDependenciesExist components =+  traverse_ validateComponent components+  where+    knownNames = Set.fromList (componentNameOf <$> toList components)+    validateComponent component =+      case find (`Set.notMember` knownNames) (Set.toAscList (componentDependenciesOf component)) of+        Just missing -> Left (MissingComponentDependency (componentNameOf component) missing)+        Nothing -> pure ()++validateExplicitOrder :: NonEmpty MigrationComponent -> Either PlanError ()+validateExplicitOrder components =+  traverse_ validateComponent (toList components)+  where+    positions = Map.fromList (zip (componentNameOf <$> toList components) [1 :: Int ..])+    validateComponent component =+      case find (isAfter component) (Set.toAscList (componentDependenciesOf component)) of+        Just dependency -> Left (DependencyPlacedAfterConsumer (componentNameOf component) dependency)+        Nothing -> pure ()+    isAfter component dependency =+      Map.lookup dependency positions > Map.lookup (componentNameOf component) positions++stableTopologicalOrder ::+  NonEmpty MigrationComponent ->+  Either PlanError (NonEmpty MigrationComponent)+stableTopologicalOrder components =+  go Set.empty [] (toList components)+  where+    go _ ordered [] =+      case ordered of+        firstComponent : remainingComponents -> Right (firstComponent :| remainingComponents)+        [] -> error "stableTopologicalOrder: NonEmpty input produced empty output"+    go resolved ordered remaining =+      case removeFirst (dependenciesResolved resolved) remaining of+        Just (next, rest) ->+          go+            (Set.insert (componentNameOf next) resolved)+            (ordered <> [next])+            rest+        Nothing ->+          case componentNameOf <$> remaining of+            firstName : remainingNames -> Left (ComponentDependencyCycle (firstName :| remainingNames))+            [] -> error "stableTopologicalOrder: unresolved set unexpectedly empty"++dependenciesResolved :: Set ComponentName -> MigrationComponent -> Bool+dependenciesResolved resolved component =+  componentDependenciesOf component `Set.isSubsetOf` resolved++removeFirst :: (a -> Bool) -> [a] -> Maybe (a, [a])+removeFirst predicate = go []+  where+    go _ [] = Nothing+    go before (candidate : after)+      | predicate candidate = Just (candidate, reverse before <> after)+      | otherwise = go (candidate : before) after++firstDuplicate :: (Ord a) => [a] -> Maybe a+firstDuplicate = go Set.empty+  where+    go _ [] = Nothing+    go seen (value : rest)+      | value `Set.member` seen = Just value+      | otherwise = go (Set.insert value seen) rest
+ src/Database/PostgreSQL/Migrate/Repair.hs view
@@ -0,0 +1,258 @@+module Database.PostgreSQL.Migrate.Repair+  ( repairMigration,+  )+where++import Data.Int (Int32, Int64)+import Data.Text qualified as Text+import Data.Version (showVersion)+import Database.PostgreSQL.Migrate.Ledger+import Database.PostgreSQL.Migrate.Ledger.Migrations+import Database.PostgreSQL.Migrate.Ledger.Sql+import Database.PostgreSQL.Migrate.Ledger.Types+import Database.PostgreSQL.Migrate.Plan (planDescription)+import Database.PostgreSQL.Migrate.Repair.Types+import Database.PostgreSQL.Migrate.Runner+import Database.PostgreSQL.Migrate.Runner.Types+import Database.PostgreSQL.Migrate.Types+import Hasql.Connection qualified as Connection+import Hasql.Session qualified as Session+import Hasql.Statement qualified as Statement+import Hasql.Transaction qualified as Transaction+import Hasql.Transaction.Sessions qualified as Transaction.Sessions+import Paths_pg_migrate qualified as Package+import PgMigrate.Prelude++-- | Repair one verified nontransactional row under the normal runner lifecycle.+repairMigration ::+  RunOptions ->+  ConnectionProvider ->+  MigrationPlan ->+  RepairRequest ->+  IO (Either RepairError RepairReport)+repairMigration options provider plan request = do+  result <-+    withRunLifecycle options provider $ \connection ->+      Right <$> repairLocked options connection plan request+  pure $ case result of+    Left migrationError -> Left (RepairRunnerError migrationError)+    Right repairResult -> repairResult++repairLocked ::+  RunOptions ->+  Connection.Connection ->+  MigrationPlan ->+  RepairRequest ->+  IO (Either RepairError RepairReport)+repairLocked options connection plan request = do+  initialized <-+    runSession+      connection+      (initializeOrUpgradeLedger (runLedgerConfig options) repairRunnerVersion)+  case initialized of+    Left migrationError -> pure (Left (RepairRunnerError migrationError))+    Right (Left ledgerError) ->+      pure (Left (RepairRunnerError (LedgerInitializationFailed ledgerError)))+    Right (Right ()) -> do+      loaded <- runSession connection (loadLedger (runLedgerConfig options))+      case loaded of+        Left migrationError -> pure (Left (RepairRunnerError migrationError))+        Right snapshot -> repairVerified options connection plan request snapshot++repairVerified ::+  RunOptions ->+  Connection.Connection ->+  MigrationPlan ->+  RepairRequest ->+  LedgerSnapshot ->+  IO (Either RepairError RepairReport)+repairVerified options connection plan request snapshot =+  case find ((== targetId) . storedMigrationId) (storedMigrations snapshot) of+    Nothing -> pure (Left (RepairTargetMissing targetId))+    Just stored ->+      case findPlannedMigration targetId plan of+        Nothing -> pure (Left (RepairTargetNotInPlan targetId))+        Just (position, migration) ->+          case validateRepairTarget targetId position migration stored verification of+            Left repairError -> pure (Left repairError)+            Right oldStatus ->+              case repairOperation request of+                MarkApplied -> markApplied options connection request oldStatus+                Retry -> retry options connection request oldStatus position migration+  where+    targetId = repairMigrationId request+    verification =+      comparePlanWithLedger+        RejectUnknownMigrations+        (planDescription plan)+        (storedMigrations snapshot)++validateRepairTarget ::+  MigrationId ->+  Int32 ->+  Migration ->+  StoredMigration ->+  VerificationReport ->+  Either RepairError MigrationStatus+validateRepairTarget targetId expectedPosition migration stored verification = do+  let StoredMigration+        { position = storedPosition,+          checksum = storedChecksum,+          kind = storedKind,+          transactionMode = storedMode,+          status = storedStatus+        } = stored+  if storedMode /= NonTransactional || migrationModeOf migration /= NonTransactional+    then Left (RepairTargetTransactional targetId)+    else Right ()+  if storedPosition /= fromIntegral expectedPosition+    || storedChecksum /= migrationChecksumOf migration+    || storedKind /= migrationKindOf migration+    || storedMode /= migrationModeOf migration+    then Left (RepairTargetMetadataMismatch targetId)+    else Right ()+  let unrelatedIssues = filter (not . targetStatusIssue targetId) (verificationIssues verification)+  case unrelatedIssues of+    [] -> Right ()+    _ -> Left (RepairBlockedByVerification (withVerificationIssues unrelatedIssues verification))+  case storedStatus of+    Applied -> Left (RepairTargetAlreadyApplied targetId)+    Running -> Right ()+    Failed -> Right ()+  Right storedStatus++markApplied ::+  RunOptions ->+  Connection.Connection ->+  RepairRequest ->+  MigrationStatus ->+  IO (Either RepairError RepairReport)+markApplied options connection request oldStatus = do+  transitioned <-+    runRepairTransaction+      connection+      (runLedgerConfig options)+      (repairLedgerRow request oldStatus Applied)+      prepareMarkAppliedStatement+  pure $ case transitioned of+    Left migrationError -> Left (RepairRunnerError migrationError)+    Right False -> Left (RepairTransitionFailed (repairMigrationId request))+    Right True ->+      Right+        RepairReport+          { repairedMigration = repairMigrationId request,+            operation = MarkApplied,+            oldStatus,+            newStatus = Applied+          }++retry ::+  RunOptions ->+  Connection.Connection ->+  RepairRequest ->+  MigrationStatus ->+  Int32 ->+  Migration ->+  IO (Either RepairError RepairReport)+retry options connection request oldStatus position migration = do+  started <- invokeEvent options (MigrationStarted (repairMigrationId request))+  case started of+    Left migrationError -> pure (Left (RepairRunnerError migrationError))+    Right () -> do+      prepared <-+        runRepairTransaction+          connection+          (runLedgerConfig options)+          (repairLedgerRow request oldStatus Running)+          prepareRetryStatement+      case prepared of+        Left migrationError -> pure (Left (RepairRunnerError migrationError))+        Right False -> pure (Left (RepairTransitionFailed (repairMigrationId request)))+        Right True -> do+          executed <-+            resumeNonTransactionalMigration+              options+              connection+              (repairMigrationId request)+              position+              migration+          pure $ case executed of+            Left migrationError -> Left (RepairRunnerError migrationError)+            Right _ ->+              Right+                RepairReport+                  { repairedMigration = repairMigrationId request,+                    operation = Retry,+                    oldStatus,+                    newStatus = Applied+                  }++runRepairTransaction ::+  Connection.Connection ->+  LedgerConfig ->+  RepairLedgerRow ->+  (LedgerConfig -> Statement.Statement RepairLedgerRow Int64) ->+  IO (Either MigrationError Bool)+runRepairTransaction connection config repairRow transitionStatement = do+  result <-+    Connection.use+      connection+      ( Transaction.Sessions.transactionNoRetry+          Transaction.Sessions.ReadCommitted+          Transaction.Sessions.Write+          $ do+            Transaction.statement repairRow (insertRepairAuditStatement config)+            affected <- Transaction.statement repairRow (transitionStatement config)+            when (affected /= 1) Transaction.condemn+            pure affected+      )+  pure $ first DatabaseSessionFailed ((== 1) <$> result)++repairLedgerRow ::+  RepairRequest ->+  MigrationStatus ->+  MigrationStatus ->+  RepairLedgerRow+repairLedgerRow request oldStatus newStatus =+  RepairLedgerRow+    { repairLedgerMigrationId = repairMigrationId request,+      repairLedgerOperation = case repairOperation request of MarkApplied -> "mark-applied"; Retry -> "retry",+      repairLedgerOldStatus = oldStatus,+      repairLedgerNewStatus = newStatus,+      repairLedgerReason = repairReason request,+      repairLedgerRunnerVersion = repairRunnerVersion+    }++findPlannedMigration :: MigrationId -> MigrationPlan -> Maybe (Int32, Migration)+findPlannedMigration targetId plan =+  find ((== targetId) . plannedId) (concatMap componentMigrations (toList (planComponentsOf plan)))+    >>= \(_, position, migration) -> Just (position, migration)+  where+    componentMigrations component =+      zipWith+        (\position migration -> (MigrationId (componentNameOf component) (migrationNameOf migration), position, migration))+        [1 ..]+        (toList (componentMigrationsOf component))+    plannedId (identifier, _, _) = identifier++targetStatusIssue :: MigrationId -> VerificationIssue -> Bool+targetStatusIssue targetId = \case+  StoredMigrationRunning identifier -> identifier == targetId+  StoredMigrationFailed identifier -> identifier == targetId+  _ -> False++verificationIssues :: VerificationReport -> [VerificationIssue]+verificationIssues VerificationReport {issues} = issues++withVerificationIssues :: [VerificationIssue] -> VerificationReport -> VerificationReport+withVerificationIssues issues VerificationReport {appliedMigrations, pendingMigrations, unknownMigrations} =+  VerificationReport {issues, appliedMigrations, pendingMigrations, unknownMigrations}++runSession ::+  Connection.Connection ->+  Session.Session value ->+  IO (Either MigrationError value)+runSession connection session = first DatabaseSessionFailed <$> Connection.use connection session++repairRunnerVersion :: Text+repairRunnerVersion = Text.pack (showVersion Package.version)
+ src/Database/PostgreSQL/Migrate/Repair/Types.hs view
@@ -0,0 +1,78 @@+module Database.PostgreSQL.Migrate.Repair.Types+  ( RepairOperation (..),+    Confirmation (..),+    RepairDefinitionError (..),+    RepairRequest (..),+    repairRequest,+    RepairError (..),+    RepairReport (..),+  )+where++import Data.Text qualified as Text+import Database.PostgreSQL.Migrate.Ledger.Types+import Database.PostgreSQL.Migrate.Runner.Types+import Database.PostgreSQL.Migrate.Types+import PgMigrate.Prelude++-- | Explicit recovery action for one nontransactional migration.+data RepairOperation+  = MarkApplied+  | Retry+  deriving stock (Generic, Eq, Ord, Show)++-- | Required acknowledgement for destructive operational intent.+data Confirmation+  = NotConfirmed+  | Confirmed+  deriving stock (Generic, Eq, Ord, Show)++-- | Invalid confirmation or audit reason.+data RepairDefinitionError+  = RepairNotConfirmed+  | EmptyRepairReason+  deriving stock (Generic, Eq, Show)++-- | Validated target, operation, and durable audit reason.+data RepairRequest = RepairRequest+  { repairMigrationId :: !MigrationId,+    repairOperation :: !RepairOperation,+    repairReason :: !Text+  }+  deriving stock (Generic, Eq, Show)++-- | Structured reason an attempted repair could not complete.+data RepairError+  = RepairRunnerError !MigrationError+  | RepairTargetMissing !MigrationId+  | RepairTargetNotInPlan !MigrationId+  | RepairTargetAlreadyApplied !MigrationId+  | RepairTargetTransactional !MigrationId+  | RepairTargetMetadataMismatch !MigrationId+  | RepairBlockedByVerification !VerificationReport+  | RepairTransitionFailed !MigrationId+  deriving stock (Generic, Show)++-- | Durable status transition produced by a successful repair.+data RepairReport = RepairReport+  { repairedMigration :: !MigrationId,+    operation :: !RepairOperation,+    oldStatus :: !MigrationStatus,+    newStatus :: !MigrationStatus+  }+  deriving stock (Generic, Eq, Show)++-- | Require explicit confirmation and a non-empty audit reason.+repairRequest ::+  MigrationId ->+  RepairOperation ->+  Text ->+  Confirmation ->+  Either RepairDefinitionError RepairRequest+repairRequest repairMigrationId repairOperation repairReason confirmation = do+  case confirmation of+    NotConfirmed -> Left RepairNotConfirmed+    Confirmed -> Right ()+  if Text.null (Text.strip repairReason)+    then Left EmptyRepairReason+    else Right RepairRequest {repairMigrationId, repairOperation, repairReason}
+ src/Database/PostgreSQL/Migrate/Runner.hs view
@@ -0,0 +1,638 @@+module Database.PostgreSQL.Migrate.Runner+  ( runMigrationPlan,+    runMigrationPlanWith,+    withRunLifecycle,+    resumeNonTransactionalMigration,+    invokeEvent,+  )+where++import Control.Exception+  ( AsyncException,+    SomeException,+    displayException,+    fromException,+    mask,+    throwIO,+    try,+  )+import Data.Int (Int32, Int64)+import Data.List.NonEmpty qualified as NonEmpty+import Data.Map.Strict qualified as Map+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text.Encoding+import Data.Time (NominalDiffTime, UTCTime, getCurrentTime)+import Data.Version (showVersion)+import Data.Word (Word64)+import Database.PostgreSQL.Migrate.Ledger+import Database.PostgreSQL.Migrate.Ledger.Migrations+import Database.PostgreSQL.Migrate.Ledger.Sql+import Database.PostgreSQL.Migrate.Ledger.Types+import Database.PostgreSQL.Migrate.Plan (planDescription)+import Database.PostgreSQL.Migrate.Runner.Connection+import Database.PostgreSQL.Migrate.Runner.Lock+import Database.PostgreSQL.Migrate.Runner.Types+import Database.PostgreSQL.Migrate.Types+import GHC.Clock (getMonotonicTimeNSec)+import Hasql.Connection qualified as Connection+import Hasql.Connection.Settings qualified as Settings+import Hasql.Decoders qualified as Decoders+import Hasql.Encoders qualified as Encoders+import Hasql.Errors qualified as Errors+import Hasql.Session (Session)+import Hasql.Session qualified as Session+import Hasql.Statement qualified as Statement+import Hasql.Transaction (Transaction)+import Hasql.Transaction qualified as Transaction+import Hasql.Transaction.Sessions qualified as Transaction.Sessions+import Paths_pg_migrate qualified as Package+import PgMigrate.Prelude++data PlannedMigration = PlannedMigration+  { plannedId :: !MigrationId,+    plannedPosition :: !Int32,+    plannedMigration :: !Migration+  }++-- | Run a plan with a freshly acquired connection from concrete settings.+runMigrationPlan ::+  RunOptions ->+  Settings.Settings ->+  MigrationPlan ->+  IO (Either MigrationError MigrationReport)+runMigrationPlan options settings =+  runMigrationPlanWith options (connectionProviderFromSettings settings)++-- | Run a plan under the lock and timeout lifecycle using a provider.+runMigrationPlanWith ::+  RunOptions ->+  ConnectionProvider ->+  MigrationPlan ->+  IO (Either MigrationError MigrationReport)+runMigrationPlanWith options ConnectionProvider {useDedicatedConnection} plan =+  withRunLifecycle+    options+    (ConnectionProvider useDedicatedConnection)+    (\connection -> runLocked options connection plan)++withRunLifecycle ::+  RunOptions ->+  ConnectionProvider ->+  (Connection.Connection -> IO (Either MigrationError value)) ->+  IO (Either MigrationError value)+withRunLifecycle options ConnectionProvider {useDedicatedConnection} action =+  case validateOptions options of+    Left optionsError -> pure (Left optionsError)+    Right () -> do+      acquired <- useDedicatedConnection (\connection -> runOnConnection options connection action)+      pure $ case acquired of+        Left connectionError -> Left (ConnectionAcquisitionFailed connectionError)+        Right result -> result++runOnConnection ::+  RunOptions ->+  Connection.Connection ->+  (Connection.Connection -> IO (Either MigrationError value)) ->+  IO (Either MigrationError value)+runOnConnection options connection action = do+  serverVersion <- checkServerVersion connection+  case serverVersion of+    Left migrationError -> pure (Left migrationError)+    Right _ ->+      withStatementTimeoutResource options connection $ do+        waitEvent <- invokeEvent options (LockWaitStarted (runLockWait options))+        case waitEvent of+          Left eventError -> pure (Left eventError)+          Right () ->+            withAdvisoryLockResource options connection $ \lockDuration -> do+              acquiredEvent <- invokeEvent options (LockAcquired lockDuration)+              case acquiredEvent of+                Left eventError -> pure (Left eventError)+                Right () -> action connection++withStatementTimeoutResource ::+  RunOptions ->+  Connection.Connection ->+  IO (Either MigrationError value) ->+  IO (Either MigrationError value)+withStatementTimeoutResource options connection action =+  mask $ \restore -> do+    applied <- applyStatementTimeout connection (runStatementTimeout options)+    case applied of+      Left migrationError -> pure (Left migrationError)+      Right previous -> do+        captured <- try @SomeException (restore action)+        cleanup <- restoreStatementTimeout connection previous+        finishResource captured [cleanup]++withAdvisoryLockResource ::+  RunOptions ->+  Connection.Connection ->+  (NominalDiffTime -> IO (Either MigrationError value)) ->+  IO (Either MigrationError value)+withAdvisoryLockResource options connection action =+  mask $ \restore -> do+    acquired <-+      restore+        ( acquireAdvisoryLock+            connection+            (ledgerLockKey (runLedgerConfig options))+            (runLockWait options)+        )+    case acquired of+      Left migrationError -> pure (Left migrationError)+      Right lockDuration -> do+        captured <- try @SomeException (restore (action lockDuration))+        cleanup <-+          releaseAdvisoryLock connection (ledgerLockKey (runLedgerConfig options))+        finishResource captured [cleanup]++finishResource ::+  Either SomeException (Either MigrationError value) ->+  [Either CleanupIssue ()] ->+  IO (Either MigrationError value)+finishResource captured cleanupResults = do+  let (cleanupIssues, _) = partitionEithers cleanupResults+  case captured of+    Left exception+      | isAsyncException exception -> throwIO exception+      | otherwise -> pure (attachCleanup cleanupIssues (Left (MigrationActionFailed exception)))+    Right result -> pure (attachCleanup cleanupIssues result)++attachCleanup ::+  [CleanupIssue] ->+  Either MigrationError value ->+  Either MigrationError value+attachCleanup cleanupIssues result =+  case NonEmpty.nonEmpty cleanupIssues of+    Nothing -> result+    Just issues ->+      Left+        ( CleanupFailed+            (case result of Left primary -> Just primary; Right _ -> Nothing)+            issues+        )++runLocked ::+  RunOptions ->+  Connection.Connection ->+  MigrationPlan ->+  IO (Either MigrationError MigrationReport)+runLocked options connection plan = do+  initialized <-+    runSession+      connection+      (initializeOrUpgradeLedger (runLedgerConfig options) libraryRunnerVersion)+  case initialized of+    Left migrationError -> pure (Left migrationError)+    Right (Left ledgerError) -> pure (Left (LedgerInitializationFailed ledgerError))+    Right (Right ()) -> do+      loaded <- runSession connection (loadLedger (runLedgerConfig options))+      case loaded of+        Left migrationError -> pure (Left migrationError)+        Right snapshot -> runVerified options connection plan snapshot++runVerified ::+  RunOptions ->+  Connection.Connection ->+  MigrationPlan ->+  LedgerSnapshot ->+  IO (Either MigrationError MigrationReport)+runVerified options connection plan snapshot = do+  let verification =+        comparePlanWithLedger+          (runUnknownMigrationsPolicy options)+          (planDescription plan)+          (storedMigrations snapshot)+  case verification of+    VerificationReport {issues = _ : _} ->+      pure (Left (PlanVerificationFailed verification))+    VerificationReport {appliedMigrations, pendingMigrations} -> do+      let planned = flattenPlan plan+          plannedById = Map.fromList ((\migration -> (plannedId migration, migration)) <$> planned)+          pending = mapMaybe (`Map.lookup` plannedById) pendingMigrations+      validatedEvent <-+        invokeEvent+          options+          PlanValidated+            { alreadyAppliedCount = length appliedMigrations,+              pendingCount = length pending+            }+      case validatedEvent of+        Left eventError -> pure (Left eventError)+        Right () -> executeVerified options connection planned appliedMigrations pending++executeVerified ::+  RunOptions ->+  Connection.Connection ->+  [PlannedMigration] ->+  [MigrationId] ->+  [PlannedMigration] ->+  IO (Either MigrationError MigrationReport)+executeVerified options connection planned appliedIds pending = do+  reportStartedAt <- getCurrentTime+  reportStartedMonotonic <- getMonotonicTimeNSec+  executed <- executePending Map.empty pending+  case executed of+    Left migrationError -> pure (Left migrationError)+    Right executedById -> do+      reportFinishedAt <- getCurrentTime+      reportDuration <- elapsedSince reportStartedMonotonic+      completedEvent <- invokeEvent options (MigrationPlanCompleted reportDuration)+      case completedEvent of+        Left eventError -> pure (Left eventError)+        Right () ->+          case NonEmpty.nonEmpty (resultsInPlanOrder executedById) of+            Nothing -> error "migration plan unexpectedly produced no results"+            Just results ->+              pure+                ( Right+                    MigrationReport+                      { startedAt = reportStartedAt,+                        finishedAt = reportFinishedAt,+                        results+                      }+                )+  where+    alreadyApplied =+      Map.fromList+        [ (identifier, MigrationResult identifier AlreadyApplied Nothing)+        | identifier <- appliedIds+        ]+    resultsInPlanOrder executedById =+      mapMaybe+        (\migration -> Map.lookup (plannedId migration) (Map.union executedById alreadyApplied))+        planned+    executePending accumulated [] = pure (Right accumulated)+    executePending accumulated (migration : rest) = do+      executed <- executePlannedMigration options connection migration+      case executed of+        Left migrationError -> pure (Left migrationError)+        Right result ->+          executePending (Map.insert (plannedId migration) result accumulated) rest++executePlannedMigration ::+  RunOptions ->+  Connection.Connection ->+  PlannedMigration ->+  IO (Either MigrationError MigrationResult)+executePlannedMigration options connection planned =+  case migrationModeOf (plannedMigration planned) of+    Transactional -> executeTransactional options connection planned+    NonTransactional -> executeNonTransactional options connection planned++executeTransactional ::+  RunOptions ->+  Connection.Connection ->+  PlannedMigration ->+  IO (Either MigrationError MigrationResult)+executeTransactional options connection planned = do+  startedEvent <- invokeEvent options (MigrationStarted identifier)+  case startedEvent of+    Left eventError -> pure (Left eventError)+    Right () -> do+      startedAt <- getCurrentTime+      startedMonotonic <- getMonotonicTimeNSec+      case transactionalAction (runLedgerConfig options) planned startedAt of+        Left migrationError -> finishFailure startedMonotonic migrationError+        Right transaction -> do+          attempted <- try @SomeException (Connection.use connection (runTransaction transaction))+          case attempted of+            Left exception+              | isAsyncException exception -> throwIO exception+              | otherwise -> finishFailure startedMonotonic (MigrationActionFailed exception)+            Right (Left sessionError) ->+              finishFailure startedMonotonic (DatabaseSessionFailed sessionError)+            Right (Right ()) -> do+              loaded <- runSession connection (loadLedger (runLedgerConfig options))+              case loaded of+                Left migrationError -> finishFailure startedMonotonic migrationError+                Right snapshot+                  | any ((== identifier) . storedMigrationId) (storedMigrations snapshot) ->+                      finishSuccess startedMonotonic+                  | otherwise -> finishFailure startedMonotonic (TransactionCondemned identifier)+  where+    identifier = plannedId planned+    finishSuccess started = do+      duration <- elapsedSince started+      completed <- invokeEvent options (MigrationCompleted identifier duration)+      pure $ case completed of+        Left eventError -> Left eventError+        Right () -> Right (MigrationResult identifier AppliedNow (Just duration))+    finishFailure started primary = do+      duration <- elapsedSince started+      observed <-+        invokeEventWithPrimary+          options+          primary+          (MigrationFailureObserved identifier duration)+      pure $ case observed of+        Left eventError -> Left eventError+        Right () -> Left primary++transactionalAction ::+  LedgerConfig ->+  PlannedMigration ->+  UTCTime ->+  Either MigrationError (Transaction ())+transactionalAction config PlannedMigration {plannedId, plannedPosition, plannedMigration} startedAt = do+  action <- case migrationActionOf plannedMigration of+    SqlAction bytes -> Right (Transaction.sql bytes)+    TransactionAction transaction -> Right transaction+    SessionAction _ -> Left (InvalidMigrationAction plannedId)+  pure $ do+    action+    Transaction.statement+      AppliedLedgerRow+        { appliedMigrationId = plannedId,+          appliedPosition = plannedPosition,+          appliedChecksum = migrationChecksumOf plannedMigration,+          appliedKind = migrationKindOf plannedMigration,+          appliedTransactionMode = migrationModeOf plannedMigration,+          appliedStartedAt = startedAt,+          appliedRunnerVersion = libraryRunnerVersion+        }+      (insertAppliedMigrationStatement config)++executeNonTransactional ::+  RunOptions ->+  Connection.Connection ->+  PlannedMigration ->+  IO (Either MigrationError MigrationResult)+executeNonTransactional options connection planned = do+  startedEvent <- invokeEvent options (MigrationStarted identifier)+  case startedEvent of+    Left eventError -> pure (Left eventError)+    Right () -> do+      startedAt <- getCurrentTime+      startedMonotonic <- getMonotonicTimeNSec+      let ledgerRow = appliedLedgerRow planned startedAt+      inserted <-+        runSession+          connection+          ( runTransaction+              ( Transaction.statement+                  ledgerRow+                  (insertRunningMigrationStatement (runLedgerConfig options))+              )+          )+      case inserted of+        Left migrationError -> finishFailureEvent startedMonotonic migrationError+        Right () ->+          executeNonTransactionalAfterRunning+            options+            connection+            planned+            ledgerRow+            startedMonotonic+  where+    identifier = plannedId planned+    finishFailureEvent started primary = do+      duration <- elapsedSince started+      observed <-+        invokeEventWithPrimary+          options+          primary+          (MigrationFailureObserved identifier duration)+      pure $ case observed of+        Left eventError -> Left eventError+        Right () -> Left primary++resumeNonTransactionalMigration ::+  RunOptions ->+  Connection.Connection ->+  MigrationId ->+  Int32 ->+  Migration ->+  IO (Either MigrationError MigrationResult)+resumeNonTransactionalMigration options connection identifier position migration = do+  startedAt <- getCurrentTime+  startedMonotonic <- getMonotonicTimeNSec+  let planned = PlannedMigration identifier position migration+      ledgerRow = appliedLedgerRow planned startedAt+  executeNonTransactionalAfterRunning options connection planned ledgerRow startedMonotonic++executeNonTransactionalAfterRunning ::+  RunOptions ->+  Connection.Connection ->+  PlannedMigration ->+  AppliedLedgerRow ->+  Word64 ->+  IO (Either MigrationError MigrationResult)+executeNonTransactionalAfterRunning options connection planned ledgerRow startedMonotonic = do+  action <- nonTransactionalAction connection planned+  case action of+    Left migrationError ->+      recordObservedFailure migrationError (renderMigrationError migrationError)+    Right runAction -> do+      attempted <- try @SomeException runAction+      case attempted of+        Left exception+          | isAsyncException exception -> throwIO exception+          | otherwise ->+              let primary = MigrationActionFailed exception+               in recordObservedFailure+                    primary+                    (Text.pack (displayException exception))+        Right (Left sessionError) ->+          let primary = NonTransactionalMigrationFailed identifier sessionError+           in recordObservedFailure primary (Errors.toDetailedText sessionError)+        Right (Right ()) -> do+          transitioned <- markRunningApplied options connection ledgerRow+          case transitioned of+            Left migrationError -> pure (Left migrationError)+            Right () -> finishSuccess+  where+    identifier = plannedId planned+    finishSuccess = do+      duration <- elapsedSince startedMonotonic+      completed <- invokeEvent options (MigrationCompleted identifier duration)+      pure $ case completed of+        Left eventError -> Left eventError+        Right () -> Right (MigrationResult identifier AppliedNow (Just duration))+    finishFailureEvent primary = do+      duration <- elapsedSince startedMonotonic+      observed <-+        invokeEventWithPrimary+          options+          primary+          (MigrationFailureObserved identifier duration)+      pure $ case observed of+        Left eventError -> Left eventError+        Right () -> Left primary+    recordObservedFailure primary diagnostic = do+      recorded <- markRunningFailed options connection ledgerRow diagnostic+      case recorded of+        Left recordingError ->+          pure+            ( Left+                (NonTransactionalFailureRecordingFailed identifier primary recordingError)+            )+        Right () -> finishFailureEvent primary++nonTransactionalAction ::+  Connection.Connection ->+  PlannedMigration ->+  IO+    ( Either+        MigrationError+        (IO (Either Errors.SessionError ()))+    )+nonTransactionalAction connection PlannedMigration {plannedId, plannedMigration} =+  pure $ case migrationActionOf plannedMigration of+    SqlAction bytes ->+      Right+        ( Connection.use+            connection+            ( Session.statement+                ()+                ( Statement.unpreparable+                    (Text.Encoding.decodeUtf8 bytes)+                    Encoders.noParams+                    Decoders.noResult+                )+            )+        )+    SessionAction session -> Right (Connection.use connection session)+    TransactionAction _ -> Left (InvalidMigrationAction plannedId)++markRunningApplied ::+  RunOptions ->+  Connection.Connection ->+  AppliedLedgerRow ->+  IO (Either MigrationError ())+markRunningApplied options connection ledgerRow = do+  transitioned <-+    runSession+      connection+      ( runTransaction+          ( Transaction.statement+              ledgerRow+              (markRunningMigrationAppliedStatement (runLedgerConfig options))+          )+      )+  pure $ transitioned >>= expectOneTransition ledgerRow Applied++markRunningFailed ::+  RunOptions ->+  Connection.Connection ->+  AppliedLedgerRow ->+  Text ->+  IO (Either MigrationError ())+markRunningFailed options connection ledgerRow diagnostic = do+  transitioned <-+    runSession+      connection+      ( runTransaction+          ( Transaction.statement+              FailedLedgerRow+                { failedLedgerIdentity = ledgerRow,+                  failedLedgerError = diagnostic+                }+              (markRunningMigrationFailedStatement (runLedgerConfig options))+          )+      )+  pure $ transitioned >>= expectOneTransition ledgerRow Failed++expectOneTransition ::+  AppliedLedgerRow ->+  MigrationStatus ->+  Int64 ->+  Either MigrationError ()+expectOneTransition ledgerRow targetStatus affected+  | affected == 1 = Right ()+  | otherwise =+      Left+        ( LedgerTransitionDidNotMatch+            (appliedMigrationId ledgerRow)+            Running+            targetStatus+        )++appliedLedgerRow :: PlannedMigration -> UTCTime -> AppliedLedgerRow+appliedLedgerRow PlannedMigration {plannedId, plannedPosition, plannedMigration} startedAt =+  AppliedLedgerRow+    { appliedMigrationId = plannedId,+      appliedPosition = plannedPosition,+      appliedChecksum = migrationChecksumOf plannedMigration,+      appliedKind = migrationKindOf plannedMigration,+      appliedTransactionMode = migrationModeOf plannedMigration,+      appliedStartedAt = startedAt,+      appliedRunnerVersion = libraryRunnerVersion+    }++renderMigrationError :: MigrationError -> Text+renderMigrationError = Text.pack . show++runTransaction :: Transaction value -> Session value+runTransaction =+  Transaction.Sessions.transactionNoRetry+    Transaction.Sessions.ReadCommitted+    Transaction.Sessions.Write++flattenPlan :: MigrationPlan -> [PlannedMigration]+flattenPlan plan =+  concatMap flattenComponent (toList (planComponentsOf plan))+  where+    flattenComponent component =+      zipWith+        ( \position migration ->+            PlannedMigration+              (MigrationId (componentNameOf component) (migrationNameOf migration))+              position+              migration+        )+        [1 ..]+        (toList (componentMigrationsOf component))++runSession ::+  Connection.Connection ->+  Session value ->+  IO (Either MigrationError value)+runSession connection session = do+  result <- Connection.use connection session+  pure (first DatabaseSessionFailed result)++invokeEvent :: RunOptions -> MigrationEvent -> IO (Either MigrationError ())+invokeEvent options = invokeEventWithMaybePrimary options Nothing++invokeEventWithPrimary ::+  RunOptions ->+  MigrationError ->+  MigrationEvent ->+  IO (Either MigrationError ())+invokeEventWithPrimary options primary =+  invokeEventWithMaybePrimary options (Just primary)++invokeEventWithMaybePrimary ::+  RunOptions ->+  Maybe MigrationError ->+  MigrationEvent ->+  IO (Either MigrationError ())+invokeEventWithMaybePrimary options primary event = do+  attempted <- try @SomeException (runEventHandler options event)+  case attempted of+    Left exception+      | isAsyncException exception -> throwIO exception+      | otherwise -> pure (Left (EventHandlerFailed primary exception))+    Right () -> pure (Right ())++validateOptions :: RunOptions -> Either MigrationError ()+validateOptions options = do+  case runLockWait options of+    WaitFor timeout | timeout < 0 -> Left (InvalidLockWait timeout)+    _ -> Right ()+  case runStatementTimeout options of+    Just timeout | timeout < 0 -> Left (InvalidStatementTimeout timeout)+    _ -> Right ()++elapsedSince :: Word64 -> IO NominalDiffTime+elapsedSince started = do+  finished <- getMonotonicTimeNSec+  pure (realToFrac (fromIntegral (finished - started) / (1000000000 :: Double)))++isAsyncException :: SomeException -> Bool+isAsyncException exception = isJust (fromException exception :: Maybe AsyncException)++libraryRunnerVersion :: Text+libraryRunnerVersion = Text.pack (showVersion Package.version)
+ src/Database/PostgreSQL/Migrate/Runner/Connection.hs view
@@ -0,0 +1,49 @@+module Database.PostgreSQL.Migrate.Runner.Connection+  ( connectionProviderFromSettings,+    checkServerVersion,+    classifyServerVersion,+  )+where++import Control.Exception (finally, mask)+import Data.Int (Int32)+import Database.PostgreSQL.Migrate.Runner.Types+import Hasql.Connection qualified as Connection+import Hasql.Connection.Settings qualified as Settings+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++-- | Acquire and release a fresh Hasql connection from concrete settings.+connectionProviderFromSettings :: Settings.Settings -> ConnectionProvider+connectionProviderFromSettings settings =+  ConnectionProvider $ \action ->+    mask $ \restore -> do+      acquired <- Connection.acquire settings+      case acquired of+        Left connectionError -> pure (Left connectionError)+        Right connection ->+          Right <$> restore (action connection) `finally` Connection.release connection++checkServerVersion :: Connection.Connection -> IO (Either MigrationError Int)+checkServerVersion connection = do+  result <- Connection.use connection (Session.statement () serverVersionStatement)+  pure $ case result of+    Left sessionError -> Left (DatabaseSessionFailed sessionError)+    Right serverVersion -> classifyServerVersion serverVersion++classifyServerVersion :: Int32 -> Either MigrationError Int+classifyServerVersion serverVersionNumber+  | majorVersion `elem` [17, 18] = Right majorVersion+  | otherwise = Left (UnsupportedPostgresVersion majorVersion)+  where+    majorVersion = fromIntegral serverVersionNumber `div` 10000++serverVersionStatement :: Statement () Int32+serverVersionStatement =+  Statement.preparable+    "SELECT current_setting('server_version_num')::integer"+    Encoders.noParams+    (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.int4)))
+ src/Database/PostgreSQL/Migrate/Runner/Lock.hs view
@@ -0,0 +1,159 @@+module Database.PostgreSQL.Migrate.Runner.Lock+  ( acquireAdvisoryLock,+    releaseAdvisoryLock,+    applyStatementTimeout,+    restoreStatementTimeout,+    readStatementTimeout,+  )+where++import Control.Concurrent (threadDelay)+import Data.Int (Int64)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Time (NominalDiffTime)+import Data.Word (Word64)+import Database.PostgreSQL.Migrate.Runner.Types+import GHC.Clock (getMonotonicTimeNSec)+import Hasql.Connection qualified as Connection+import Hasql.Decoders qualified as Decoders+import Hasql.Encoders qualified as Encoders+import Hasql.Errors qualified as Errors+import Hasql.Session qualified as Session+import Hasql.Statement (Statement)+import Hasql.Statement qualified as Statement++acquireAdvisoryLock ::+  Connection.Connection ->+  Int64 ->+  LockWait ->+  IO (Either MigrationError NominalDiffTime)+acquireAdvisoryLock connection lockKey lockWait = do+  started <- getMonotonicTimeNSec+  case lockWait of+    WaitIndefinitely -> pollIndefinitely started+    NoWait -> do+      result <- tryLock connection lockKey+      case result of+        Left sessionError -> pure (Left (DatabaseSessionFailed sessionError))+        Right False -> pure (Left AdvisoryLockUnavailable)+        Right True -> Right <$> elapsedSince started+    WaitFor timeout+      | timeout < 0 -> pure (Left (InvalidLockWait timeout))+      | otherwise -> pollUntil started timeout+  where+    pollIndefinitely started = do+      result <- tryLock connection lockKey+      case result of+        Left sessionError -> pure (Left (DatabaseSessionFailed sessionError))+        Right True -> Right <$> elapsedSince started+        Right False -> do+          threadDelay 50000+          pollIndefinitely started+    pollUntil started timeout = do+      result <- tryLock connection lockKey+      case result of+        Left sessionError -> pure (Left (DatabaseSessionFailed sessionError))+        Right True -> Right <$> elapsedSince started+        Right False -> do+          elapsed <- elapsedSince started+          if elapsed >= timeout+            then pure (Left (AdvisoryLockTimedOut timeout))+            else do+              threadDelay (pollDelayMicroseconds timeout elapsed)+              pollUntil started timeout++releaseAdvisoryLock ::+  Connection.Connection ->+  Int64 ->+  IO (Either CleanupIssue ())+releaseAdvisoryLock connection lockKey = do+  result <- Connection.use connection (Session.statement lockKey unlockStatement)+  pure $ case result of+    Left sessionError -> Left (AdvisoryUnlockFailed sessionError)+    Right False -> Left AdvisoryUnlockReturnedFalse+    Right True -> Right ()++applyStatementTimeout ::+  Connection.Connection ->+  Maybe NominalDiffTime ->+  IO (Either MigrationError (Maybe Text))+applyStatementTimeout _ Nothing = pure (Right Nothing)+applyStatementTimeout connection (Just timeout)+  | timeout < 0 = pure (Left (InvalidStatementTimeout timeout))+  | otherwise = do+      result <-+        Connection.use connection $ do+          previous <- Session.statement () currentStatementTimeoutStatement+          _ <- Session.statement (formatStatementTimeout timeout) setStatementTimeoutStatement+          pure previous+      pure $ case result of+        Left sessionError -> Left (DatabaseSessionFailed sessionError)+        Right previous -> Right (Just previous)++restoreStatementTimeout ::+  Connection.Connection ->+  Maybe Text ->+  IO (Either CleanupIssue ())+restoreStatementTimeout _ Nothing = pure (Right ())+restoreStatementTimeout connection (Just previous) = do+  result <- Connection.use connection (Session.statement previous setStatementTimeoutStatement)+  pure $ case result of+    Left sessionError -> Left (StatementTimeoutRestoreFailed sessionError)+    Right _ -> Right ()++readStatementTimeout :: Connection.Connection -> IO (Either MigrationError Text)+readStatementTimeout connection = do+  result <- Connection.use connection (Session.statement () currentStatementTimeoutStatement)+  pure $ case result of+    Left sessionError -> Left (DatabaseSessionFailed sessionError)+    Right value -> Right value++tryLock :: Connection.Connection -> Int64 -> IO (Either Errors.SessionError Bool)+tryLock connection lockKey =+  Connection.use connection (Session.statement lockKey tryLockStatement)++elapsedSince :: Word64 -> IO NominalDiffTime+elapsedSince started = do+  finished <- getMonotonicTimeNSec+  pure (realToFrac (fromIntegral (finished - started) / (1000000000 :: Double)))++pollDelayMicroseconds :: NominalDiffTime -> NominalDiffTime -> Int+pollDelayMicroseconds timeout elapsed =+  max 1 (min 50000 (floor (realToFrac (timeout - elapsed) * (1000000 :: Double))))++formatStatementTimeout :: NominalDiffTime -> Text+formatStatementTimeout timeout =+  Text.pack (show milliseconds) <> "ms"+  where+    milliseconds+      | timeout == 0 = 0 :: Integer+      | otherwise = ceiling (realToFrac timeout * (1000 :: Double))++tryLockStatement :: Statement Int64 Bool+tryLockStatement =+  Statement.preparable+    "SELECT pg_try_advisory_lock($1)"+    (Encoders.param (Encoders.nonNullable Encoders.int8))+    (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.bool)))++unlockStatement :: Statement Int64 Bool+unlockStatement =+  Statement.preparable+    "SELECT pg_advisory_unlock($1)"+    (Encoders.param (Encoders.nonNullable Encoders.int8))+    (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.bool)))++currentStatementTimeoutStatement :: Statement () Text+currentStatementTimeoutStatement =+  Statement.preparable+    "SELECT current_setting('statement_timeout')"+    Encoders.noParams+    (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.text)))++setStatementTimeoutStatement :: Statement Text Text+setStatementTimeoutStatement =+  Statement.preparable+    "SELECT set_config('statement_timeout', $1, false)"+    (Encoders.param (Encoders.nonNullable Encoders.text))+    (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.text)))
+ src/Database/PostgreSQL/Migrate/Runner/Types.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE RankNTypes #-}++module Database.PostgreSQL.Migrate.Runner.Types+  ( RunOptions (..),+    defaultRunOptions,+    withLedger,+    withLockWait,+    withStatementTimeout,+    withUnknownMigrationsPolicy,+    withEventHandler,+    runLedgerConfig,+    runLockWait,+    runStatementTimeout,+    runUnknownMigrationsPolicy,+    runEventHandler,+    LockWait (..),+    MigrationEvent (..),+    MigrationOutcome (..),+    MigrationResult (..),+    MigrationReport (..),+    CleanupIssue (..),+    MigrationError (..),+    ConnectionProvider (..),+    connectionProvider,+  )+where++import Control.Exception (SomeException)+import Data.Time (NominalDiffTime, UTCTime)+import Database.PostgreSQL.Migrate.Ledger.Types+import Database.PostgreSQL.Migrate.Types+import Hasql.Connection qualified as Connection+import Hasql.Errors qualified as Errors+import PgMigrate.Prelude++-- | Immutable runner configuration; construct with 'defaultRunOptions' and modifiers.+data RunOptions = RunOptions+  { ledger :: !LedgerConfig,+    lockWait :: !LockWait,+    statementTimeout :: !(Maybe NominalDiffTime),+    unknownMigrations :: !UnknownMigrationsPolicy,+    emit :: !(MigrationEvent -> IO ())+  }++-- | Advisory-lock acquisition policy.+data LockWait+  = WaitIndefinitely+  | WaitFor !NominalDiffTime+  | NoWait+  deriving stock (Generic, Eq, Ord, Show)++-- | Ordered lifecycle observation emitted only at defined durable boundaries.+data MigrationEvent+  = LockWaitStarted !LockWait+  | LockAcquired !NominalDiffTime+  | PlanValidated+      { alreadyAppliedCount :: !Int,+        pendingCount :: !Int+      }+  | MigrationStarted !MigrationId+  | MigrationCompleted !MigrationId !NominalDiffTime+  | MigrationFailureObserved !MigrationId !NominalDiffTime+  | MigrationPlanCompleted !NominalDiffTime+  deriving stock (Generic, Eq, Show)++-- | Whether a migration pre-existed or committed during this run.+data MigrationOutcome+  = AlreadyApplied+  | AppliedNow+  deriving stock (Generic, Eq, Ord, Show)++-- | Outcome and optional execution duration for one migration.+data MigrationResult = MigrationResult+  { migration :: !MigrationId,+    outcome :: !MigrationOutcome,+    duration :: !(Maybe NominalDiffTime)+  }+  deriving stock (Generic, Eq, Show)++-- | Successful whole-plan execution report.+data MigrationReport = MigrationReport+  { startedAt :: !UTCTime,+    finishedAt :: !UTCTime,+    results :: !(NonEmpty MigrationResult)+  }+  deriving stock (Generic, Eq, Show)++-- | Resource restoration failure observed while leaving the runner lifecycle.+data CleanupIssue+  = AdvisoryUnlockReturnedFalse+  | AdvisoryUnlockFailed !Errors.SessionError+  | StatementTimeoutRestoreFailed !Errors.SessionError+  deriving stock (Generic, Show)++-- | Structured acquisition, validation, execution, event, or cleanup failure.+data MigrationError+  = ConnectionAcquisitionFailed !Errors.ConnectionError+  | DatabaseSessionFailed !Errors.SessionError+  | UnsupportedPostgresVersion !Int+  | InvalidLockWait !NominalDiffTime+  | InvalidStatementTimeout !NominalDiffTime+  | AdvisoryLockUnavailable+  | AdvisoryLockTimedOut !NominalDiffTime+  | LedgerInitializationFailed !LedgerError+  | PlanVerificationFailed !VerificationReport+  | UnsupportedNonTransactionalMigration !MigrationId+  | TransactionCondemned !MigrationId+  | EventHandlerFailed !(Maybe MigrationError) !SomeException+  | MigrationActionFailed !SomeException+  | InvalidMigrationAction !MigrationId+  | NonTransactionalMigrationFailed !MigrationId !Errors.SessionError+  | LedgerTransitionDidNotMatch !MigrationId !MigrationStatus !MigrationStatus+  | NonTransactionalFailureRecordingFailed !MigrationId !MigrationError !MigrationError+  | CleanupFailed !(Maybe MigrationError) !(NonEmpty CleanupIssue)+  deriving stock (Generic, Show)++-- | Rank-2 provider that brackets one dedicated PostgreSQL connection per operation.+newtype ConnectionProvider = ConnectionProvider+  { useDedicatedConnection ::+      forall a.+      (Connection.Connection -> IO a) ->+      IO (Either Errors.ConnectionError a)+  }++-- | Strict defaults with the standard ledger, indefinite lock wait, and no events.+defaultRunOptions :: RunOptions+defaultRunOptions =+  RunOptions+    { ledger = defaultLedgerConfig,+      lockWait = WaitIndefinitely,+      statementTimeout = Nothing,+      unknownMigrations = RejectUnknownMigrations,+      emit = const (pure ())+    }++-- | Select a validated ledger configuration.+withLedger :: LedgerConfig -> RunOptions -> RunOptions+withLedger ledger options = options {ledger}++-- | Select the advisory-lock wait policy.+withLockWait :: LockWait -> RunOptions -> RunOptions+withLockWait lockWait options = options {lockWait}++-- | Set or disable the temporary PostgreSQL statement timeout.+withStatementTimeout :: Maybe NominalDiffTime -> RunOptions -> RunOptions+withStatementTimeout statementTimeout options = options {statementTimeout}++-- | Select how inspection treats unknown stored migrations.+withUnknownMigrationsPolicy :: UnknownMigrationsPolicy -> RunOptions -> RunOptions+withUnknownMigrationsPolicy unknownMigrations RunOptions {ledger, lockWait, statementTimeout, emit} =+  RunOptions {ledger, lockWait, statementTimeout, unknownMigrations, emit}++-- | Install an observational lifecycle callback.+withEventHandler :: (MigrationEvent -> IO ()) -> RunOptions -> RunOptions+withEventHandler emit options = options {emit}++runLedgerConfig :: RunOptions -> LedgerConfig+runLedgerConfig RunOptions {ledger} = ledger++runLockWait :: RunOptions -> LockWait+runLockWait RunOptions {lockWait} = lockWait++runStatementTimeout :: RunOptions -> Maybe NominalDiffTime+runStatementTimeout RunOptions {statementTimeout} = statementTimeout++runUnknownMigrationsPolicy :: RunOptions -> UnknownMigrationsPolicy+runUnknownMigrationsPolicy RunOptions {unknownMigrations} = unknownMigrations++runEventHandler :: RunOptions -> MigrationEvent -> IO ()+runEventHandler RunOptions {emit} = emit++-- | Construct a provider from an application-owned connection bracket.+connectionProvider ::+  ( forall a.+    (Connection.Connection -> IO a) ->+    IO (Either Errors.ConnectionError a)+  ) ->+  ConnectionProvider+connectionProvider = ConnectionProvider
+ src/Database/PostgreSQL/Migrate/Sql.hs view
@@ -0,0 +1,77 @@+module Database.PostgreSQL.Migrate.Sql+  ( SqlError (..),+    SqlScan,+    validateSql,+    sqlScanTransactionMode,+    sqlScanStatementCount,+  )+where++import Data.ByteString qualified as ByteString+import Data.Text.Encoding qualified as Text.Encoding+import Data.Word (Word8)+import Database.PostgreSQL.Migrate.Sql.Scanner+  ( SqlError (..),+    SqlScan,+    scanSql,+    sqlScanStatementCount,+    sqlScanTransactionMode,+  )+import PgMigrate.Prelude++validateSql :: ByteString -> Either SqlError SqlScan+validateSql bytes = do+  validateUtf8 bytes+  scanSql (Text.Encoding.decodeUtf8 bytes)++validateUtf8 :: ByteString -> Either SqlError ()+validateUtf8 = go 0 . ByteString.unpack+  where+    go :: Int -> [Word8] -> Either SqlError ()+    go _ [] = Right ()+    go offset (byte : rest)+      | byte <= 0x7F = go (offset + 1) rest+      | byte >= 0xC2 && byte <= 0xDF =+          consumeContinuation offset 1 rest+      | byte == 0xE0 =+          consumeRestricted offset 0xA0 0xBF 1 rest+      | byte >= 0xE1 && byte <= 0xEC =+          consumeContinuation offset 2 rest+      | byte == 0xED =+          consumeRestricted offset 0x80 0x9F 1 rest+      | byte >= 0xEE && byte <= 0xEF =+          consumeContinuation offset 2 rest+      | byte == 0xF0 =+          consumeRestricted offset 0x90 0xBF 2 rest+      | byte >= 0xF1 && byte <= 0xF3 =+          consumeContinuation offset 3 rest+      | byte == 0xF4 =+          consumeRestricted offset 0x80 0x8F 2 rest+      | otherwise = Left (InvalidUtf8 offset)++    consumeRestricted :: Int -> Word8 -> Word8 -> Int -> [Word8] -> Either SqlError ()+    consumeRestricted offset lower upper remainingCount input =+      case input of+        next : rest+          | next >= lower && next <= upper ->+              consumeContinuationFrom+                (offset + 2)+                remainingCount+                rest+          | otherwise -> Left (InvalidUtf8 (offset + 1))+        [] -> Left (InvalidUtf8 (offset + 1))++    consumeContinuation :: Int -> Int -> [Word8] -> Either SqlError ()+    consumeContinuation offset count input =+      consumeContinuationFrom (offset + 1) count input++    consumeContinuationFrom :: Int -> Int -> [Word8] -> Either SqlError ()+    consumeContinuationFrom nextOffset count input+      | count == 0 = go nextOffset input+      | otherwise =+          case input of+            next : rest+              | next >= 0x80 && next <= 0xBF ->+                  consumeContinuationFrom (nextOffset + 1) (count - 1) rest+              | otherwise -> Left (InvalidUtf8 nextOffset)+            [] -> Left (InvalidUtf8 nextOffset)
+ src/Database/PostgreSQL/Migrate/Sql/Scanner.hs view
@@ -0,0 +1,293 @@+module Database.PostgreSQL.Migrate.Sql.Scanner+  ( SqlError (..),+    SqlScan,+    scanSql,+    sqlScanTransactionMode,+    sqlScanStatementCount,+  )+where++import Data.Char qualified as Char+import Data.List qualified as List+import Data.Text qualified as Text+import Database.PostgreSQL.Migrate.Types (TransactionMode (..))+import PgMigrate.Prelude++-- | Exact reason SQL bytes are unsafe or invalid for the migration contract.+data SqlError+  = InvalidUtf8+      { byteOffset :: !Int+      }+  | UnknownDirective+      { directive :: !Text+      }+  | DuplicateNoTransactionDirective+  | UnterminatedSqlConstruct+      { construct :: !Text+      }+  | ProhibitedTransactionCommand+      { command :: !Text+      }+  | PsqlMetaCommand+      { lineNumber :: !Int+      }+  | CopyFromStdin+  | EmptySql+  | NonTransactionalStatementCount+      { actualStatements :: !Int+      }+  deriving stock (Generic, Eq, Show)++data SqlScan = SqlScan+  { transactionMode :: !TransactionMode,+    statementCount :: !Int+  }+  deriving stock (Generic, Eq, Show)++data Statement = Statement+  { tokens :: ![Text]+  }+  deriving stock (Generic, Eq, Show)++data StatementAccumulator = StatementAccumulator+  { reverseTokens :: ![Text],+    reverseWord :: !String,+    hasContent :: !Bool+  }++emptyAccumulator :: StatementAccumulator+emptyAccumulator = StatementAccumulator [] [] False++sqlScanTransactionMode :: SqlScan -> TransactionMode+sqlScanTransactionMode SqlScan {transactionMode} = transactionMode++sqlScanStatementCount :: SqlScan -> Int+sqlScanStatementCount SqlScan {statementCount} = statementCount++scanSql :: Text -> Either SqlError SqlScan+scanSql sql = do+  (noTransaction, body) <- scanLeadingRegion False (Text.unpack sql)+  statements <- scanStatements body+  traverse_ validateStatement statements+  let statementCount = length statements+  case (noTransaction, statementCount) of+    (_, 0) -> Left EmptySql+    (True, 1) -> Right (SqlScan NonTransactional statementCount)+    (True, count) -> Left (NonTransactionalStatementCount count)+    (False, count) -> Right (SqlScan Transactional count)++scanLeadingRegion :: Bool -> String -> Either SqlError (Bool, String)+scanLeadingRegion noTransaction input =+  case dropWhile Char.isSpace input of+    '-' : '-' : rest -> do+      let (comment, remaining) = break (== '\n') rest+      noTransaction' <- inspectLeadingComment noTransaction comment+      scanLeadingRegion noTransaction' remaining+    '/' : '*' : rest -> do+      remaining <- consumeLeadingBlockComment 1 rest+      scanLeadingRegion noTransaction remaining+    remaining -> Right (noTransaction, remaining)++inspectLeadingComment :: Bool -> String -> Either SqlError Bool+inspectLeadingComment alreadySeen comment =+  let commentText = Text.strip (Text.pack comment)+   in if commentText == "pg-migrate: no-transaction"+        then+          if alreadySeen+            then Left DuplicateNoTransactionDirective+            else Right True+        else+          if "pg-migrate:" `Text.isPrefixOf` commentText+            then Left (UnknownDirective commentText)+            else Right alreadySeen++consumeLeadingBlockComment :: Int -> String -> Either SqlError String+consumeLeadingBlockComment depth input =+  case input of+    [] -> Left (UnterminatedSqlConstruct "block comment")+    '/' : '*' : rest -> consumeLeadingBlockComment (depth + 1) rest+    '*' : '/' : rest+      | depth == 1 -> Right rest+      | otherwise -> consumeLeadingBlockComment (depth - 1) rest+    _ : rest -> consumeLeadingBlockComment depth rest++scanStatements :: String -> Either SqlError [Statement]+scanStatements = go 1 True emptyAccumulator []+  where+    go line lineOnlyWhitespace accumulator statements input =+      case input of+        [] -> Right (reverse (finishStatement accumulator statements))+        '\n' : rest ->+          go (line + 1) True (flushWord accumulator) statements rest+        character : rest+          | Char.isSpace character ->+              go line lineOnlyWhitespace (flushWord accumulator) statements rest+        '-' : '-' : rest ->+          go line lineOnlyWhitespace (flushWord accumulator) statements (dropLineComment rest)+        '/' : '*' : rest -> do+          (nextLine, nextLineOnlyWhitespace, remaining) <-+            consumeBlockComment 1 line lineOnlyWhitespace rest+          go nextLine nextLineOnlyWhitespace (flushWord accumulator) statements remaining+        '\\' : _+          | lineOnlyWhitespace -> Left (PsqlMetaCommand line)+        '\'' : rest -> do+          let (word, flushedAccumulator) = takeWord accumulator+              isEscapeString = fmap Char.toUpper word == "E"+          (nextLine, remaining) <- consumeSingleQuoted isEscapeString line rest+          go nextLine False (markContent flushedAccumulator) statements remaining+        '"' : rest -> do+          (nextLine, remaining) <- consumeDoubleQuoted line rest+          go nextLine False (markContent (flushWord accumulator)) statements remaining+        '$' : rest+          | null (reverseWord accumulator),+            Just (delimiter, afterOpening) <- dollarDelimiter rest -> do+              (nextLine, remaining) <- consumeDollarQuoted delimiter line afterOpening+              go nextLine False (markContent accumulator) statements remaining+        ';' : rest ->+          let flushedAccumulator = flushWord accumulator+           in go+                line+                False+                emptyAccumulator+                (finishStatement flushedAccumulator statements)+                rest+        character : rest+          | isWordCharacter character ->+              go+                line+                False+                accumulator+                  { reverseWord = character : reverseWord accumulator,+                    hasContent = True+                  }+                statements+                rest+        _ : rest ->+          go line False (markContent (flushWord accumulator)) statements rest++dropLineComment :: String -> String+dropLineComment = dropWhile (/= '\n')++consumeBlockComment :: Int -> Int -> Bool -> String -> Either SqlError (Int, Bool, String)+consumeBlockComment depth line lineOnlyWhitespace input =+  case input of+    [] -> Left (UnterminatedSqlConstruct "block comment")+    '/' : '*' : rest -> consumeBlockComment (depth + 1) line lineOnlyWhitespace rest+    '*' : '/' : rest+      | depth == 1 -> Right (line, lineOnlyWhitespace, rest)+      | otherwise -> consumeBlockComment (depth - 1) line lineOnlyWhitespace rest+    '\n' : rest -> consumeBlockComment depth (line + 1) True rest+    _ : rest -> consumeBlockComment depth line lineOnlyWhitespace rest++consumeSingleQuoted :: Bool -> Int -> String -> Either SqlError (Int, String)+consumeSingleQuoted isEscapeString line input =+  case input of+    [] -> Left (UnterminatedSqlConstruct "single-quoted string")+    '\'' : '\'' : rest -> consumeSingleQuoted isEscapeString line rest+    '\'' : rest -> Right (line, rest)+    '\\' : '\n' : rest+      | isEscapeString -> consumeSingleQuoted isEscapeString (line + 1) rest+    '\\' : _ : rest+      | isEscapeString -> consumeSingleQuoted isEscapeString line rest+    '\n' : rest -> consumeSingleQuoted isEscapeString (line + 1) rest+    _ : rest -> consumeSingleQuoted isEscapeString line rest++consumeDoubleQuoted :: Int -> String -> Either SqlError (Int, String)+consumeDoubleQuoted line input =+  case input of+    [] -> Left (UnterminatedSqlConstruct "double-quoted identifier")+    '"' : '"' : rest -> consumeDoubleQuoted line rest+    '"' : rest -> Right (line, rest)+    '\n' : rest -> consumeDoubleQuoted (line + 1) rest+    _ : rest -> consumeDoubleQuoted line rest++dollarDelimiter :: String -> Maybe (String, String)+dollarDelimiter rest =+  case rest of+    '$' : after -> Just ("$$", after)+    firstCharacter : _+      | Char.isAlpha firstCharacter || firstCharacter == '_' ->+          let (tag, suffix) = span isDollarTagCharacter rest+           in case suffix of+                '$' : after -> Just ('$' : tag <> "$", after)+                _ -> Nothing+    _ -> Nothing++isDollarTagCharacter :: Char -> Bool+isDollarTagCharacter character =+  Char.isAlphaNum character || character == '_'++consumeDollarQuoted :: String -> Int -> String -> Either SqlError (Int, String)+consumeDollarQuoted delimiter line input+  | delimiter `List.isPrefixOf` input = Right (line, drop (length delimiter) input)+  | otherwise =+      case input of+        [] -> Left (UnterminatedSqlConstruct "dollar-quoted string")+        '\n' : rest -> consumeDollarQuoted delimiter (line + 1) rest+        _ : rest -> consumeDollarQuoted delimiter line rest++isWordCharacter :: Char -> Bool+isWordCharacter character =+  Char.isAlphaNum character || character == '_' || character == '$'++markContent :: StatementAccumulator -> StatementAccumulator+markContent accumulator = accumulator {hasContent = True}++takeWord :: StatementAccumulator -> (String, StatementAccumulator)+takeWord accumulator =+  ( reverse (reverseWord accumulator),+    flushWord accumulator+  )++flushWord :: StatementAccumulator -> StatementAccumulator+flushWord accumulator@StatementAccumulator {reverseWord = []} = accumulator+flushWord accumulator@StatementAccumulator {reverseTokens, reverseWord} =+  accumulator+    { reverseTokens = Text.toUpper (Text.pack (reverse reverseWord)) : reverseTokens,+      reverseWord = []+    }++finishStatement :: StatementAccumulator -> [Statement] -> [Statement]+finishStatement accumulator statements+  | hasContent accumulator =+      let StatementAccumulator {reverseTokens} = flushWord accumulator+       in Statement {tokens = reverse reverseTokens} : statements+  | otherwise = statements++validateStatement :: Statement -> Either SqlError ()+validateStatement Statement {tokens} =+  case prohibitedCommand tokens of+    Just command -> Left (ProhibitedTransactionCommand command)+    Nothing+      | isCopyFromStdin tokens -> Left CopyFromStdin+      | otherwise -> Right ()++prohibitedCommand :: [Text] -> Maybe Text+prohibitedCommand tokens =+  case tokens of+    "BEGIN" : _ -> Just "BEGIN"+    "START" : "TRANSACTION" : _ -> Just "START TRANSACTION"+    "COMMIT" : "PREPARED" : _ -> Just "COMMIT PREPARED"+    "COMMIT" : _ -> Just "COMMIT"+    "END" : _ -> Just "END"+    "ROLLBACK" : "PREPARED" : _ -> Just "ROLLBACK PREPARED"+    "ROLLBACK" : _ -> Just "ROLLBACK"+    "ABORT" : _ -> Just "ABORT"+    "SAVEPOINT" : _ -> Just "SAVEPOINT"+    "RELEASE" : _ -> Just "RELEASE SAVEPOINT"+    "PREPARE" : "TRANSACTION" : _ -> Just "PREPARE TRANSACTION"+    _ -> Nothing++isCopyFromStdin :: [Text] -> Bool+isCopyFromStdin tokens =+  case tokens of+    "COPY" : rest -> containsAdjacent "FROM" "STDIN" rest+    _ -> False++containsAdjacent :: (Eq a) => a -> a -> [a] -> Bool+containsAdjacent firstValue secondValue values =+  case values of+    current : next : rest ->+      (current == firstValue && next == secondValue)+        || containsAdjacent firstValue secondValue (next : rest)+    _ -> False
+ src/Database/PostgreSQL/Migrate/Types.hs view
@@ -0,0 +1,154 @@+module Database.PostgreSQL.Migrate.Types+  ( ComponentName (..),+    MigrationName (..),+    MigrationId (..),+    MigrationChecksum (..),+    TransactionMode (..),+    MigrationKind (..),+    MigrationAction (..),+    Migration (..),+    MigrationComponent (..),+    MigrationPlan (..),+    componentNameText,+    migrationNameText,+    migrationIdComponent,+    migrationIdName,+    migrationNameOf,+    migrationChecksumOf,+    migrationKindOf,+    migrationModeOf,+    migrationActionOf,+    componentNameOf,+    componentDependenciesOf,+    componentMigrationsOf,+    planComponentsOf,+  )+where++import Hasql.Session qualified as Hasql.Session+import Hasql.Transaction qualified as Hasql.Transaction+import PgMigrate.Prelude++-- | Validated, application-stable component identifier.+newtype ComponentName = ComponentName+  { unComponentName :: Text+  }+  deriving stock (Generic, Eq, Ord, Show)++-- | Validated migration identifier local to one component.+newtype MigrationName = MigrationName+  { unMigrationName :: Text+  }+  deriving stock (Generic, Eq, Ord, Show)++-- | Globally unique migration identity: component plus local name.+data MigrationId = MigrationId+  { component :: !ComponentName,+    name :: !MigrationName+  }+  deriving stock (Generic, Eq, Ord, Show)++-- | SHA-256 fingerprint of the immutable migration payload.+newtype MigrationChecksum = MigrationChecksum+  { unMigrationChecksum :: ByteString+  }+  deriving stock (Generic, Eq, Ord, Show)++data TransactionMode+  = Transactional+  | NonTransactional+  deriving stock (Generic, Eq, Ord, Show)++data MigrationKind+  = SqlKind+  | HaskellKind+  deriving stock (Generic, Eq, Ord, Show)++data MigrationAction+  = SqlAction !ByteString+  | TransactionAction !(Hasql.Transaction.Transaction ())+  | SessionAction !(Hasql.Session.Session ())++-- | Validated migration definition with an immutable action and fingerprint.+data Migration = Migration+  { name :: !MigrationName,+    description :: !(Maybe Text),+    mode :: !TransactionMode,+    kind :: !MigrationKind,+    checksum :: !MigrationChecksum,+    action :: !MigrationAction+  }++-- | Ordered, non-empty migrations owned by one library component.+data MigrationComponent = MigrationComponent+  { name :: !ComponentName,+    dependencies :: !(Set ComponentName),+    migrations :: !(NonEmpty Migration)+  }++-- | Validated dependency-ordered composition of components.+newtype MigrationPlan = MigrationPlan+  { components :: NonEmpty MigrationComponent+  }++instance Show MigrationPlan where+  showsPrec precedence (MigrationPlan planComponents) =+    showsPrec precedence (summarizeComponent <$> planComponents)++summarizeComponent ::+  MigrationComponent ->+  (ComponentName, Set ComponentName, NonEmpty (MigrationName, MigrationChecksum, MigrationKind, TransactionMode))+summarizeComponent migrationComponent =+  ( componentNameOf migrationComponent,+    componentDependenciesOf migrationComponent,+    summarizeMigration <$> componentMigrationsOf migrationComponent+  )++summarizeMigration ::+  Migration ->+  (MigrationName, MigrationChecksum, MigrationKind, TransactionMode)+summarizeMigration migration =+  ( migrationNameOf migration,+    migrationChecksumOf migration,+    migrationKindOf migration,+    migrationModeOf migration+  )++componentNameText :: ComponentName -> Text+componentNameText (ComponentName value) = value++migrationNameText :: MigrationName -> Text+migrationNameText (MigrationName value) = value++migrationIdComponent :: MigrationId -> ComponentName+migrationIdComponent MigrationId {component} = component++migrationIdName :: MigrationId -> MigrationName+migrationIdName MigrationId {name} = name++migrationNameOf :: Migration -> MigrationName+migrationNameOf Migration {name} = name++migrationChecksumOf :: Migration -> MigrationChecksum+migrationChecksumOf Migration {checksum} = checksum++migrationKindOf :: Migration -> MigrationKind+migrationKindOf Migration {kind} = kind++migrationModeOf :: Migration -> TransactionMode+migrationModeOf Migration {mode} = mode++migrationActionOf :: Migration -> MigrationAction+migrationActionOf Migration {action} = action++componentNameOf :: MigrationComponent -> ComponentName+componentNameOf MigrationComponent {name} = name++componentDependenciesOf :: MigrationComponent -> Set ComponentName+componentDependenciesOf MigrationComponent {dependencies} = dependencies++componentMigrationsOf :: MigrationComponent -> NonEmpty Migration+componentMigrationsOf MigrationComponent {migrations} = migrations++planComponentsOf :: MigrationPlan -> NonEmpty MigrationComponent+planComponentsOf MigrationPlan {components} = components
+ src/PgMigrate/Prelude.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE PackageImports #-}+{-# OPTIONS_HADDOCK hide #-}++module PgMigrate.Prelude+  ( module X,+  )+where++import "base" Control.Monad as X (foldM, unless, when)+import "base" Data.Bifunctor as X (first)+import "base" Data.Either as X (partitionEithers)+import "base" Data.Foldable as X (for_, toList, traverse_)+import "base" Data.Function as X ((&))+import "base" Data.List as X (find, sortOn)+import "base" Data.List.NonEmpty as X (NonEmpty (..))+import "base" Data.Maybe as X (fromMaybe, isJust, mapMaybe)+import "base" Data.Ord as X (comparing)+import "base" Data.Traversable as X (for)+import "base" GHC.Generics as X (Generic)+import "bytestring" Data.ByteString as X (ByteString)+import "containers" Data.Map.Strict as X (Map)+import "containers" Data.Set as X (Set)+import "text" Data.Text as X (Text)+import "base" Prelude as X
+ test/crash-helper/Main.hs view
@@ -0,0 +1,51 @@+module Main (main) where++import Data.Int (Int64)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Set qualified as Set+import Data.Text qualified as Text+import Database.PostgreSQL.Migrate+import Hasql.Connection.Settings qualified as Settings+import System.Environment (getArgs, lookupEnv)++main :: IO ()+main = do+  arguments <- getArgs+  connectionString <- lookupEnv "PG_CONNECTION_STRING"+  case (arguments, connectionString) of+    ([schema, rawLockKey], Just connection) -> do+      let config = requireRight (ledgerConfig (Text.pack schema) (read rawLockKey :: Int64))+      result <-+        runMigrationPlan+          (withLedger config defaultRunOptions)+          (Settings.connectionString (Text.pack connection))+          crashPlan+      case result of+        Left migrationError -> fail (show migrationError)+        Right _ -> pure ()+    _ -> fail "usage: pg-migrate-crash-helper SCHEMA LOCK_KEY with PG_CONNECTION_STRING set"++crashPlan :: MigrationPlan+crashPlan =+  requireRight+    ( migrationPlan+        ( requireRight+            ( migrationComponent+                "crash-helper"+                Set.empty+                ( requireRight+                    ( sqlMigration+                        "0001-sleep"+                        "-- pg-migrate: no-transaction\nSELECT pg_sleep(2)"+                    )+                    :| []+                )+            )+            :| []+        )+    )++requireRight :: (Show error) => Either error value -> value+requireRight = \case+  Left err -> error (show err)+  Right value -> value
+ test/integration/Main.hs view
@@ -0,0 +1,1269 @@+module Main (main) where++import Control.Concurrent+  ( forkIO,+    killThread,+    newEmptyMVar,+    putMVar,+    readMVar,+    takeMVar,+    threadDelay,+    tryPutMVar,+  )+import Control.Exception (SomeException, bracket, finally, throwIO, try)+import Data.Aeson qualified as Aeson+import Data.ByteString (ByteString)+import Data.Foldable (toList)+import Data.Function ((&))+import Data.IORef (atomicModifyIORef', newIORef, readIORef)+import Data.Int (Int64)+import Data.List qualified as List+import Data.List.NonEmpty (NonEmpty (..))+import Data.List.NonEmpty qualified as NonEmpty+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text.Encoding+import Data.Time (NominalDiffTime)+import Data.Time.Clock.POSIX (getPOSIXTime)+import Data.Time.LocalTime (LocalTime)+import Database.PostgreSQL.Migrate+import Database.PostgreSQL.Migrate qualified as Migrate+import Database.PostgreSQL.Migrate.Internal+import GHC.Clock (getMonotonicTimeNSec)+import Hasql.Connection qualified as Connection+import Hasql.Connection.Settings qualified as Settings+import Hasql.Decoders qualified as Decoders+import Hasql.Encoders qualified as Encoders+import Hasql.Session (Session)+import Hasql.Session qualified as Session+import Hasql.Statement qualified as Statement+import Hasql.Transaction qualified as Transaction+import System.Environment (lookupEnv)+import System.Posix.Signals (sigKILL, signalProcess)+import System.Process (createProcess, getPid, proc, waitForProcess)+import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))++main :: IO ()+main = do+  maybeConnectionString <- lookupEnv "PG_CONNECTION_STRING"+  case maybeConnectionString of+    Nothing ->+      putStrLn+        "pg-migrate integration tests skipped: PG_CONNECTION_STRING is not set"+    Just connectionString ->+      defaultMain (tests (Settings.connectionString (Text.pack connectionString)))++tests :: Settings.Settings -> TestTree+tests settings =+  testGroup+    "pg-migrate PostgreSQL ledger"+    [ testCase "installation is complete, constrained, and idempotent" (testInstallation settings),+      testCase "quoted custom schemas are safe" (testQuotedSchema settings),+      testCase "read-only loading leaves a missing ledger missing" (testMissingReadOnly settings),+      testCase "a future schema version is refused without mutation" (testFutureVersion settings),+      testCase "server version and statement timeout lifecycle are supported" (testConnectionLifecycle settings),+      testCase "lock no-wait and finite timeout preserve session settings" (testLockLifecycle settings),+      testCase "transactional plans apply once and then report applied" (testTransactionalRunner settings),+      testCase "transactional SQL failure rolls back action and ledger" (testTransactionalRollback settings),+      testCase "condemned Haskell transactions are detected" (testTransactionCondemn settings),+      testCase "nontransactional CREATE INDEX CONCURRENTLY applies" (testNonTransactionalSuccess settings),+      testCase "nontransactional observed failure records Failed" (testNonTransactionalFailure settings),+      testCase "repair mark-applied audits and unblocks the plan" (testRepairMarkApplied settings),+      testCase "repair retry audits and executes the current action once" (testRepairRetry settings),+      testCase "repair retry failure remains audited and Failed" (testRepairRetryFailure settings),+      testCase "repair rejects invalid targets" (testRepairValidation settings),+      testCase "terminated nontransactional helper leaves Running" (testCrashAmbiguity settings),+      testCase "nontransactional callback failure leaves Applied" (testNonTransactionalCallback settings),+      testCase "history import is atomic, audited, and idempotent" (testHistoryImport settings),+      testCase "history import conflicts with ordinary applied rows" (testHistoryExistingConflict settings),+      testCase "history audit failure rolls back target rows" (testHistoryAtomicity settings),+      testCase "equivalent history uses read-only state validation" (testHistoryEquivalentState settings),+      testCase "events follow durable migration boundaries" (testEventOrder settings),+      testCase "callback failure restores timeout and releases the lock" (testCallbackCleanup settings),+      testCase "two concurrent runners execute each effect once" (testConcurrentRunners settings),+      testCase "asynchronous interruption restores and unlocks before returning" (testAsyncCleanup settings)+    ]++testInstallation :: Settings.Settings -> IO ()+testInstallation settings =+  withTestLedger settings "install" $ \connection config -> do+    initialize connection config >>= (@?= Right ())+    initialize connection config >>= (@?= Right ())+    snapshot <- useSession connection (loadLedger config)+    case snapshot of+      LedgerSnapshot+        { metadata =+            Just+              LedgerMetadata+                { schemaVersion,+                  runnerVersion+                },+          storedMigrations = []+        } -> do+          schemaVersion @?= currentLedgerVersion+          runnerVersion @?= integrationRunnerVersion+      other -> assertFailure ("unexpected initialized snapshot: " <> show other)+    tableNames <- useSession connection (Session.statement (ledgerSchema config) tableNamesStatement)+    tableNames+      @?= ["history_imports", "ledger_metadata", "migrations", "repairs"]+    mapM_ (assertConstraintRejects connection config) invalidMigrationRows+    migrationCount <- useSession connection (Session.statement () (migrationCountStatement config))+    migrationCount @?= 0++testQuotedSchema :: Settings.Settings -> IO ()+testQuotedSchema settings =+  withTestLedgerNamed settings (\suffix -> "application \"migrations\" " <> suffix) $ \connection config -> do+    initialize connection config >>= (@?= Right ())+    snapshot <- useSession connection (loadLedger config)+    case snapshot of+      LedgerSnapshot {metadata = Just LedgerMetadata {schemaVersion}} ->+        schemaVersion @?= currentLedgerVersion+      other -> assertFailure ("unexpected quoted-schema snapshot: " <> show other)++testMissingReadOnly :: Settings.Settings -> IO ()+testMissingReadOnly settings =+  withTestLedger settings "missing" $ \connection config -> do+    snapshot <- useSession connection (loadLedger config)+    snapshot @?= LedgerSnapshot {metadata = Nothing, storedMigrations = []}+    case statusFromSnapshot integrationPlan snapshot of+      StatusReport {issues, appliedMigrations, pendingMigrations, unknownMigrations} -> do+        issues @?= []+        appliedMigrations @?= []+        length pendingMigrations @?= 1+        unknownMigrations @?= []+    tableNames <- useSession connection (Session.statement (ledgerSchema config) tableNamesStatement)+    tableNames @?= []++testFutureVersion :: Settings.Settings -> IO ()+testFutureVersion settings =+  withTestLedger settings "future" $ \connection config -> do+    initialize connection config >>= (@?= Right ())+    tableNamesBefore <- useSession connection (Session.statement (ledgerSchema config) tableNamesStatement)+    useSession connection (Session.script (setFutureVersionSql config))+    initialize connection config+      >>= ( @?=+              Left+                LedgerTooNew+                  { databaseVersion = currentLedgerVersion + 1,+                    supportedVersion = currentLedgerVersion+                  }+          )+    tableNamesAfter <- useSession connection (Session.statement (ledgerSchema config) tableNamesStatement)+    tableNamesAfter @?= tableNamesBefore+    snapshot <- useSession connection (loadLedger config)+    case snapshot of+      LedgerSnapshot {metadata = Just LedgerMetadata {schemaVersion}} ->+        schemaVersion @?= currentLedgerVersion + 1+      other -> assertFailure ("unexpected future-version snapshot: " <> show other)++testConnectionLifecycle :: Settings.Settings -> IO ()+testConnectionLifecycle settings =+  withConnection settings $ \connection -> do+    majorVersion <- checkServerVersion connection >>= requireMigrationRight+    assertBool ("unsupported accepted server major: " <> show majorVersion) (majorVersion `elem` [17, 18])+    before <- readStatementTimeout connection >>= requireMigrationRight+    saved <- applyStatementTimeout connection (Just 0.075) >>= requireMigrationRight+    saved @?= Just before+    during <- readStatementTimeout connection >>= requireMigrationRight+    during @?= "75ms"+    restoreStatementTimeout connection saved >>= requireCleanupRight+    after <- readStatementTimeout connection >>= requireMigrationRight+    after @?= before++testLockLifecycle :: Settings.Settings -> IO ()+testLockLifecycle settings = do+  lockKey <- uniqueLockKey+  withConnection settings $ \holder ->+    withConnection settings $ \contender -> do+      timeoutBefore <- readStatementTimeout contender >>= requireMigrationRight+      _ <- acquireAdvisoryLock holder lockKey WaitIndefinitely >>= requireMigrationRight+      acquireAdvisoryLock contender lockKey NoWait >>= assertLockUnavailable+      started <- getMonotonicTimeNSec+      acquireAdvisoryLock contender lockKey (WaitFor 0.12) >>= assertLockTimedOut+      finished <- getMonotonicTimeNSec+      let elapsed = fromIntegral (finished - started) / (1000000000 :: Double)+      assertBool ("finite lock wait returned too early: " <> show elapsed) (elapsed >= 0.10)+      assertBool ("finite lock wait returned too late: " <> show elapsed) (elapsed < 1.0)+      releaseAdvisoryLock holder lockKey >>= requireCleanupRight+      _ <- acquireAdvisoryLock contender lockKey NoWait >>= requireMigrationRight+      releaseAdvisoryLock contender lockKey >>= requireCleanupRight+      timeoutAfter <- readStatementTimeout contender >>= requireMigrationRight+      timeoutAfter @?= timeoutBefore++testTransactionalRunner :: Settings.Settings -> IO ()+testTransactionalRunner settings =+  withTestLedger settings "runner" $ \connection config -> do+    let plan =+          sqlPlan+            "runner"+            [ ("0001-create", "CREATE TABLE " <> quotedSchema config <> ".effects (value integer NOT NULL)"),+              ("0002-insert", "INSERT INTO " <> quotedSchema config <> ".effects (value) VALUES (1)")+            ]+        options = withLedger config defaultRunOptions+    firstReport <- runMigrationPlan options settings plan >>= requireRunRight+    reportOutcomes firstReport @?= [AppliedNow, AppliedNow]+    secondReport <- runMigrationPlan options settings plan >>= requireRunRight+    reportOutcomes secondReport @?= [AlreadyApplied, AlreadyApplied]+    effectCount <- useSession connection (Session.statement () (effectCountStatement config))+    effectCount @?= 1+    snapshot <- useSession connection (loadLedger config)+    length (storedMigrations snapshot) @?= 2++testTransactionalRollback :: Settings.Settings -> IO ()+testTransactionalRollback settings =+  withTestLedger settings "rollback" $ \connection config -> do+    let plan =+          sqlPlan+            "rollback"+            [ ( "0001-fail",+                Text.unlines+                  [ "CREATE TABLE",+                    quotedSchema config <> ".rolled_back (value integer);",+                    "SELECT 1 / 0"+                  ]+              )+            ]+    runMigrationPlan (withLedger config defaultRunOptions) settings plan+      >>= assertDatabaseSessionFailure+    tableNames <- useSession connection (Session.statement (ledgerSchema config) tableNamesStatement)+    assertBool "failed transaction left its user table" ("rolled_back" `notElem` tableNames)+    snapshot <- useSession connection (loadLedger config)+    storedMigrations snapshot @?= []++testTransactionCondemn :: Settings.Settings -> IO ()+testTransactionCondemn settings =+  withTestLedger settings "condemn" $ \connection config -> do+    let action = do+          Transaction.sql+            (Text.Encoding.encodeUtf8 ("CREATE TABLE " <> quotedSchema config <> ".condemned (value integer)"))+          Transaction.condemn+        migration =+          requireRight+            (transactionMigration "0001-condemn" (migrationFingerprint "condemn-v1") action)+        plan = planFromMigrations "condemn" [migration]+    runMigrationPlan (withLedger config defaultRunOptions) settings plan+      >>= assertTransactionCondemned+    tableNames <- useSession connection (Session.statement (ledgerSchema config) tableNamesStatement)+    assertBool "condemned transaction left its user table" ("condemned" `notElem` tableNames)+    snapshot <- useSession connection (loadLedger config)+    storedMigrations snapshot @?= []++testNonTransactionalSuccess :: Settings.Settings -> IO ()+testNonTransactionalSuccess settings =+  withTestLedger settings "nontransactional_success" $ \connection config -> do+    let plan =+          sqlPlan+            "nontransactional-success"+            [ ( "0001-table",+                Text.unlines+                  [ "CREATE TABLE",+                    quotedSchema config <> ".indexed_values (value integer NOT NULL);",+                    "INSERT INTO",+                    quotedSchema config <> ".indexed_values (value) VALUES (1)"+                  ]+              ),+              ( "0002-index",+                Text.unlines+                  [ "-- pg-migrate: no-transaction",+                    "CREATE INDEX CONCURRENTLY idx_nontransactional ON",+                    quotedSchema config <> ".indexed_values (value)"+                  ]+              )+            ]+    report <-+      runMigrationPlan (withLedger config defaultRunOptions) settings plan+        >>= requireRunRight+    reportOutcomes report @?= [AppliedNow, AppliedNow]+    indexExists <-+      useSession connection (Session.statement (ledgerSchema config) indexExistsStatement)+    indexExists @?= True+    snapshot <- useSession connection (loadLedger config)+    storedStatuses snapshot @?= [Applied, Applied]++testNonTransactionalFailure :: Settings.Settings -> IO ()+testNonTransactionalFailure settings =+  withTestLedger settings "nontransactional_failure" $ \connection config -> do+    let plan =+          sqlPlan+            "nontransactional-failure"+            [ ("0001-table", "CREATE TABLE " <> quotedSchema config <> ".existing_values (value integer NOT NULL)"),+              ( "0002-fail",+                Text.unlines+                  [ "-- pg-migrate: no-transaction",+                    "CREATE INDEX CONCURRENTLY idx_missing ON",+                    quotedSchema config <> ".missing_values (value)"+                  ]+              )+            ]+        options = withLedger config defaultRunOptions+    runMigrationPlan options settings plan >>= assertNonTransactionalFailure+    snapshot <- useSession connection (loadLedger config)+    storedStatuses snapshot @?= [Applied, Failed]+    case reverse (storedMigrations snapshot) of+      StoredMigration {errorMessage = Just diagnostic} : _ ->+        assertBool "Failed row did not preserve a diagnostic" (not (Text.null diagnostic))+      rows -> assertFailure ("unexpected failed rows: " <> show rows)+    runMigrationPlan options settings plan >>= assertPlanVerificationFailure++testRepairMarkApplied :: Settings.Settings -> IO ()+testRepairMarkApplied settings =+  withTestLedger settings "repair_mark" $ \connection config -> do+    let component = "repair-mark"+        plan = missingIndexPlan config component "idx_repair_mark" "mark_missing"+        options = withLedger config defaultRunOptions+        targetId = requireRight (Migrate.migrationId component "0001-index")+        request =+          requireRight+            (repairRequest targetId MarkApplied "index was verified out of band" Confirmed)+    runMigrationPlan options settings plan >>= assertNonTransactionalFailure+    repaired <-+      repairMigration options (connectionProviderFromSettings settings) plan request+        >>= requireRepairRight+    repaired+      @?= RepairReport+        { repairedMigration = targetId,+          operation = MarkApplied,+          oldStatus = Failed,+          newStatus = Applied+        }+    snapshot <- useSession connection (loadLedger config)+    storedStatuses snapshot @?= [Applied]+    repairCount <- useSession connection (Session.statement () (repairAuditCountStatement config))+    repairCount @?= 1+    repairAudit <- useSession connection (Session.statement () (repairAuditStatement config))+    repairAudit @?= ("mark-applied", "failed", "applied", "index was verified out of band")+    report <- runMigrationPlan options settings plan >>= requireRunRight+    reportOutcomes report @?= [AlreadyApplied]++testRepairRetry :: Settings.Settings -> IO ()+testRepairRetry settings =+  withTestLedger settings "repair_retry" $ \connection config -> do+    let component = "repair-retry"+        plan = missingIndexPlan config component "idx_repair_retry" "retry_values"+        options = withLedger config defaultRunOptions+        targetId = requireRight (Migrate.migrationId component "0001-index")+        request =+          requireRight+            (repairRequest targetId Retry "created the missing prerequisite table" Confirmed)+    runMigrationPlan options settings plan >>= assertNonTransactionalFailure+    useSession+      connection+      (Session.script ("CREATE TABLE " <> quotedSchema config <> ".retry_values (value integer NOT NULL)"))+    repaired <-+      repairMigration options (connectionProviderFromSettings settings) plan request+        >>= requireRepairRight+    repaired+      @?= RepairReport+        { repairedMigration = targetId,+          operation = Retry,+          oldStatus = Failed,+          newStatus = Applied+        }+    snapshot <- useSession connection (loadLedger config)+    storedStatuses snapshot @?= [Applied]+    repairCount <- useSession connection (Session.statement () (repairAuditCountStatement config))+    repairCount @?= 1+    repairAudit <- useSession connection (Session.statement () (repairAuditStatement config))+    repairAudit @?= ("retry", "failed", "running", "created the missing prerequisite table")+    indexExists <- useSession connection (Session.statement (ledgerSchema config) retryIndexExistsStatement)+    indexExists @?= True++testRepairRetryFailure :: Settings.Settings -> IO ()+testRepairRetryFailure settings =+  withTestLedger settings "repair_retry_failure" $ \connection config -> do+    let component = "repair-retry-failure"+        plan = missingIndexPlan config component "idx_retry_failure" "still_missing"+        options = withLedger config defaultRunOptions+        targetId = requireRight (Migrate.migrationId component "0001-index")+        request = requireRight (repairRequest targetId Retry "retry once for audit" Confirmed)+    runMigrationPlan options settings plan >>= assertNonTransactionalFailure+    repairMigration options (connectionProviderFromSettings settings) plan request+      >>= assertRepairRunFailure+    snapshot <- useSession connection (loadLedger config)+    storedStatuses snapshot @?= [Failed]+    repairCount <- useSession connection (Session.statement () (repairAuditCountStatement config))+    repairCount @?= 1+    repairAudit <- useSession connection (Session.statement () (repairAuditStatement config))+    repairAudit @?= ("retry", "failed", "running", "retry once for audit")++testRepairValidation :: Settings.Settings -> IO ()+testRepairValidation settings = do+  withTestLedger settings "repair_transactional" $ \_ config -> do+    let transactionalPlan =+          sqlPlan+            "repair-transactional"+            [("0001-table", "CREATE TABLE " <> quotedSchema config <> ".transactional_target (value integer)")]+        options = withLedger config defaultRunOptions+        transactionalId = requireRight (Migrate.migrationId "repair-transactional" "0001-table")+        transactionalRequest =+          requireRight (repairRequest transactionalId MarkApplied "must reject" Confirmed)+    _ <- runMigrationPlan options settings transactionalPlan >>= requireRunRight+    repairMigration options (connectionProviderFromSettings settings) transactionalPlan transactionalRequest+      >>= assertRepairTransactional+  withTestLedger settings "repair_checksum" $ \_ config -> do+    let component = "repair-checksum"+        originalPlan = missingIndexPlan config component "idx_original" "checksum_missing"+        changedPlan = missingIndexPlan config component "idx_changed" "checksum_missing"+        options = withLedger config defaultRunOptions+        targetId = requireRight (Migrate.migrationId component "0001-index")+        request = requireRight (repairRequest targetId Retry "must reject changed SQL" Confirmed)+    runMigrationPlan options settings originalPlan >>= assertNonTransactionalFailure+    repairMigration options (connectionProviderFromSettings settings) changedPlan request+      >>= assertRepairMetadataMismatch+  withTestLedger settings "repair_missing" $ \_ config -> do+    let component = "repair-missing"+        plan = missingIndexPlan config component "idx_missing_target" "missing_target"+        options = withLedger config defaultRunOptions+        unknownId = requireRight (Migrate.migrationId component "9999-unknown")+        request = requireRight (repairRequest unknownId MarkApplied "must reject unknown target" Confirmed)+    repairMigration options (connectionProviderFromSettings settings) plan request+      >>= assertRepairMissing+  withTestLedger settings "repair_applied" $ \connection config -> do+    initialize connection config >>= (@?= Right ())+    useSession connection (Session.script ("CREATE TABLE " <> quotedSchema config <> ".applied_values (value integer NOT NULL)"))+    let component = "repair-applied"+        plan = missingIndexPlan config component "idx_applied_target" "applied_values"+        options = withLedger config defaultRunOptions+        targetId = requireRight (Migrate.migrationId component "0001-index")+        request = requireRight (repairRequest targetId MarkApplied "must reject applied target" Confirmed)+    _ <- runMigrationPlan options settings plan >>= requireRunRight+    repairMigration options (connectionProviderFromSettings settings) plan request+      >>= assertRepairAlreadyApplied++testCrashAmbiguity :: Settings.Settings -> IO ()+testCrashAmbiguity settings =+  withTestLedger settings "crash" $ \connection config ->+    withConnection settings $ \contender -> do+      (_, _, _, processHandle) <-+        createProcess+          ( proc+              "pg-migrate-crash-helper"+              [ Text.unpack (ledgerSchema config),+                show (lockKey config)+              ]+          )+      waitForRunning connection config 600+      processId <- getPid processHandle >>= maybe (fail "crash helper has no process id") pure+      signalProcess sigKILL processId+      _ <- waitForProcess processHandle+      snapshot <- useSession connection (loadLedger config)+      storedStatuses snapshot @?= [Running]+      runMigrationPlan+        (withLedger config defaultRunOptions)+        settings+        (crashMigrationPlan config)+        >>= assertPlanVerificationFailure+      _ <- acquireAdvisoryLock contender (lockKey config) NoWait >>= requireMigrationRight+      releaseAdvisoryLock contender (lockKey config) >>= requireCleanupRight++testNonTransactionalCallback :: Settings.Settings -> IO ()+testNonTransactionalCallback settings =+  withTestLedger settings "nontransactional_callback" $ \connection config ->+    withConnection settings $ \contender -> do+      initialize connection config >>= (@?= Right ())+      useSession connection (Session.script ("CREATE TABLE " <> quotedSchema config <> ".callback_values (value integer NOT NULL)"))+      let component = "nontransactional-callback"+          plan = missingIndexPlan config component "idx_nontransactional_callback" "callback_values"+          handler = \case+            MigrationCompleted {} -> throwIO (userError "nontransactional callback failure")+            _ -> pure ()+          options = defaultRunOptions & withLedger config & withEventHandler handler+      runMigrationPlan options settings plan >>= assertEventHandlerFailure+      snapshot <- useSession connection (loadLedger config)+      storedStatuses snapshot @?= [Applied]+      _ <- acquireAdvisoryLock contender (lockKey config) NoWait >>= requireMigrationRight+      releaseAdvisoryLock contender (lockKey config) >>= requireCleanupRight++testHistoryImport :: Settings.Settings -> IO ()+testHistoryImport settings =+  withTestLedger settings "history_import" $ \connection config -> do+    let plan = historySqlPlan config+        imported = historySqlImport config False+        options = historyOptions config+        provider = connectionProviderFromSettings settings+        expectedIds = historyTarget <$> [1, 2]+    firstReport <- importMigrationHistory options provider plan imported >>= requireHistoryRight+    historyOutcomes firstReport @?= zip expectedIds (repeat Imported)+    snapshot <- useSession connection (loadLedger config)+    storedStatuses snapshot @?= [Applied, Applied]+    [storedPosition | StoredMigration {position = storedPosition} <- storedMigrations snapshot] @?= [1, 2]+    tableNames <- useSession connection (Session.statement (ledgerSchema config) tableNamesStatement)+    assertBool "history import executed a target action" (all (`notElem` tableNames) ["import_action_1", "import_action_2"])+    auditEvidence <- useSession connection (Session.statement () (historyAuditEvidenceStatement config))+    auditEvidence @?= (2, True, True)+    secondReport <- importMigrationHistory options provider plan imported >>= requireHistoryRight+    historyOutcomes secondReport @?= zip expectedIds (repeat AlreadyImported)+    migrationCount <- useSession connection (Session.statement () (migrationCountStatement config))+    migrationCount @?= 2+    importMigrationHistory options provider plan (historySqlImport config True)+      >>= assertHistoryConflict (historyTarget 1)++testHistoryExistingConflict :: Settings.Settings -> IO ()+testHistoryExistingConflict settings =+  withTestLedger settings "history_existing" $ \connection config -> do+    let firstSql = "CREATE TABLE " <> quotedSchema config <> ".import_action_1 (value integer)"+        existingPlan = sqlPlan "history-import" [("0001-one", firstSql)]+        fullPlan = historySqlPlan config+        runOptions = withLedger config defaultRunOptions+    _ <- runMigrationPlan runOptions settings existingPlan >>= requireRunRight+    importMigrationHistory+      (historyOptions config)+      (connectionProviderFromSettings settings)+      fullPlan+      (historySqlImport config False)+      >>= assertHistoryConflict (historyTarget 1)+    snapshot <- useSession connection (loadLedger config)+    length (storedMigrations snapshot) @?= 1+    auditCount <- useSession connection (Session.statement () (historyAuditCountStatement config))+    auditCount @?= 0++testHistoryAtomicity :: Settings.Settings -> IO ()+testHistoryAtomicity settings =+  withTestLedger settings "history_atomicity" $ \connection config -> do+    initialize connection config >>= (@?= Right ())+    useSession+      connection+      ( Session.script+          ( "ALTER TABLE "+              <> quotedSchema config+              <> ".history_imports ADD CONSTRAINT reject_second_history CHECK (migration <> '0002-two')"+          )+      )+    importMigrationHistory+      (historyOptions config)+      (connectionProviderFromSettings settings)+      (historySqlPlan config)+      (historySqlImport config False)+      >>= assertHistoryDatabaseFailure+    snapshot <- useSession connection (loadLedger config)+    storedMigrations snapshot @?= []+    auditCount <- useSession connection (Session.statement () (historyAuditCountStatement config))+    auditCount @?= 0++testHistoryEquivalentState :: Settings.Settings -> IO ()+testHistoryEquivalentState settings = do+  withTestLedger settings "history_equivalent" $ \connection config -> do+    initialize connection config >>= (@?= Right ())+    useSession connection (Session.script ("CREATE TABLE " <> quotedSchema config <> ".legacy_state (value integer)"))+    let (plan, imported) = equivalentHistoryPlan config successfulStateValidator+        baseOptions = historyOptions config+        allowedOptions = withEquivalentHistory AllowEquivalentHistory baseOptions+        provider = connectionProviderFromSettings settings+        successfulStateValidator =+          stateValidator historyStateKey $ do+            exists <- Transaction.statement (ledgerSchema config <> ".legacy_state") stateTableExistsStatement+            pure+              ( if exists+                  then Right (Aeson.object ["legacy_table" Aeson..= ("present" :: Text)])+                  else Left (requireRight (stateValidationError "legacy state is missing"))+              )+    importMigrationHistory baseOptions provider plan imported+      >>= assertEquivalentDisallowed (historyHaskellTarget)+    report <- importMigrationHistory allowedOptions provider plan imported >>= requireHistoryRight+    historyOutcomes report @?= [(historyHaskellTarget, Imported)]+    tableNames <- useSession connection (Session.statement (ledgerSchema config) tableNamesStatement)+    assertBool "equivalent import executed the Haskell target" ("haskell_action" `notElem` tableNames)+  withTestLedger settings "history_validator_failure" $ \_ config -> do+    let failedValidator =+          stateValidator historyStateKey (pure (Left (requireRight (stateValidationError "domain state mismatch"))))+        (plan, imported) = equivalentHistoryPlan config failedValidator+    importMigrationHistory+      (withEquivalentHistory AllowEquivalentHistory (historyOptions config))+      (connectionProviderFromSettings settings)+      plan+      imported+      >>= assertStateValidationFailure historyStateKey+  withTestLedger settings "history_validator_read_only" $ \connection config -> do+    let writeValidator =+          stateValidator historyStateKey $ do+            Transaction.sql (Text.Encoding.encodeUtf8 ("CREATE TABLE " <> quotedSchema config <> ".validator_write (value integer)"))+            pure (Right Aeson.Null)+        (plan, imported) = equivalentHistoryPlan config writeValidator+    importMigrationHistory+      (withEquivalentHistory AllowEquivalentHistory (historyOptions config))+      (connectionProviderFromSettings settings)+      plan+      imported+      >>= assertHistoryDatabaseFailure+    tableNames <- useSession connection (Session.statement (ledgerSchema config) tableNamesStatement)+    assertBool "read-only validator wrote state" ("validator_write" `notElem` tableNames)++testEventOrder :: Settings.Settings -> IO ()+testEventOrder settings =+  withTestLedger settings "events" $ \_ config -> do+    eventsRef <- newIORef []+    let plan =+          sqlPlan+            "events"+            [ ("0001-create", "CREATE TABLE " <> quotedSchema config <> ".event_effects (value integer NOT NULL)"),+              ("0002-insert", "INSERT INTO " <> quotedSchema config <> ".event_effects (value) VALUES (1)")+            ]+        handler event = atomicModifyIORef' eventsRef (\events -> (events <> [event], ()))+        options = defaultRunOptions & withLedger config & withEventHandler handler+    report <- runMigrationPlan options settings plan >>= requireRunRight+    reportOutcomes report @?= [AppliedNow, AppliedNow]+    events <- readIORef eventsRef+    assertSuccessfulEventOrder events++testCallbackCleanup :: Settings.Settings -> IO ()+testCallbackCleanup settings =+  withTestLedger settings "callback" $ \connection config ->+    withConnection settings $ \contender -> do+      timeoutBefore <- readStatementTimeout connection >>= requireMigrationRight+      let plan =+            sqlPlan+              "callback"+              [ ("0001-create", "CREATE TABLE " <> quotedSchema config <> ".callback_first (value integer)"),+                ("0002-never", "CREATE TABLE " <> quotedSchema config <> ".callback_second (value integer)")+              ]+          handler = \case+            MigrationCompleted {} -> throwIO (userError "callback failure")+            _ -> pure ()+          options =+            defaultRunOptions+              & withLedger config+              & withStatementTimeout (Just 0.5)+              & withEventHandler handler+          provider = connectionProvider (\action -> Right <$> action connection)+      runMigrationPlanWith options provider plan >>= assertEventHandlerFailure+      timeoutAfter <- readStatementTimeout connection >>= requireMigrationRight+      timeoutAfter @?= timeoutBefore+      _ <- acquireAdvisoryLock contender (lockKey config) NoWait >>= requireMigrationRight+      releaseAdvisoryLock contender (lockKey config) >>= requireCleanupRight+      snapshot <- useSession connection (loadLedger config)+      length (storedMigrations snapshot) @?= 1+      tableNames <- useSession connection (Session.statement (ledgerSchema config) tableNamesStatement)+      assertBool "first migration was not durable before callback" ("callback_first" `elem` tableNames)+      assertBool "runner continued after callback failure" ("callback_second" `notElem` tableNames)++testConcurrentRunners :: Settings.Settings -> IO ()+testConcurrentRunners settings =+  withTestLedger settings "concurrent" $ \connection config -> do+    let plan =+          sqlPlan+            "concurrent"+            [ ("0001-create", "CREATE TABLE " <> quotedSchema config <> ".concurrent_effects (value integer NOT NULL)"),+              ("0002-insert", "INSERT INTO " <> quotedSchema config <> ".concurrent_effects (value) VALUES (1)")+            ]+        options = defaultRunOptions & withLedger config+        run = runMigrationPlan options settings plan+    gate <- newEmptyMVar+    firstDone <- newEmptyMVar+    secondDone <- newEmptyMVar+    _ <- forkIO (readMVar gate >> try @SomeException run >>= putMVar firstDone)+    _ <- forkIO (readMVar gate >> try @SomeException run >>= putMVar secondDone)+    putMVar gate ()+    firstReport <- takeMVar firstDone >>= requireThreadRun+    secondReport <- takeMVar secondDone >>= requireThreadRun+    List.sort [reportOutcomes firstReport, reportOutcomes secondReport]+      @?= List.sort [[AppliedNow, AppliedNow], [AlreadyApplied, AlreadyApplied]]+    effectCount <- useSession connection (Session.statement () (concurrentEffectCountStatement config))+    effectCount @?= 1+    snapshot <- useSession connection (loadLedger config)+    length (storedMigrations snapshot) @?= 2++testAsyncCleanup :: Settings.Settings -> IO ()+testAsyncCleanup settings =+  withTestLedger settings "async" $ \connection config ->+    withConnection settings $ \contender -> do+      timeoutBefore <- readStatementTimeout connection >>= requireMigrationRight+      started <- newEmptyMVar+      done <- newEmptyMVar+      let action = Transaction.sql "SELECT pg_sleep(5)"+          migration =+            requireRight+              (transactionMigration "0001-sleep" (migrationFingerprint "sleep-v1") action)+          plan = planFromMigrations "async" [migration]+          handler = \case+            MigrationStarted {} -> do+              _ <- tryPutMVar started ()+              pure ()+            _ -> pure ()+          options =+            defaultRunOptions+              & withLedger config+              & withStatementTimeout (Just 2)+              & withEventHandler handler+          provider = connectionProvider (\use -> Right <$> use connection)+      runnerThread <-+        forkIO+          (try @SomeException (runMigrationPlanWith options provider plan) >>= putMVar done)+      takeMVar started+      threadDelay 50000+      killThread runnerThread+      interrupted <- takeMVar done+      case interrupted of+        Left _ -> pure ()+        Right result -> assertFailure ("expected asynchronous exception, received " <> show result)+      timeoutAfter <- readStatementTimeout connection >>= requireMigrationRight+      timeoutAfter @?= timeoutBefore+      _ <- acquireAdvisoryLock contender (lockKey config) NoWait >>= requireMigrationRight+      releaseAdvisoryLock contender (lockKey config) >>= requireCleanupRight+      snapshot <- useSession connection (loadLedger config)+      storedMigrations snapshot @?= []++withTestLedger ::+  Settings.Settings ->+  Text ->+  (Connection.Connection -> LedgerConfig -> IO a) ->+  IO a+withTestLedger settings label action =+  withTestLedgerNamed settings (\suffix -> "pgmigrate_test_" <> label <> "_" <> suffix) action++withTestLedgerNamed ::+  Settings.Settings ->+  (Text -> Text) ->+  (Connection.Connection -> LedgerConfig -> IO a) ->+  IO a+withTestLedgerNamed settings makeSchema action = do+  suffix <- uniqueSuffix+  let suffixNumber = read (Text.unpack suffix) :: Integer+      lockKey = testLockKey + fromIntegral (suffixNumber `mod` 1000000)+      config = requireRight (ledgerConfig (makeSchema suffix) lockKey)+  withConnection settings $ \connection -> do+    cleanupLedger connection config+    action connection config `finally` cleanupLedger connection config++withConnection :: Settings.Settings -> (Connection.Connection -> IO a) -> IO a+withConnection settings action = do+  acquired <- Connection.acquire settings+  case acquired of+    Left connectionError ->+      assertFailure ("failed to acquire PostgreSQL integration connection: " <> show connectionError)+        >> error "assertFailure returned"+    Right connection -> bracket (pure connection) Connection.release action++initialize :: Connection.Connection -> LedgerConfig -> IO (Either LedgerError ())+initialize connection config =+  useSession connection (initializeOrUpgradeLedger config integrationRunnerVersion)++useSession :: Connection.Connection -> Session a -> IO a+useSession connection session = do+  result <- Connection.use connection session+  case result of+    Left sessionError ->+      assertFailure ("PostgreSQL session failed: " <> show sessionError)+        >> error "assertFailure returned"+    Right value -> pure value++assertConstraintRejects :: Connection.Connection -> LedgerConfig -> Text -> IO ()+assertConstraintRejects connection config values = do+  result <- Connection.use connection (Session.script (invalidInsertSql config values))+  assertBool ("expected constraint failure for values: " <> Text.unpack values) (isLeft result)++cleanupLedger :: Connection.Connection -> LedgerConfig -> IO ()+cleanupLedger connection config =+  useSession+    connection+    (Session.script ("DROP SCHEMA IF EXISTS " <> quotedSchema config <> " CASCADE"))++invalidInsertSql :: LedgerConfig -> Text -> Text+invalidInsertSql config values =+  Text.unwords+    [ "INSERT INTO",+      qualifiedMigrationsTable config,+      "(component, migration, position, checksum, kind, transaction_mode, status,",+      "started_at, finished_at, execution_time_ms, error, runner_version)",+      "VALUES",+      values+    ]++invalidMigrationRows :: [Text]+invalidMigrationRows =+  [ "('owner', 'bad-position', 0, decode(repeat('00', 32), 'hex'), 'sql', 'transactional', 'applied', clock_timestamp(), clock_timestamp(), 0, NULL, 'test')",+    "('owner', 'bad-checksum', 1, decode('00', 'hex'), 'sql', 'transactional', 'applied', clock_timestamp(), clock_timestamp(), 0, NULL, 'test')",+    "('owner', 'bad-kind', 1, decode(repeat('00', 32), 'hex'), 'other', 'transactional', 'applied', clock_timestamp(), clock_timestamp(), 0, NULL, 'test')",+    "('owner', 'bad-mode', 1, decode(repeat('00', 32), 'hex'), 'sql', 'other', 'applied', clock_timestamp(), clock_timestamp(), 0, NULL, 'test')",+    "('owner', 'bad-status', 1, decode(repeat('00', 32), 'hex'), 'sql', 'transactional', 'other', clock_timestamp(), clock_timestamp(), 0, NULL, 'test')",+    "('owner', 'transactional-running', 1, decode(repeat('00', 32), 'hex'), 'sql', 'transactional', 'running', clock_timestamp(), NULL, NULL, NULL, 'test')",+    "('owner', 'bad-status-shape', 1, decode(repeat('00', 32), 'hex'), 'sql', 'transactional', 'applied', clock_timestamp(), NULL, 0, NULL, 'test')"+  ]++tableNamesStatement :: Statement.Statement Text [Text]+tableNamesStatement =+  Statement.preparable+    """+    SELECT table_name::text+    FROM information_schema.tables+    WHERE table_schema = $1+    ORDER BY table_name+    """+    (Encoders.param (Encoders.nonNullable Encoders.text))+    (Decoders.rowList (Decoders.column (Decoders.nonNullable Decoders.text)))++migrationCountStatement :: LedgerConfig -> Statement.Statement () Int64+migrationCountStatement config =+  Statement.unpreparable+    ("SELECT count(*) FROM " <> qualifiedMigrationsTable config)+    Encoders.noParams+    (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.int8)))++effectCountStatement :: LedgerConfig -> Statement.Statement () Int64+effectCountStatement config =+  Statement.unpreparable+    ("SELECT count(*) FROM " <> quotedSchema config <> ".effects")+    Encoders.noParams+    (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.int8)))++concurrentEffectCountStatement :: LedgerConfig -> Statement.Statement () Int64+concurrentEffectCountStatement config =+  Statement.unpreparable+    ("SELECT count(*) FROM " <> quotedSchema config <> ".concurrent_effects")+    Encoders.noParams+    (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.int8)))++repairAuditCountStatement :: LedgerConfig -> Statement.Statement () Int64+repairAuditCountStatement config =+  Statement.unpreparable+    ("SELECT count(*) FROM " <> quotedSchema config <> ".repairs")+    Encoders.noParams+    (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.int8)))++repairAuditStatement :: LedgerConfig -> Statement.Statement () (Text, Text, Text, Text)+repairAuditStatement config =+  Statement.unpreparable+    ("SELECT operation, old_status, new_status, reason FROM " <> quotedSchema config <> ".repairs")+    Encoders.noParams+    ( Decoders.singleRow+        ( (,,,)+            <$> Decoders.column (Decoders.nonNullable Decoders.text)+            <*> Decoders.column (Decoders.nonNullable Decoders.text)+            <*> Decoders.column (Decoders.nonNullable Decoders.text)+            <*> Decoders.column (Decoders.nonNullable Decoders.text)+        )+    )++historyAuditCountStatement :: LedgerConfig -> Statement.Statement () Int64+historyAuditCountStatement config =+  Statement.unpreparable+    ("SELECT count(*) FROM " <> quotedSchema config <> ".history_imports")+    Encoders.noParams+    (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.int8)))++historyAuditEvidenceStatement :: LedgerConfig -> Statement.Statement () (Int64, Bool, Bool)+historyAuditEvidenceStatement config =+  Statement.unpreparable+    ( Text.unwords+        [ "SELECT count(*),",+          "bool_and(h.source_evidence #>> '{satisfying_evidence,0,applied_at,kind}' = 'local-without-zone'),",+          "bool_and(m.started_at = m.finished_at AND m.started_at = h.imported_at)",+          "FROM",+          quotedSchema config <> ".history_imports h",+          "JOIN",+          quotedSchema config <> ".migrations m USING (component, migration)"+        ]+    )+    Encoders.noParams+    ( Decoders.singleRow+        ( (,,)+            <$> Decoders.column (Decoders.nonNullable Decoders.int8)+            <*> Decoders.column (Decoders.nonNullable Decoders.bool)+            <*> Decoders.column (Decoders.nonNullable Decoders.bool)+        )+    )++stateTableExistsStatement :: Statement.Statement Text Bool+stateTableExistsStatement =+  Statement.preparable+    "SELECT to_regclass($1) IS NOT NULL"+    (Encoders.param (Encoders.nonNullable Encoders.text))+    (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.bool)))++indexExistsStatement :: Statement.Statement Text Bool+indexExistsStatement =+  Statement.preparable+    """+    SELECT EXISTS+    (+      SELECT 1+      FROM pg_indexes+      WHERE schemaname = $1+        AND indexname = 'idx_nontransactional'+    )+    """+    (Encoders.param (Encoders.nonNullable Encoders.text))+    (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.bool)))++retryIndexExistsStatement :: Statement.Statement Text Bool+retryIndexExistsStatement =+  Statement.preparable+    """+    SELECT EXISTS+    (+      SELECT 1+      FROM pg_indexes+      WHERE schemaname = $1+        AND indexname = 'idx_repair_retry'+    )+    """+    (Encoders.param (Encoders.nonNullable Encoders.text))+    (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.bool)))++setFutureVersionSql :: LedgerConfig -> Text+setFutureVersionSql config =+  "UPDATE "+    <> quotedSchema config+    <> ".\"ledger_metadata\" SET schema_version = "+    <> Text.pack (show (currentLedgerVersion + 1))++qualifiedMigrationsTable :: LedgerConfig -> Text+qualifiedMigrationsTable config = quotedSchema config <> ".\"migrations\""++quotedSchema :: LedgerConfig -> Text+quotedSchema config = quotePostgresIdentifier (PostgresIdentifier (ledgerSchemaText config))++ledgerSchema :: LedgerConfig -> Text+ledgerSchema = ledgerSchemaText++integrationPlan :: MigrationPlan+integrationPlan =+  requireRight+    ( migrationPlan+        ( requireRight+            ( migrationComponent+                "integration"+                Set.empty+                (requireRight (sqlMigration "0001" "SELECT 1") :| [])+            )+            :| []+        )+    )++uniqueSuffix :: IO Text+uniqueSuffix = do+  now <- getPOSIXTime+  pure (Text.pack (show (floor (realToFrac now * (1000000 :: Double)) :: Integer)))++requireRight :: (Show error) => Either error value -> value+requireRight = \case+  Left err -> error (show err)+  Right value -> value++isLeft :: Either left right -> Bool+isLeft = \case+  Left _ -> True+  Right _ -> False++requireMigrationRight :: Either MigrationError value -> IO value+requireMigrationRight = \case+  Left migrationError -> assertFailure (show migrationError) >> error "assertFailure returned"+  Right value -> pure value++requireCleanupRight :: Either CleanupIssue () -> IO ()+requireCleanupRight = \case+  Left cleanupIssue -> assertFailure (show cleanupIssue)+  Right () -> pure ()++requireRunRight :: Either MigrationError MigrationReport -> IO MigrationReport+requireRunRight = \case+  Left migrationError -> assertFailure (show migrationError) >> error "assertFailure returned"+  Right report -> pure report++requireRepairRight :: Either RepairError RepairReport -> IO RepairReport+requireRepairRight = \case+  Left repairError -> assertFailure (show repairError) >> error "assertFailure returned"+  Right report -> pure report++requireHistoryRight :: Either HistoryImportError HistoryImportReport -> IO HistoryImportReport+requireHistoryRight = \case+  Left importError -> assertFailure (show importError) >> error "assertFailure returned"+  Right report -> pure report++requireThreadRun ::+  Either SomeException (Either MigrationError MigrationReport) ->+  IO MigrationReport+requireThreadRun = \case+  Left exception -> assertFailure (show exception) >> error "assertFailure returned"+  Right result -> requireRunRight result++assertDatabaseSessionFailure :: Either MigrationError MigrationReport -> IO ()+assertDatabaseSessionFailure = \case+  Left DatabaseSessionFailed {} -> pure ()+  Left migrationError -> assertFailure ("expected DatabaseSessionFailed, received " <> show migrationError)+  Right report -> assertFailure ("expected DatabaseSessionFailed, received " <> show report)++assertTransactionCondemned :: Either MigrationError MigrationReport -> IO ()+assertTransactionCondemned = \case+  Left TransactionCondemned {} -> pure ()+  Left migrationError -> assertFailure ("expected TransactionCondemned, received " <> show migrationError)+  Right report -> assertFailure ("expected TransactionCondemned, received " <> show report)++assertNonTransactionalFailure :: Either MigrationError MigrationReport -> IO ()+assertNonTransactionalFailure = \case+  Left NonTransactionalMigrationFailed {} -> pure ()+  Left migrationError -> assertFailure ("expected NonTransactionalMigrationFailed, received " <> show migrationError)+  Right report -> assertFailure ("expected NonTransactionalMigrationFailed, received " <> show report)++assertPlanVerificationFailure :: Either MigrationError MigrationReport -> IO ()+assertPlanVerificationFailure = \case+  Left PlanVerificationFailed {} -> pure ()+  Left migrationError -> assertFailure ("expected PlanVerificationFailed, received " <> show migrationError)+  Right report -> assertFailure ("expected PlanVerificationFailed, received " <> show report)++assertRepairTransactional :: Either RepairError RepairReport -> IO ()+assertRepairTransactional = \case+  Left RepairTargetTransactional {} -> pure ()+  Left repairError -> assertFailure ("expected RepairTargetTransactional, received " <> show repairError)+  Right report -> assertFailure ("expected RepairTargetTransactional, received " <> show report)++assertRepairMetadataMismatch :: Either RepairError RepairReport -> IO ()+assertRepairMetadataMismatch = \case+  Left RepairTargetMetadataMismatch {} -> pure ()+  Left repairError -> assertFailure ("expected RepairTargetMetadataMismatch, received " <> show repairError)+  Right report -> assertFailure ("expected RepairTargetMetadataMismatch, received " <> show report)++assertRepairMissing :: Either RepairError RepairReport -> IO ()+assertRepairMissing = \case+  Left RepairTargetMissing {} -> pure ()+  Left repairError -> assertFailure ("expected RepairTargetMissing, received " <> show repairError)+  Right report -> assertFailure ("expected RepairTargetMissing, received " <> show report)++assertRepairAlreadyApplied :: Either RepairError RepairReport -> IO ()+assertRepairAlreadyApplied = \case+  Left RepairTargetAlreadyApplied {} -> pure ()+  Left repairError -> assertFailure ("expected RepairTargetAlreadyApplied, received " <> show repairError)+  Right report -> assertFailure ("expected RepairTargetAlreadyApplied, received " <> show report)++assertRepairRunFailure :: Either RepairError RepairReport -> IO ()+assertRepairRunFailure = \case+  Left (RepairRunnerError NonTransactionalMigrationFailed {}) -> pure ()+  Left repairError -> assertFailure ("expected repaired action failure, received " <> show repairError)+  Right report -> assertFailure ("expected repaired action failure, received " <> show report)++assertHistoryConflict :: MigrationId -> Either HistoryImportError HistoryImportReport -> IO ()+assertHistoryConflict expected = \case+  Left (HistoryImportConflict actual) -> actual @?= expected+  Left importError -> assertFailure ("expected HistoryImportConflict, received " <> show importError)+  Right report -> assertFailure ("expected HistoryImportConflict, received " <> show report)++assertHistoryDatabaseFailure :: Either HistoryImportError HistoryImportReport -> IO ()+assertHistoryDatabaseFailure = \case+  Left (HistoryImportRunnerError DatabaseSessionFailed {}) -> pure ()+  Left importError -> assertFailure ("expected history database failure, received " <> show importError)+  Right report -> assertFailure ("expected history database failure, received " <> show report)++assertEquivalentDisallowed :: MigrationId -> Either HistoryImportError HistoryImportReport -> IO ()+assertEquivalentDisallowed expected = \case+  Left (HistoryImportValidationFailed (HistoryEquivalentStateDisallowed actual)) -> actual @?= expected+  Left importError -> assertFailure ("expected HistoryEquivalentStateDisallowed, received " <> show importError)+  Right report -> assertFailure ("expected HistoryEquivalentStateDisallowed, received " <> show report)++assertStateValidationFailure :: EvidenceKey -> Either HistoryImportError HistoryImportReport -> IO ()+assertStateValidationFailure expected = \case+  Left (HistoryStateValidationFailed actual _) -> actual @?= expected+  Left importError -> assertFailure ("expected HistoryStateValidationFailed, received " <> show importError)+  Right report -> assertFailure ("expected HistoryStateValidationFailed, received " <> show report)++assertEventHandlerFailure :: Either MigrationError MigrationReport -> IO ()+assertEventHandlerFailure = \case+  Left (EventHandlerFailed Nothing _) -> pure ()+  Left migrationError -> assertFailure ("expected EventHandlerFailed, received " <> show migrationError)+  Right report -> assertFailure ("expected EventHandlerFailed, received " <> show report)++assertLockUnavailable :: Either MigrationError value -> IO ()+assertLockUnavailable = \case+  Left AdvisoryLockUnavailable -> pure ()+  Left migrationError -> assertFailure ("expected AdvisoryLockUnavailable, received " <> show migrationError)+  Right _ -> assertFailure "expected AdvisoryLockUnavailable, received Right"++assertLockTimedOut :: Either MigrationError value -> IO ()+assertLockTimedOut = \case+  Left (AdvisoryLockTimedOut timeout) -> timeout @?= 0.12+  Left migrationError -> assertFailure ("expected AdvisoryLockTimedOut, received " <> show migrationError)+  Right _ -> assertFailure "expected AdvisoryLockTimedOut, received Right"++assertSuccessfulEventOrder :: [MigrationEvent] -> IO ()+assertSuccessfulEventOrder = \case+  [ LockWaitStarted WaitIndefinitely,+    LockAcquired lockDuration,+    PlanValidated 0 2,+    MigrationStarted firstId,+    MigrationCompleted firstCompleted firstDuration,+    MigrationStarted secondId,+    MigrationCompleted secondCompleted secondDuration,+    MigrationPlanCompleted planDuration+    ] -> do+      let expectedFirst = requireRight (Migrate.migrationId "events" "0001-create")+          expectedSecond = requireRight (Migrate.migrationId "events" "0002-insert")+      firstId @?= expectedFirst+      firstCompleted @?= expectedFirst+      secondId @?= expectedSecond+      secondCompleted @?= expectedSecond+      assertNonnegative "lock duration" lockDuration+      assertNonnegative "first migration duration" firstDuration+      assertNonnegative "second migration duration" secondDuration+      assertNonnegative "plan duration" planDuration+  events -> assertFailure ("unexpected event order: " <> show events)++assertNonnegative :: String -> NominalDiffTime -> IO ()+assertNonnegative label duration =+  assertBool (label <> " was negative: " <> show duration) (duration >= 0)++uniqueLockKey :: IO Int64+uniqueLockKey = do+  now <- getPOSIXTime+  let microseconds = floor (realToFrac now * (1000000 :: Double)) :: Integer+  pure (testLockKey + fromIntegral (microseconds `mod` 1000000))++reportOutcomes :: MigrationReport -> [MigrationOutcome]+reportOutcomes MigrationReport {results} =+  (\MigrationResult {outcome} -> outcome) <$> toList results++historyOutcomes :: HistoryImportReport -> [(MigrationId, HistoryImportOutcome)]+historyOutcomes HistoryImportReport {importResults} =+  [(importedMigration, importOutcome) | HistoryImportResult {importedMigration, importOutcome} <- toList importResults]++storedStatuses :: LedgerSnapshot -> [MigrationStatus]+storedStatuses LedgerSnapshot {storedMigrations} =+  (\StoredMigration {status} -> status) <$> storedMigrations++sqlPlan :: Text -> [(Text, Text)] -> MigrationPlan+sqlPlan component entries =+  planFromMigrations+    component+    [ requireRight (sqlMigration name (Text.Encoding.encodeUtf8 sql))+    | (name, sql) <- entries+    ]++planFromMigrations :: Text -> [Migration] -> MigrationPlan+planFromMigrations component migrations =+  case NonEmpty.nonEmpty migrations of+    Nothing -> error "planFromMigrations requires at least one migration"+    Just nonEmptyMigrations ->+      requireRight+        ( migrationPlan+            ( requireRight+                (migrationComponent component Set.empty nonEmptyMigrations)+                :| []+            )+        )++historyOptions :: LedgerConfig -> ImportOptions+historyOptions config =+  withImportRunOptions (withLedger config defaultRunOptions) defaultImportOptions++historySqlPlan :: LedgerConfig -> MigrationPlan+historySqlPlan config =+  sqlPlan+    "history-import"+    [ ("0001-one", "CREATE TABLE " <> quotedSchema config <> ".import_action_1 (value integer)"),+      ("0002-two", "CREATE TABLE " <> quotedSchema config <> ".import_action_2 (value integer)"),+      ("0003-three", "CREATE TABLE " <> quotedSchema config <> ".import_action_3 (value integer)")+    ]++historySqlImport :: LedgerConfig -> Bool -> HistoryImport+historySqlImport config changed =+  requireRight+    ( historyImport+        "legacy-engine"+        (Map.fromList [(historyEvidenceKey number, historyEvidence number) | number <- [1 .. 3]])+        []+        (historyMappingFor 1 :| [historyMappingFor 2])+        "verified staging cutover"+    )+  where+    historyEvidence number =+      requireRight+        ( sourceManifestVerifiedEvidence+            ("legacy/000" <> Text.pack (show number) <> ".sql")+            (Just (LocalTimeWithoutZone (read "2020-01-02 03:04:05" :: LocalTime)))+            (Just (migrationFingerprint (historySqlBytes config number)))+            ( Aeson.object+                [ "ordinal" Aeson..= number,+                  "revision" Aeson..= if changed && number == (1 :: Int) then (2 :: Int) else 1+                ]+            )+        )+    historyMappingFor number =+      historyMapping+        (historyTarget number)+        (Evidence (historyEvidenceKey number))+        (SamePayload (historyEvidenceKey number))++historySqlBytes :: LedgerConfig -> Int -> ByteString+historySqlBytes config number =+  Text.Encoding.encodeUtf8+    ( case number of+        1 -> "CREATE TABLE " <> quotedSchema config <> ".import_action_1 (value integer)"+        2 -> "CREATE TABLE " <> quotedSchema config <> ".import_action_2 (value integer)"+        _ -> "CREATE TABLE " <> quotedSchema config <> ".import_action_3 (value integer)"+    )++historyTarget :: Int -> MigrationId+historyTarget number =+  requireRight+    ( Migrate.migrationId+        "history-import"+        (case number of 1 -> "0001-one"; 2 -> "0002-two"; _ -> "0003-three")+    )++historyEvidenceKey :: Int -> EvidenceKey+historyEvidenceKey number = requireRight (evidenceKey ("legacy:000" <> Text.pack (show number)))++historyStateKey :: EvidenceKey+historyStateKey = requireRight (evidenceKey "legacy:state")++historyHaskellTarget :: MigrationId+historyHaskellTarget = requireRight (Migrate.migrationId "history-equivalent" "0001-haskell")++equivalentHistoryPlan :: LedgerConfig -> StateValidator -> (MigrationPlan, HistoryImport)+equivalentHistoryPlan config validator =+  ( planFromMigrations "history-equivalent" [migration],+    requireRight+      ( historyImport+          "legacy-engine"+          Map.empty+          [validator]+          (historyMapping historyHaskellTarget (Evidence historyStateKey) EquivalentState :| [])+          "domain state verified"+      )+  )+  where+    migration =+      requireRight+        ( transactionMigration+            "0001-haskell"+            (migrationFingerprint "history-haskell-v1")+            (Transaction.sql (Text.Encoding.encodeUtf8 ("CREATE TABLE " <> quotedSchema config <> ".haskell_action (value integer)")))+        )++missingIndexPlan :: LedgerConfig -> Text -> Text -> Text -> MigrationPlan+missingIndexPlan config component indexName tableName =+  sqlPlan+    component+    [ ( "0001-index",+        Text.unlines+          [ "-- pg-migrate: no-transaction",+            "CREATE INDEX CONCURRENTLY " <> indexName <> " ON",+            quotedSchema config <> "." <> tableName <> " (value)"+          ]+      )+    ]++crashMigrationPlan :: LedgerConfig -> MigrationPlan+crashMigrationPlan _ =+  sqlPlan+    "crash-helper"+    [ ( "0001-sleep",+        "-- pg-migrate: no-transaction\nSELECT pg_sleep(2)"+      )+    ]++waitForRunning :: Connection.Connection -> LedgerConfig -> Int -> IO ()+waitForRunning _ _ 0 = assertFailure "crash helper did not persist Running within fifteen seconds"+waitForRunning connection config attempts = do+  snapshot <- useSession connection (loadLedger config)+  if storedStatuses snapshot == [Running]+    then pure ()+    else do+      threadDelay 25000+      waitForRunning connection config (attempts - 1)++integrationRunnerVersion :: Text+integrationRunnerVersion = "pg-migrate-integration"++testLockKey :: Int64+testLockKey = 0x70675F6D74657374
+ test/unit/Main.hs view
@@ -0,0 +1,26 @@+module Main (main) where++import PgMigrate.Prelude ()+import Test.Definition qualified as Definition+import Test.History qualified as History+import Test.Ledger qualified as Ledger+import Test.Plan qualified as Plan+import Test.PublicApi qualified as PublicApi+import Test.Runner qualified as Runner+import Test.Sql qualified as Sql+import Test.Tasty (defaultMain, testGroup)++main :: IO ()+main =+  defaultMain+    ( testGroup+        "pg-migrate"+        [ Definition.tests,+          History.tests,+          Ledger.tests,+          Plan.tests,+          PublicApi.tests,+          Runner.tests,+          Sql.tests+        ]+    )
+ test/unit/Test/Definition.hs view
@@ -0,0 +1,129 @@+module Test.Definition (tests) where++import Data.ByteString qualified as ByteString+import Data.Set qualified as Set+import Data.Text qualified as Text+import Database.PostgreSQL.Migrate+import Database.PostgreSQL.Migrate.Internal (migrationChecksumBytes)+import PgMigrate.Prelude+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))++tests :: TestTree+tests =+  testGroup+    "definition"+    [ testGroup+        "component names"+        (fmap invalidComponentCase invalidIdentifierCases),+      testGroup+        "migration names"+        (fmap invalidMigrationCase invalidIdentifierCases),+      testCase "printable internal spaces are valid" $+        assertRight (componentName "event store"),+      testCase "migration identity validates both names" $+        assertRight (migrationId "event-store" "0001-bootstrap"),+      testCase "SHA-256 uses the exact input bytes" $+        migrationChecksumBytes (migrationFingerprint "abc") @?= sha256Abc,+      testCase "fingerprints are deterministic" $+        migrationFingerprint "version-1" @?= migrationFingerprint "version-1",+      testCase "different fingerprints differ" $+        assertBool+          "different inputs must not share this fingerprint"+          (migrationFingerprint "version-1" /= migrationFingerprint "version-2"),+      testCase "transaction migrations validate their local name" $+        assertDefinitionLeft+          (InvalidMigrationName " bad" IdentifierHasSurroundingWhitespace)+          (transactionMigration " bad" (migrationFingerprint "v1") (pure ())),+      testCase "session migrations validate their local name" $+        assertDefinitionLeft+          (InvalidMigrationName "bad/part" IdentifierContainsSlash)+          (sessionMigration "bad/part" (migrationFingerprint "v1") (pure ())),+      testCase "component dependencies use component-name validation" $+        assertDefinitionLeft+          (InvalidComponentName " invalid" IdentifierHasSurroundingWhitespace)+          ( migrationComponent+              "owner"+              (Set.singleton " invalid")+              (validMigration :| [])+          )+    ]++invalidIdentifierCases :: [(Text, IdentifierError)]+invalidIdentifierCases =+  [ ("", EmptyIdentifier),+    (" event-store", IdentifierHasSurroundingWhitespace),+    ("event-store ", IdentifierHasSurroundingWhitespace),+    ("event/store", IdentifierContainsSlash),+    (Text.replicate 201 "a", IdentifierTooLong 201 200),+    ("event\nstore", IdentifierContainsNonPrintableAscii '\n'),+    ("café", IdentifierContainsNonPrintableAscii 'é')+  ]++invalidComponentCase :: (Text, IdentifierError) -> TestTree+invalidComponentCase (input, reason) =+  testCase (Text.unpack (caseLabel input)) $+    componentName input @?= Left (InvalidComponentName input reason)++invalidMigrationCase :: (Text, IdentifierError) -> TestTree+invalidMigrationCase (input, reason) =+  testCase (Text.unpack (caseLabel input)) $+    migrationName input @?= Left (InvalidMigrationName input reason)++caseLabel :: Text -> Text+caseLabel value+  | Text.null value = "empty"+  | otherwise = Text.pack (show value)++assertRight :: (Show error) => Either error value -> IO ()+assertRight = \case+  Left err -> fail ("expected Right, received Left " <> show err)+  Right _ -> pure ()++assertDefinitionLeft :: DefinitionError -> Either DefinitionError value -> IO ()+assertDefinitionLeft expected = \case+  Left actual -> actual @?= expected+  Right _ -> assertFailure ("expected Left " <> show expected <> ", received Right")++validMigration :: Migration+validMigration =+  case transactionMigration "0001-bootstrap" (migrationFingerprint "v1") (pure ()) of+    Left err -> error (show err)+    Right migration -> migration++sha256Abc :: ByteString+sha256Abc =+  ByteString.pack+    [ 0xBA,+      0x78,+      0x16,+      0xBF,+      0x8F,+      0x01,+      0xCF,+      0xEA,+      0x41,+      0x41,+      0x40,+      0xDE,+      0x5D,+      0xAE,+      0x22,+      0x23,+      0xB0,+      0x03,+      0x61,+      0xA3,+      0x96,+      0x17,+      0x7A,+      0x9C,+      0xB4,+      0x10,+      0xFF,+      0x61,+      0xF2,+      0x00,+      0x15,+      0xAD+    ]
+ test/unit/Test/History.hs view
@@ -0,0 +1,368 @@+module Test.History (tests) where++import Data.Aeson qualified as Aeson+import Data.List.NonEmpty (NonEmpty (..))+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text.Encoding+import Database.PostgreSQL.Migrate+import Database.PostgreSQL.Migrate.Internal+  ( ResolvedHistoryMapping (..),+    resolveHistoryImport,+    stateVerifiedEvidence,+  )+import PgMigrate.Prelude ()+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertFailure, testCase, (@?=))++tests :: TestTree+tests =+  testGroup+    "history"+    [ testCase "evidence keys are non-empty" testEvidenceKey,+      testCase "static evidence identities are non-empty" testEvidenceIdentity,+      testCase "imports require source and reason" testSourceAndReason,+      testCase "state validators cannot collide with static evidence" testValidatorCollision,+      testCase "mapping targets are unique" testUniqueTargets,+      testCase "requirements reference known evidence" testKnownRequirement,+      testCase "same-payload evidence participates in its requirement" testSamePayloadRequirement,+      testCase "equivalent history is rejected by default" testEquivalentDefault,+      testCase "same-payload prefixes resolve from target metadata" testResolvePrefix,+      testCase "each affected component resolves its own prefix" testMultiComponentPrefix,+      testCase "component gaps are rejected" testPrefixGap,+      testCase "unknown targets are rejected" testUnknownTarget,+      testCase "payload checksum mismatches are rejected" testChecksumMismatch,+      testCase "same-payload cannot import Haskell migrations" testHaskellSamePayload,+      testCase "equivalent state requires policy and verified evidence" testEquivalentState,+      testCase "multiple satisfied AnyOf branches are ambiguous" testAmbiguousRequirement+    ]++testEvidenceKey :: IO ()+testEvidenceKey = do+  evidenceKey " " @?= Left EmptyEvidenceKey+  evidenceKey "legacy:0001" @?= Right (requireEvidenceKey "legacy:0001")++testEvidenceIdentity :: IO ()+testEvidenceIdentity =+  ledgerOnlyEvidence "" Nothing Nothing Aeson.Null @?= Left EmptyEvidenceIdentity++testSourceAndReason :: IO ()+testSourceAndReason = do+  assertDefinitionError EmptyHistorySource (historyImport "" evidenceMap [] (mapping :| []) "reason")+  assertDefinitionError EmptyHistoryReason (historyImport "source" evidenceMap [] (mapping :| []) " ")++testValidatorCollision :: IO ()+testValidatorCollision =+  assertDefinitionError+    (EvidenceKeyCollision key)+    ( historyImport+        "source"+        evidenceMap+        [stateValidator key (pure (Right Aeson.Null))]+        (mapping :| [])+        "reason"+    )++testUniqueTargets :: IO ()+testUniqueTargets =+  assertDefinitionError+    (DuplicateHistoryTarget targetId)+    (historyImport "source" evidenceMap [] (mapping :| [mapping]) "reason")++testKnownRequirement :: IO ()+testKnownRequirement =+  assertDefinitionError+    (UnknownRequirementEvidence unknownKey)+    ( historyImport+        "source"+        evidenceMap+        []+        (historyMapping targetId (Evidence unknownKey) (SamePayload unknownKey) :| [])+        "reason"+    )++testSamePayloadRequirement :: IO ()+testSamePayloadRequirement =+  assertDefinitionError+    (SamePayloadEvidenceNotRequired otherKey)+    ( historyImport+        "source"+        evidenceWithOther+        []+        (historyMapping targetId (Evidence key) (SamePayload otherKey) :| [])+        "reason"+    )+  where+    otherKey = requireEvidenceKey "legacy:other"+    evidenceWithOther = Map.fromList [(key, staticEvidence), (otherKey, staticEvidence)]++testEquivalentDefault :: IO ()+testEquivalentDefault =+  importEquivalentHistoryPolicy defaultImportOptions @?= RejectEquivalentHistory++testResolvePrefix :: IO ()+testResolvePrefix = do+  let imported = requireHistoryImport prefixEvidence [prefixMapping 1, prefixMapping 2] []+  resolved <- requireValidationRight (resolveHistoryImport RejectEquivalentHistory prefixPlan prefixEvidence imported)+  (resolvedPosition <$> resolved) @?= (1 :| [2])+  (resolvedChecksum <$> resolved)+    @?= (migrationFingerprint "SELECT 1" :| [migrationFingerprint "SELECT 2"])++testMultiComponentPrefix :: IO ()+testMultiComponentPrefix = do+  let firstKey = requireEvidenceKey "legacy:first"+      secondKey = requireEvidenceKey "legacy:second"+      firstTarget = requireRight (migrationId "history-first" "0001-one")+      secondTarget = requireRight (migrationId "history-second" "0001-one")+      firstChecksum = migrationFingerprint "SELECT 'first'"+      secondChecksum = migrationFingerprint "SELECT 'second'"+      available =+        Map.fromList+          [ (firstKey, requireRight (sourceManifestVerifiedEvidence "first" Nothing (Just firstChecksum) Aeson.Null)),+            (secondKey, requireRight (sourceManifestVerifiedEvidence "second" Nothing (Just secondChecksum) Aeson.Null))+          ]+      imported =+        requireRight+          ( historyImport+              "legacy"+              available+              []+              ( historyMapping firstTarget (Evidence firstKey) (SamePayload firstKey)+                  :| [historyMapping secondTarget (Evidence secondKey) (SamePayload secondKey)]+              )+              "cutover"+          )+      firstComponent =+        requireRight+          ( migrationComponent+              "history-first"+              Set.empty+              (requireRight (sqlMigration "0001-one" "SELECT 'first'") :| [])+          )+      secondComponent =+        requireRight+          ( migrationComponent+              "history-second"+              Set.empty+              (requireRight (sqlMigration "0001-one" "SELECT 'second'") :| [])+          )+      plan = requireRight (migrationPlan (firstComponent :| [secondComponent]))+  resolved <- requireValidationRight (resolveHistoryImport RejectEquivalentHistory plan available imported)+  (resolvedPosition <$> resolved) @?= (1 :| [1])++testPrefixGap :: IO ()+testPrefixGap = do+  let imported = requireHistoryImport prefixEvidence [prefixMapping 1, prefixMapping 3] []+  resolveHistoryImport RejectEquivalentHistory prefixPlan prefixEvidence imported+    @?= Left (HistoryComponentPrefixGap (requireRight (componentName "history-prefix")) 2)++testUnknownTarget :: IO ()+testUnknownTarget = do+  let unknown = requireRight (migrationId "history-prefix" "9999-unknown")+      imported =+        requireRight+          ( historyImport+              "legacy"+              prefixEvidence+              []+              (historyMapping unknown (Evidence (prefixKey 1)) (SamePayload (prefixKey 1)) :| [])+              "cutover"+          )+  resolveHistoryImport RejectEquivalentHistory prefixPlan prefixEvidence imported+    @?= Left (HistoryTargetUnknown unknown)++testChecksumMismatch :: IO ()+testChecksumMismatch = do+  let mismatchedEvidence =+        Map.singleton+          (prefixKey 1)+          ( requireRight+              ( sourceManifestVerifiedEvidence+                  "legacy/0001.sql"+                  Nothing+                  (Just (migrationFingerprint "SELECT changed"))+                  Aeson.Null+              )+          )+      imported = requireHistoryImport mismatchedEvidence [prefixMapping 1] []+  resolveHistoryImport RejectEquivalentHistory prefixPlan mismatchedEvidence imported+    @?= Left (HistoryPayloadChecksumMismatch (prefixTarget 1) (prefixKey 1))++testHaskellSamePayload :: IO ()+testHaskellSamePayload = do+  let target = requireRight (migrationId "history-haskell" "0001-action")+      checksum = migrationFingerprint "haskell-v1"+      sourceEvidence =+        Map.singleton+          key+          (requireRight (sourceManifestVerifiedEvidence "legacy-action" Nothing (Just checksum) Aeson.Null))+      imported =+        requireRight+          ( historyImport+              "legacy"+              sourceEvidence+              []+              (historyMapping target (Evidence key) (SamePayload key) :| [])+              "cutover"+          )+      migration = requireRight (transactionMigration "0001-action" checksum (pure ()))+      component = requireRight (migrationComponent "history-haskell" Set.empty (migration :| []))+      plan = requireRight (migrationPlan (component :| []))+  resolveHistoryImport RejectEquivalentHistory plan sourceEvidence imported+    @?= Left (HistorySamePayloadForHaskell target)++testEquivalentState :: IO ()+testEquivalentState = do+  let target = prefixTarget 1+      verified = stateVerifiedEvidence key (Aeson.object ["table" Aeson..= ("ready" :: Text)])+      available = Map.singleton key verified+      validator = stateValidator key (pure (Right Aeson.Null))+      imported =+        requireRight+          ( historyImport+              "legacy"+              Map.empty+              [validator]+              (historyMapping target (Evidence key) EquivalentState :| [])+              "cutover"+          )+  resolveHistoryImport RejectEquivalentHistory prefixPlan available imported+    @?= Left (HistoryEquivalentStateDisallowed target)+  _ <- requireValidationRight (resolveHistoryImport AllowEquivalentHistory prefixPlan available imported)+  pure ()++testAmbiguousRequirement :: IO ()+testAmbiguousRequirement = do+  let secondKey = requireEvidenceKey "legacy:second"+      available = Map.fromList [(key, prefixEvidence Map.! prefixKey 1), (secondKey, prefixEvidence Map.! prefixKey 1)]+      target = prefixTarget 1+      imported =+        requireRight+          ( historyImport+              "legacy"+              available+              []+              ( historyMapping+                  target+                  (AnyOf (Evidence key :| [Evidence secondKey]))+                  (SamePayload key)+                  :| []+              )+              "cutover"+          )+  resolveHistoryImport RejectEquivalentHistory prefixPlan available imported+    @?= Left (HistoryRequirementAmbiguous target)++key :: EvidenceKey+key = requireEvidenceKey "legacy:0001"++unknownKey :: EvidenceKey+unknownKey = requireEvidenceKey "legacy:unknown"++targetId :: MigrationId+targetId = requireRight (migrationId "history" "0001")++staticEvidence :: ImportEvidence+staticEvidence =+  requireRight+    (sourceManifestVerifiedEvidence "legacy/0001.sql" Nothing Nothing Aeson.Null)++evidenceMap :: Map.Map EvidenceKey ImportEvidence+evidenceMap = Map.singleton key staticEvidence++mapping :: HistoryMapping+mapping = historyMapping targetId (Evidence key) (SamePayload key)++prefixPlan :: MigrationPlan+prefixPlan =+  requireRight+    ( migrationPlan+        ( requireRight+            ( migrationComponent+                "history-prefix"+                Set.empty+                ( requireRight (sqlMigration "0001-one" "SELECT 1")+                    :| [ requireRight (sqlMigration "0002-two" "SELECT 2"),+                         requireRight (sqlMigration "0003-three" "SELECT 3")+                       ]+                )+            )+            :| []+        )+    )++prefixEvidence :: Map.Map EvidenceKey ImportEvidence+prefixEvidence =+  Map.fromList+    [ ( prefixKey number,+        requireRight+          ( sourceManifestVerifiedEvidence+              ("legacy/000" <> showText number <> ".sql")+              Nothing+              (Just (migrationFingerprint (Text.Encoding.encodeUtf8 ("SELECT " <> showText number))))+              Aeson.Null+          )+      )+    | number <- [1 .. 3]+    ]++prefixKey :: Int -> EvidenceKey+prefixKey number = requireEvidenceKey ("legacy:000" <> showText number)++prefixTarget :: Int -> MigrationId+prefixTarget number =+  requireRight (migrationId "history-prefix" ("000" <> showText number <> "-" <> suffix number))+  where+    suffix 1 = "one"+    suffix 2 = "two"+    suffix _ = "three"++prefixMapping :: Int -> HistoryMapping+prefixMapping number =+  historyMapping+    (prefixTarget number)+    (Evidence (prefixKey number))+    (SamePayload (prefixKey number))++requireHistoryImport ::+  Map.Map EvidenceKey ImportEvidence ->+  [HistoryMapping] ->+  [StateValidator] ->+  HistoryImport+requireHistoryImport available importedMappings importedValidators =+  requireRight+    ( historyImport+        "legacy"+        available+        importedValidators+        (case importedMappings of firstMapping : rest -> firstMapping :| rest; [] -> error "empty mappings")+        "cutover"+    )++showText :: (Show value) => value -> Text+showText = Text.pack . show++requireEvidenceKey :: Text -> EvidenceKey+requireEvidenceKey = requireRight . evidenceKey++requireRight :: (Show error) => Either error value -> value+requireRight = \case+  Left err -> error (show err)+  Right value -> value++assertDefinitionError ::+  HistoryDefinitionError ->+  Either HistoryDefinitionError HistoryImport ->+  IO ()+assertDefinitionError expected = \case+  Left actual -> actual @?= expected+  Right _ -> assertFailure ("expected " <> show expected <> ", received Right")++requireValidationRight ::+  Either HistoryValidationError value ->+  IO value+requireValidationRight = \case+  Left err -> assertFailure (show err) >> error "assertFailure returned"+  Right value -> pure value
+ test/unit/Test/Ledger.hs view
@@ -0,0 +1,324 @@+module Test.Ledger (tests) where++import Data.Int (Int64)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Set qualified as Set+import Data.Text qualified as Text+import Data.Time (UTCTime (..), fromGregorian)+import Database.PostgreSQL.Migrate+import Database.PostgreSQL.Migrate qualified as Migrate+import Database.PostgreSQL.Migrate.Internal+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertFailure, testCase, (@?=))++tests :: TestTree+tests =+  testGroup+    "ledger"+    [ testCase "default configuration is valid" testDefaultConfiguration,+      testCase "custom quoted identifiers are valid" testQuotedIdentifier,+      testCase "empty schema identifiers are rejected" testEmptyIdentifier,+      testCase "NUL schema identifiers are rejected" testNulIdentifier,+      testCase "PostgreSQL's reserved schema prefix is rejected" testReservedIdentifier,+      testCase "schema identifiers use PostgreSQL's byte limit" testIdentifierLength,+      testCase "quoted identifiers escape embedded quotes" testIdentifierQuoting,+      testCase "ledger upgrade paths are ordered and bounded" testUpgradePath,+      testCase "an applied prefix leaves the remainder pending" testAppliedPrefix,+      testCase "comparison reports every immutable metadata mismatch" testMetadataMismatches,+      testCase "running and failed rows remain pending and block progress" testInterruptedRows,+      testCase "duplicate identities and component positions are corrupt" testDuplicateRows,+      testCase "a stored migration after a gap is not a valid prefix" testPrefixGap,+      testCase "unknown history follows the explicit policy" testUnknownPolicy,+      testCase "strict verification rejects every pending migration" testPendingVerification,+      testCase "lenient status preserves unknown rows separately" testLenientStatus+    ]++testDefaultConfiguration :: IO ()+testDefaultConfiguration =+  defaultLedgerConfig @?= requireRight (ledgerConfig "pgmigrate" defaultLockKey)++testQuotedIdentifier :: IO ()+testQuotedIdentifier =+  assertRight (ledgerConfig "application \"migrations\"" 17)++testEmptyIdentifier :: IO ()+testEmptyIdentifier =+  ledgerConfig "" 17+    @?= Left+      InvalidLedgerSchema+        { input = "",+          postgresIdentifierReason = EmptyPostgresIdentifier+        }++testNulIdentifier :: IO ()+testNulIdentifier =+  ledgerConfig "invalid\NULschema" 17+    @?= Left+      InvalidLedgerSchema+        { input = "invalid\NULschema",+          postgresIdentifierReason = PostgresIdentifierContainsNul+        }++testReservedIdentifier :: IO ()+testReservedIdentifier =+  ledgerConfig "pg_custom" 17+    @?= Left+      InvalidLedgerSchema+        { input = "pg_custom",+          postgresIdentifierReason = PostgresIdentifierHasReservedPrefix+        }++testIdentifierLength :: IO ()+testIdentifierLength =+  ledgerConfig tooLong 17+    @?= Left+      InvalidLedgerSchema+        { input = tooLong,+          postgresIdentifierReason =+            PostgresIdentifierTooLong+              { actualBytes = 64,+                maximumBytes = 63+              }+        }+  where+    tooLong = Text.replicate 64 "a"++testIdentifierQuoting :: IO ()+testIdentifierQuoting =+  quotePostgresIdentifier (PostgresIdentifier "application \"migrations\"")+    @?= "\"application \"\"migrations\"\"\""++testUpgradePath :: IO ()+testUpgradePath = do+  ledgerMigrationVersions @?= [1]+  ledgerUpgradePath 0 @?= Right [1]+  ledgerUpgradePath 1 @?= Right []+  ledgerUpgradePath 2+    @?= Left+      LedgerTooNew+        { databaseVersion = 2,+          supportedVersion = currentLedgerVersion+        }++testAppliedPrefix :: IO ()+testAppliedPrefix = do+  let (firstDescription, secondDescription) = twoDescriptions+      firstId = descriptionId firstDescription+      secondId = descriptionId secondDescription+  comparePlanWithLedger+    AllowUnknownMigrations+    twoPlanDescription+    [storedFromDescription Applied firstDescription]+    @?= VerificationReport+      { issues = [],+        appliedMigrations = [firstId],+        pendingMigrations = [secondId],+        unknownMigrations = []+      }++testMetadataMismatches :: IO ()+testMetadataMismatches = do+  let (firstDescription, _) = twoDescriptions+      firstId = descriptionId firstDescription+      expectedChecksum = descriptionChecksum firstDescription+      actualChecksum = migrationFingerprint "changed"+      actual =+        storedMigration+          firstDescription+          2+          actualChecksum+          HaskellKind+          NonTransactional+          Applied+  verificationIssues+    (comparePlanWithLedger AllowUnknownMigrations twoPlanDescription [actual])+    @?= [ MigrationPositionMismatch firstId 1 2,+          MigrationChecksumMismatch firstId expectedChecksum actualChecksum,+          MigrationKindMismatch firstId SqlKind HaskellKind,+          MigrationTransactionModeMismatch firstId Transactional NonTransactional+        ]++testInterruptedRows :: IO ()+testInterruptedRows = do+  let (firstDescription, secondDescription) = twoDescriptions+      firstId = descriptionId firstDescription+      secondId = descriptionId secondDescription+      report =+        comparePlanWithLedger+          AllowUnknownMigrations+          twoPlanDescription+          [ storedFromDescription Running firstDescription,+            storedFromDescription Failed secondDescription+          ]+  verificationIssues report+    @?= [StoredMigrationRunning firstId, StoredMigrationFailed secondId]+  verificationPending report @?= [firstId, secondId]++testDuplicateRows :: IO ()+testDuplicateRows = do+  let (firstDescription, secondDescription) = twoDescriptions+      firstId = descriptionId firstDescription+      owner = requireRight (componentName "owner")+      first = storedFromDescription Applied firstDescription+      secondAtFirstPosition =+        storedMigration+          secondDescription+          1+          (descriptionChecksum secondDescription)+          SqlKind+          Transactional+          Applied+  verificationIssues+    (comparePlanWithLedger AllowUnknownMigrations twoPlanDescription [first, first])+    @?= [DuplicateStoredMigration firstId, DuplicateStoredPosition owner 1]+  verificationIssues+    (comparePlanWithLedger AllowUnknownMigrations twoPlanDescription [first, secondAtFirstPosition])+    @?= [DuplicateStoredPosition owner 1, MigrationPositionMismatch (descriptionId secondDescription) 2 1]++testPrefixGap :: IO ()+testPrefixGap = do+  let (firstDescription, secondDescription) = twoDescriptions+      firstId = descriptionId firstDescription+      secondId = descriptionId secondDescription+  verificationIssues+    ( comparePlanWithLedger+        AllowUnknownMigrations+        twoPlanDescription+        [storedFromDescription Applied secondDescription]+    )+    @?= [AppliedMigrationAfterGap secondId firstId]++testUnknownPolicy :: IO ()+testUnknownPolicy = do+  let unknown = unknownStoredMigration+      unknownId = storedMigrationId unknown+  verificationIssues+    (comparePlanWithLedger RejectUnknownMigrations twoPlanDescription [unknown])+    @?= [UnknownStoredMigration unknownId]+  verificationIssues+    (comparePlanWithLedger AllowUnknownMigrations twoPlanDescription [unknown])+    @?= []++testPendingVerification :: IO ()+testPendingVerification = do+  let (firstDescription, secondDescription) = twoDescriptions+  verificationIssues+    (verifyFromSnapshot twoMigrationPlan LedgerSnapshot {metadata = Nothing, storedMigrations = []})+    @?= [ PendingMigration (descriptionId firstDescription),+          PendingMigration (descriptionId secondDescription)+        ]++testLenientStatus :: IO ()+testLenientStatus =+  case statusFromSnapshot+    twoMigrationPlan+    LedgerSnapshot {metadata = Nothing, storedMigrations = [unknownStoredMigration]} of+    StatusReport {issues, appliedMigrations, pendingMigrations, unknownMigrations} -> do+      issues @?= []+      appliedMigrations @?= []+      pendingMigrations+        @?= [ descriptionId (fst twoDescriptions),+              descriptionId (snd twoDescriptions)+            ]+      unknownMigrations @?= [unknownStoredMigration]++defaultLockKey :: Int64+defaultLockKey = 0x70675F6D69677261++requireRight :: (Show error) => Either error value -> value+requireRight = \case+  Left err -> error (show err)+  Right value -> value++assertRight :: (Show error) => Either error value -> IO ()+assertRight = \case+  Left err -> assertFailure (show err)+  Right _ -> pure ()++twoMigrationPlan :: MigrationPlan+twoMigrationPlan =+  requireRight+    ( migrationPlan+        ( requireRight+            ( migrationComponent+                "owner"+                Set.empty+                ( requireRight (sqlMigration "0001-first" "SELECT 1")+                    :| [requireRight (sqlMigration "0002-second" "SELECT 2")]+                )+            )+            :| []+        )+    )++twoPlanDescription :: PlanDescription+twoPlanDescription = planDescription twoMigrationPlan++twoDescriptions :: (MigrationDescription, MigrationDescription)+twoDescriptions =+  case twoPlanDescription of+    PlanDescription+      ( ComponentDescription+          { migrations = firstDescription :| [secondDescription]+          }+          :| []+        ) -> (firstDescription, secondDescription)+    other -> error ("unexpected test plan: " <> show other)++descriptionId :: MigrationDescription -> MigrationId+descriptionId MigrationDescription {migrationId = identifier} = identifier++descriptionChecksum :: MigrationDescription -> MigrationChecksum+descriptionChecksum MigrationDescription {checksum} = checksum++storedFromDescription :: MigrationStatus -> MigrationDescription -> StoredMigration+storedFromDescription status description@MigrationDescription {position, checksum, kind, transactionMode} =+  storedMigration description position checksum kind transactionMode status++storedMigration ::+  MigrationDescription ->+  Int ->+  MigrationChecksum ->+  MigrationKind ->+  TransactionMode ->+  MigrationStatus ->+  StoredMigration+storedMigration description position checksum kind transactionMode status =+  StoredMigration+    { storedMigrationId = descriptionId description,+      position,+      checksum,+      kind,+      transactionMode,+      status,+      startedAt = testTime,+      finishedAt = if status == Running then Nothing else Just testTime,+      executionTimeMilliseconds = if status == Running then Nothing else Just 0,+      errorMessage = if status == Failed then Just "failed" else Nothing,+      runnerVersion = "test"+    }++unknownStoredMigration :: StoredMigration+unknownStoredMigration =+  StoredMigration+    { storedMigrationId = requireRight (Migrate.migrationId "legacy" "0001"),+      position = 1,+      checksum = migrationFingerprint "legacy",+      kind = SqlKind,+      transactionMode = Transactional,+      status = Applied,+      startedAt = testTime,+      finishedAt = Just testTime,+      executionTimeMilliseconds = Just 0,+      errorMessage = Nothing,+      runnerVersion = "legacy"+    }++verificationIssues :: VerificationReport -> [VerificationIssue]+verificationIssues VerificationReport {issues} = issues++verificationPending :: VerificationReport -> [MigrationId]+verificationPending VerificationReport {pendingMigrations} = pendingMigrations++testTime :: UTCTime+testTime = UTCTime (fromGregorian 2026 7 10) 0
+ test/unit/Test/Plan.hs view
@@ -0,0 +1,198 @@+module Test.Plan (tests) where++import Data.List.NonEmpty qualified as NonEmpty+import Data.Set qualified as Set+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text.Encoding+import Database.PostgreSQL.Migrate+import Database.PostgreSQL.Migrate.Internal+import PgMigrate.Prelude+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertFailure, testCase, (@?=))+import Test.Tasty.QuickCheck qualified as QuickCheck++tests :: TestTree+tests =+  testGroup+    "plan"+    [ testCase "explicit plans preserve caller order" testExplicitOrder,+      QuickCheck.testProperty+        "explicit plans preserve every permutation of unrelated components"+        propertyExplicitOrder,+      testCase "duplicate component names have a distinct error" testDuplicateComponent,+      testCase "duplicate local migration names have a distinct error" testDuplicateMigration,+      testCase "identical local names in different components are valid" testLocalNameScope,+      testCase "missing dependencies have a distinct error" testMissingDependency,+      testCase "dependencies after consumers have a distinct error" testInvalidOrder,+      testCase "dependency cycles have a distinct error" testCycle,+      testCase "stable resolution changes only constrained order" testStableResolution,+      testCase "stable resolution is deterministic" testStableResolutionDeterministic,+      testCase "plan descriptions include positions and migration metadata" testDescription+    ]++testExplicitOrder :: IO ()+testExplicitOrder = do+  let queue = makeComponent "queue" Set.empty ["0001"]+      eventStore = makeComponent "event-store" Set.empty ["0001"]+  plan <- requireRight (migrationPlan (queue :| [eventStore]))+  componentNames (planDescription plan)+    @?= requireNames ["queue", "event-store"]++propertyExplicitOrder :: QuickCheck.Property+propertyExplicitOrder =+  QuickCheck.forAll (QuickCheck.shuffle ["alpha", "bravo", "charlie"]) $ \rawNames ->+    let textNames = Text.pack <$> rawNames+        components = fmap (\name -> makeComponent name Set.empty ["0001"]) textNames+     in case NonEmpty.nonEmpty components of+          Nothing -> QuickCheck.property False+          Just nonEmptyComponents ->+            case migrationPlan nonEmptyComponents of+              Left err -> QuickCheck.counterexample (show err) False+              Right plan ->+                componentNames (planDescription plan)+                  QuickCheck.=== requireNames textNames++testDuplicateComponent :: IO ()+testDuplicateComponent = do+  duplicateName <- requireRight (componentName "duplicate")+  assertPlanError+    (DuplicateComponentName duplicateName)+    ( migrationPlan+        ( makeComponent "duplicate" Set.empty ["0001"]+            :| [makeComponent "duplicate" Set.empty ["0002"]]+        )+    )++testDuplicateMigration :: IO ()+testDuplicateMigration = do+  owner <- requireRight (componentName "owner")+  duplicateName <- requireRight (migrationName "0001")+  assertPlanError+    (DuplicateMigrationName owner duplicateName)+    (migrationPlan (makeComponent "owner" Set.empty ["0001", "0001"] :| []))++testLocalNameScope :: IO ()+testLocalNameScope =+  assertRight+    ( migrationPlan+        ( makeComponent "alpha" Set.empty ["0001"]+            :| [makeComponent "bravo" Set.empty ["0001"]]+        )+    )++testMissingDependency :: IO ()+testMissingDependency = do+  consumer <- requireRight (componentName "consumer")+  missing <- requireRight (componentName "missing")+  assertPlanError+    (MissingComponentDependency consumer missing)+    ( migrationPlan+        (makeComponent "consumer" (Set.singleton "missing") ["0001"] :| [])+    )++testInvalidOrder :: IO ()+testInvalidOrder = do+  consumer <- requireRight (componentName "consumer")+  dependency <- requireRight (componentName "dependency")+  assertPlanError+    (DependencyPlacedAfterConsumer consumer dependency)+    ( migrationPlan+        ( makeComponent "consumer" (Set.singleton "dependency") ["0001"]+            :| [makeComponent "dependency" Set.empty ["0001"]]+        )+    )++testCycle :: IO ()+testCycle =+  case migrationPlan+    ( makeComponent "alpha" (Set.singleton "bravo") ["0001"]+        :| [makeComponent "bravo" (Set.singleton "alpha") ["0001"]]+    ) of+    Left (ComponentDependencyCycle _) -> pure ()+    other -> assertFailure ("expected ComponentDependencyCycle, received " <> show other)++testStableResolution :: IO ()+testStableResolution = do+  let queue = makeComponent "queue" Set.empty ["0001"]+      eventStore = makeComponent "event-store" Set.empty ["0001"]+      eventSourcing = makeComponent "event-sourcing" (Set.singleton "event-store") ["0001"]+  plan <- requireRight (resolveMigrationPlan (eventSourcing :| [queue, eventStore]))+  componentNames (planDescription plan)+    @?= requireNames ["queue", "event-store", "event-sourcing"]++testStableResolutionDeterministic :: IO ()+testStableResolutionDeterministic = do+  let queue = makeComponent "queue" Set.empty ["0001"]+      eventStore = makeComponent "event-store" Set.empty ["0001"]+      eventSourcing = makeComponent "event-sourcing" (Set.singleton "event-store") ["0001"]+      input = eventSourcing :| [queue, eventStore]+  firstPlan <- requireRight (resolveMigrationPlan input)+  secondPlan <- requireRight (resolveMigrationPlan input)+  planDescription firstPlan @?= planDescription secondPlan++testDescription :: IO ()+testDescription = do+  let firstMigration = makeMigration "0001"+      secondMigration =+        requireDefinition+          (sessionMigration "0002" (migrationFingerprint "session-v1") (pure ()))+      component = requireDefinition (migrationComponent "owner" Set.empty (firstMigration :| [secondMigration]))+  plan <- requireRight (migrationPlan (component :| []))+  case planDescription plan of+    PlanDescription+      ( ComponentDescription+          { position = 1,+            migrations =+              MigrationDescription+                { position = 1,+                  kind = HaskellKind,+                  transactionMode = Transactional+                }+                :| [ MigrationDescription+                       { position = 2,+                         kind = HaskellKind,+                         transactionMode = NonTransactional+                       }+                     ]+          }+          :| []+        ) -> pure ()+    description -> assertFailure ("unexpected plan description: " <> show description)++componentNames :: PlanDescription -> [ComponentName]+componentNames (PlanDescription descriptions) =+  fmap (\ComponentDescription {name} -> name) (toList descriptions)++requireNames :: [Text] -> [ComponentName]+requireNames = fmap (requireDefinition . componentName)++makeComponent :: Text -> Set Text -> [Text] -> MigrationComponent+makeComponent name dependencies migrationNames =+  case NonEmpty.nonEmpty (makeMigration <$> migrationNames) of+    Nothing -> error "makeComponent requires at least one migration"+    Just migrations -> requireDefinition (migrationComponent name dependencies migrations)++makeMigration :: Text -> Migration+makeMigration name =+  requireDefinition+    (transactionMigration name (migrationFingerprint (Text.Encoding.encodeUtf8 name)) (pure ()))++requireDefinition :: Either DefinitionError value -> value+requireDefinition = \case+  Left err -> error (show err)+  Right value -> value++requireRight :: (Show error) => Either error value -> IO value+requireRight = \case+  Left err -> assertFailure (show err) >> error "assertFailure returned"+  Right value -> pure value++assertRight :: (Show error) => Either error value -> IO ()+assertRight result = do+  _ <- requireRight result+  pure ()++assertPlanError :: PlanError -> Either PlanError MigrationPlan -> IO ()+assertPlanError expected = \case+  Left actual -> actual @?= expected+  Right plan -> assertFailure ("expected Left " <> show expected <> ", received Right " <> show plan)
+ test/unit/Test/PublicApi.hs view
@@ -0,0 +1,56 @@+module Test.PublicApi (tests) where++import Data.Set qualified as Set+import Database.PostgreSQL.Migrate+  ( DefinitionError,+    Migration,+    MigrationComponent,+    MigrationPlan,+    PlanError,+    ledgerSchemaVersion,+    migrationComponent,+    migrationFingerprint,+    migrationPlan,+    migrationStatus,+    sessionMigration,+    transactionMigration,+    verifyMigrationPlan,+  )+import PgMigrate.Prelude+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertFailure, testCase)++tests :: TestTree+tests =+  testGroup+    "public API"+    [ testCase "manual definitions compile through the singular public module" $+        case publicPlan of+          Left err -> assertFailure (show err)+          Right (Left err) -> assertFailure (show err)+          Right (Right plan) ->+            length (show plan) `seq`+              migrationStatus `seq`+                verifyMigrationPlan `seq`+                  ledgerSchemaVersion `seq`+                    pure ()+    ]++publicPlan :: Either DefinitionError (Either PlanError MigrationPlan)+publicPlan = do+  transaction <- publicTransaction+  session <- publicSession+  component <- publicComponent transaction session+  pure (migrationPlan (component :| []))++publicTransaction :: Either DefinitionError Migration+publicTransaction =+  transactionMigration "0001-transaction" (migrationFingerprint "transaction-v1") (pure ())++publicSession :: Either DefinitionError Migration+publicSession =+  sessionMigration "0002-session" (migrationFingerprint "session-v1") (pure ())++publicComponent :: Migration -> Migration -> Either DefinitionError MigrationComponent+publicComponent transaction session =+  migrationComponent "public-api" Set.empty (transaction :| [session])
+ test/unit/Test/Runner.hs view
@@ -0,0 +1,82 @@+module Test.Runner (tests) where++import Data.Function ((&))+import Data.Int (Int32)+import Data.Time (NominalDiffTime)+import Database.PostgreSQL.Migrate+import Database.PostgreSQL.Migrate qualified as Migrate+import Database.PostgreSQL.Migrate.Internal+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++tests :: TestTree+tests =+  testGroup+    "runner"+    [ testCase "default options are conservative" testDefaultOptions,+      testCase "functional option updates compose" testOptionUpdates,+      testCase "report values remain immutable structured data" testReportValues,+      testCase "server version classification accepts only 17 and 18" testServerVersions,+      testCase "repair requests require confirmation" testRepairConfirmation,+      testCase "repair requests require a non-empty reason" testRepairReason+    ]++testDefaultOptions :: IO ()+testDefaultOptions = do+  runLedgerConfig defaultRunOptions @?= defaultLedgerConfig+  runLockWait defaultRunOptions @?= WaitIndefinitely+  runStatementTimeout defaultRunOptions @?= Nothing+  runUnknownMigrationsPolicy defaultRunOptions @?= RejectUnknownMigrations++testOptionUpdates :: IO ()+testOptionUpdates = do+  let customLedger = requireRight (ledgerConfig "application_migrations" 99)+      timeout = 12.5 :: NominalDiffTime+      options =+        defaultRunOptions+          & withLedger customLedger+          & withLockWait (WaitFor 3)+          & withStatementTimeout (Just timeout)+          & withUnknownMigrationsPolicy AllowUnknownMigrations+  runLedgerConfig options @?= customLedger+  runLockWait options @?= WaitFor 3+  runStatementTimeout options @?= Just timeout+  runUnknownMigrationsPolicy options @?= AllowUnknownMigrations++testReportValues :: IO ()+testReportValues = do+  let identifier = requireRight (Migrate.migrationId "component" "0001")+      result = MigrationResult identifier AppliedNow (Just 0.5)+  result @?= MigrationResult identifier AppliedNow (Just 0.5)+  MigrationCompleted identifier 0.5 @?= MigrationCompleted identifier 0.5++testServerVersions :: IO ()+testServerVersions = do+  requireRight (classifyServerVersion (170010 :: Int32)) @?= 17+  requireRight (classifyServerVersion (180000 :: Int32)) @?= 18+  assertUnsupported 16 (classifyServerVersion 160010)+  assertUnsupported 19 (classifyServerVersion 190000)++assertUnsupported :: Int -> Either MigrationError Int -> IO ()+assertUnsupported expected = \case+  Left (UnsupportedPostgresVersion actual) -> actual @?= expected+  other -> error ("expected unsupported PostgreSQL version, received " <> show other)++testRepairConfirmation :: IO ()+testRepairConfirmation = do+  let identifier = requireRight (Migrate.migrationId "component" "0001")+  repairRequest identifier MarkApplied "operator verified state" NotConfirmed+    @?= Left RepairNotConfirmed+  case repairRequest identifier MarkApplied "operator verified state" Confirmed of+    Left repairError -> error (show repairError)+    Right _ -> pure ()++testRepairReason :: IO ()+testRepairReason = do+  let identifier = requireRight (Migrate.migrationId "component" "0001")+  repairRequest identifier Retry "   " Confirmed @?= Left EmptyRepairReason++requireRight :: (Show error) => Either error value -> value+requireRight = \case+  Left err -> error (show err)+  Right value -> value
+ test/unit/Test/Sql.hs view
@@ -0,0 +1,139 @@+module Test.Sql (tests) where++import Data.ByteString qualified as ByteString+import Data.ByteString.Char8 qualified as ByteString.Char8+import Database.PostgreSQL.Migrate+import Database.PostgreSQL.Migrate.Internal+  ( MigrationKind (..),+    TransactionMode (..),+    migrationKind,+    migrationSqlBytes,+    migrationTransactionMode,+  )+import PgMigrate.Prelude+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertFailure, testCase, (@?=))++tests :: TestTree+tests =+  testGroup+    "SQL definitions"+    [ testCase "SQL is transactional by default" $+        modeOf "SELECT 1" @?= Right Transactional,+      testCase "a leading directive selects nontransactional execution" $+        modeOf "-- pg-migrate: no-transaction\nCREATE INDEX CONCURRENTLY example_idx ON example (id)"+          @?= Right NonTransactional,+      testCase "a directive inside a string is ordinary payload" $+        modeOf "SELECT '-- pg-migrate: no-transaction'"+          @?= Right Transactional,+      testCase "a directive after the first SQL token is ignored" $+        modeOf "SELECT 1;\n-- pg-migrate: no-transaction\nSELECT 2"+          @?= Right Transactional,+      testCase "an unknown leading directive fails" $+        assertDefinitionLeft+          (InvalidSql (UnknownDirective "pg-migrate: eventually"))+          (sqlMigration "0001-test" "-- pg-migrate: eventually\nSELECT 1"),+      testCase "a duplicate transaction directive fails" $+        assertDefinitionLeft+          (InvalidSql DuplicateNoTransactionDirective)+          ( sqlMigration+              "0001-test"+              "-- pg-migrate: no-transaction\n-- pg-migrate: no-transaction\nSELECT 1"+          ),+      testCase "semicolons in standard strings do not split statements" $+        modeOf "SELECT 'one;two'; SELECT 2"+          @?= Right Transactional,+      testCase "semicolons in escape strings do not split statements" $+        modeOf "SELECT E'one\\';two'; SELECT 2"+          @?= Right Transactional,+      testCase "semicolons in quoted identifiers do not split statements" $+        modeOf "SELECT 1 AS \"one;two\"; SELECT 2"+          @?= Right Transactional,+      testCase "semicolons in dollar-quoted bodies do not split statements" $+        modeOf+          "CREATE FUNCTION example() RETURNS void LANGUAGE plpgsql AS $body$ BEGIN PERFORM 1; END $body$; SELECT 2"+          @?= Right Transactional,+      testCase "semicolons in line and nested block comments do not split statements" $+        modeOf "/* outer; /* inner; */ done; */ SELECT 1; -- ignored;\nSELECT 2"+          @?= Right Transactional,+      testGroup+        "transaction control is prohibited"+        (fmap prohibitedCase prohibitedCommands),+      testCase "one nontransactional statement succeeds" $+        modeOf "-- pg-migrate: no-transaction\nCREATE INDEX CONCURRENTLY example_idx ON example (id);"+          @?= Right NonTransactional,+      testCase "multiple nontransactional statements fail" $+        assertDefinitionLeft+          (InvalidSql (NonTransactionalStatementCount 2))+          ( sqlMigration+              "0001-test"+              "-- pg-migrate: no-transaction\nSELECT 1; SELECT 2"+          ),+      testCase "empty SQL fails" $+        assertDefinitionLeft+          (InvalidSql EmptySql)+          (sqlMigration "0001-test" " -- only a comment"),+      testCase "invalid UTF-8 reports the offending byte" $+        assertDefinitionLeft+          (InvalidSql (InvalidUtf8 2))+          (sqlMigration "0001-test" (ByteString.pack [0x61, 0xE2, 0x28, 0xA1])),+      testCase "psql meta-commands fail with their line" $+        assertDefinitionLeft+          (InvalidSql (PsqlMetaCommand 2))+          (sqlMigration "0001-test" "SELECT 1;\n  \\echo unsupported"),+      testCase "COPY FROM STDIN is unsupported" $+        assertDefinitionLeft+          (InvalidSql CopyFromStdin)+          (sqlMigration "0001-test" "COPY example (id) FROM STDIN"),+      testCase "unterminated lexical constructs fail safely" $+        assertDefinitionLeft+          (InvalidSql (UnterminatedSqlConstruct "single-quoted string"))+          (sqlMigration "0001-test" "SELECT 'unfinished"),+      testCase "SQL migrations retain exact bytes and SQL kind" $ do+        migration <- assertRight (sqlMigration "0001-test" "SELECT 1  \n")+        migrationKind migration @?= SqlKind+        migrationSqlBytes migration @?= Just "SELECT 1  \n",+      testCase "whitespace changes the SQL checksum" $ do+        firstMigration <- assertRight (sqlMigration "0001-test" "SELECT 1")+        secondMigration <- assertRight (sqlMigration "0001-test" "SELECT  1")+        migrationFingerprint "SELECT 1"+          @?= migrationFingerprint (fromMaybe ByteString.empty (migrationSqlBytes firstMigration))+        migrationFingerprint "SELECT 1"+          /= migrationFingerprint (fromMaybe ByteString.empty (migrationSqlBytes secondMigration))+          @?= True+    ]++prohibitedCommands :: [(ByteString, Text)]+prohibitedCommands =+  [ ("BEGIN", "BEGIN"),+    ("START TRANSACTION", "START TRANSACTION"),+    ("COMMIT", "COMMIT"),+    ("END", "END"),+    ("ROLLBACK", "ROLLBACK"),+    ("ABORT", "ABORT"),+    ("SAVEPOINT before_change", "SAVEPOINT"),+    ("RELEASE SAVEPOINT before_change", "RELEASE SAVEPOINT"),+    ("PREPARE TRANSACTION 'transaction-id'", "PREPARE TRANSACTION"),+    ("COMMIT PREPARED 'transaction-id'", "COMMIT PREPARED"),+    ("ROLLBACK PREPARED 'transaction-id'", "ROLLBACK PREPARED")+  ]++prohibitedCase :: (ByteString, Text) -> TestTree+prohibitedCase (sql, command) =+  testCase (ByteString.Char8.unpack sql) $+    assertDefinitionLeft+      (InvalidSql (ProhibitedTransactionCommand command))+      (sqlMigration "0001-test" sql)++modeOf :: ByteString -> Either DefinitionError TransactionMode+modeOf sql = migrationTransactionMode <$> sqlMigration "0001-test" sql++assertRight :: (Show error) => Either error value -> IO value+assertRight = \case+  Left err -> assertFailure ("expected Right, received Left " <> show err)+  Right value -> pure value++assertDefinitionLeft :: DefinitionError -> Either DefinitionError value -> IO ()+assertDefinitionLeft expected = \case+  Left actual -> actual @?= expected+  Right _ -> assertFailure ("expected Left " <> show expected <> ", received Right")