diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,46 @@ # Changelog +## 1.1.0.0 — 2026-07-13 + +Major release: this set changes public report constructors and the `CleanupFailed` +constructor. + +### Breaking changes + +- Added `cleanupIssues :: [CleanupIssue]` to `MigrationReport`, `RepairReport`, and + `HistoryImportReport`; the latter is now a multi-field `data` type rather than a + `newtype`. +- Changed `CleanupFailed` from an optional primary error to + `CleanupFailed MigrationError (NonEmpty CleanupIssue)`. +- Added `HistoryPayloadEvidenceTooWeak` to `HistoryValidationError`; exhaustive consumers + must handle the new constructor. +- Added `ByteOrderMarkFound` and `MisplacedDirective` to `SqlError`; exhaustive consumers + must handle the new constructors. + +### Fixes and behavior changes + +- Preserve durably successful migration, repair, and history-import reports when advisory + unlock or statement-timeout restoration fails, attaching the cleanup observations to the + report instead of replacing it with an error. +- Retain a genuine primary runner failure inside `CleanupFailed` when cleanup also fails. +- Added `Eq` for `CleanupIssue`, preserving the existing report `Eq` instances after their + new field was added. +- Require `SamePayload` mappings to use evidence of at least + `SourceManifestVerified` strength, preventing matching but unverified ledger-only + checksums from authorizing imports. +- Reject SQL payloads with a leading UTF-8 byte-order mark and reject `pg-migrate:` line + comments placed after SQL begins; psql meta-command diagnostics now use file-absolute + line numbers. +- Reject zero and negative temporary statement timeouts before acquiring a connection; + `Nothing` remains the way to leave the PostgreSQL session default untouched. +- Honor an explicitly configured `AllowUnknownMigrations` policy during repair and history + import, matching normal execution. The strict default remains unchanged. +- Replace the transactional runner's per-migration full-ledger reload with a keyed + existence query and build history-import classification maps once per import. +- Pin and document the conservative mixed native/import contract: import a gap-free legacy + prefix before applying that component natively; native rows without matching import audit + evidence remain conflicts. + ## 1.0.0.0 — 2026-07-10 - Initial stable release of the validated plan model, ledger schema v1, transactional and diff --git a/pg-migrate.cabal b/pg-migrate.cabal --- a/pg-migrate.cabal +++ b/pg-migrate.cabal @@ -1,6 +1,6 @@ cabal-version: 3.8 name: pg-migrate -version: 1.0.0.0 +version: 1.1.0.0 synopsis: Hasql-native PostgreSQL migration engine category: Database maintainer: nadeem@gmail.com diff --git a/src/Database/PostgreSQL/Migrate/History.hs b/src/Database/PostgreSQL/Migrate/History.hs --- a/src/Database/PostgreSQL/Migrate/History.hs +++ b/src/Database/PostgreSQL/Migrate/History.hs @@ -40,6 +40,7 @@ import Data.Aeson qualified as Aeson import Data.ByteString.Lazy qualified as LazyByteString +import Data.List.NonEmpty qualified as NonEmpty import Data.Map.Strict qualified as Map import Data.Text qualified as Text import Data.Time (UTCTime, getCurrentTime) @@ -73,12 +74,21 @@ HistoryImport -> IO (Either HistoryImportError HistoryImportReport) importMigrationHistory options provider plan history = do - result <- + (result, observedCleanupIssues) <- withRunLifecycle (importRunOptions options) provider $ \connection -> - Right <$> importLocked options connection plan history + importLocked options connection plan history >>= \case + Left (HistoryImportRunnerError migrationError) -> pure (Left migrationError) + importResult -> pure (Right importResult) pure $ case result of - Left migrationError -> Left (HistoryImportRunnerError migrationError) - Right imported -> imported + Left migrationError -> Left (HistoryImportRunnerError (attachCleanup observedCleanupIssues migrationError)) + Right (Left importError) -> Left importError + Right (Right HistoryImportReport {importResults}) -> + Right HistoryImportReport {importResults, cleanupIssues = observedCleanupIssues} + where + attachCleanup cleanup migrationError = + case NonEmpty.nonEmpty cleanup of + Nothing -> migrationError + Just issues -> CleanupFailed migrationError issues importLocked :: ImportOptions -> @@ -114,7 +124,7 @@ [StoredHistoryImport] -> IO (Either HistoryImportError HistoryImportReport) importAgainstSnapshot options connection plan history snapshot storedAudits = - case comparePlanWithLedger RejectUnknownMigrations (planDescription plan) (storedMigrations snapshot) of + case comparePlanWithLedger policy (planDescription plan) (storedMigrations snapshot) of verification@VerificationReport {issues = _ : _} -> pure (Left (HistoryImportRunnerError (PlanVerificationFailed verification))) VerificationReport {} -> do @@ -125,13 +135,19 @@ case resolveHistoryImport (equivalentHistoryPolicy options) plan availableEvidence history of Left validationError -> pure (Left (HistoryImportValidationFailed validationError)) Right resolved -> do - let classified = + let migrationsById = + Map.fromList [(storedMigrationId row, row) | row <- storedMigrations snapshot] + auditsById = + Map.fromList [(storedHistoryMigrationId row, row) | row <- storedAudits] + classified = traverse - (classifyImport history snapshot storedAudits) + (classifyImport history migrationsById auditsById) resolved case classified of Left importError -> pure (Left importError) Right imports -> persistImports options connection history imports + where + policy = runUnknownMigrationsPolicy (importRunOptions options) runValidators :: Connection.Connection -> @@ -160,11 +176,11 @@ classifyImport :: HistoryImport -> - LedgerSnapshot -> - [StoredHistoryImport] -> + Map MigrationId StoredMigration -> + Map MigrationId StoredHistoryImport -> ResolvedHistoryMapping -> Either HistoryImportError ClassifiedImport -classifyImport history snapshot storedAudits resolved = +classifyImport history migrationsById auditsById resolved = case (Map.lookup identifier migrationsById, Map.lookup identifier auditsById) of (Nothing, Nothing) -> Right (ImportPending resolved) (Just storedMigration, Just storedAudit) @@ -173,8 +189,6 @@ _ -> 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 @@ -224,9 +238,10 @@ Left sessionError -> Left (HistoryImportRunnerError (DatabaseSessionFailed sessionError)) Right () -> Right - ( HistoryImportReport - (toResult <$> imports) - ) + HistoryImportReport + { importResults = toResult <$> imports, + cleanupIssues = [] + } where toResult = \case ImportPending resolved -> HistoryImportResult (resolvedTarget resolved) Imported diff --git a/src/Database/PostgreSQL/Migrate/History/Types.hs b/src/Database/PostgreSQL/Migrate/History/Types.hs --- a/src/Database/PostgreSQL/Migrate/History/Types.hs +++ b/src/Database/PostgreSQL/Migrate/History/Types.hs @@ -157,9 +157,10 @@ } deriving stock (Generic, Eq, Show) --- | Non-empty successful result set for an import operation. -newtype HistoryImportReport = HistoryImportReport - { importResults :: NonEmpty HistoryImportResult +-- | Non-empty successful result set and lifecycle cleanup observations for an import operation. +data HistoryImportReport = HistoryImportReport + { importResults :: !(NonEmpty HistoryImportResult), + cleanupIssues :: ![CleanupIssue] } deriving stock (Generic, Eq, Show) @@ -170,6 +171,7 @@ | HistoryRequirementUnsatisfied !MigrationId | HistoryRequirementAmbiguous !MigrationId | HistoryPayloadEvidenceMissing !MigrationId !EvidenceKey + | HistoryPayloadEvidenceTooWeak !MigrationId !EvidenceKey | HistoryPayloadChecksumMissing !MigrationId !EvidenceKey | HistoryPayloadChecksumMismatch !MigrationId !EvidenceKey | HistorySamePayloadForHaskell !MigrationId diff --git a/src/Database/PostgreSQL/Migrate/History/Validation.hs b/src/Database/PostgreSQL/Migrate/History/Validation.hs --- a/src/Database/PostgreSQL/Migrate/History/Validation.hs +++ b/src/Database/PostgreSQL/Migrate/History/Validation.hs @@ -204,6 +204,9 @@ (Left (HistoryPayloadEvidenceMissing (target mapping) key)) Right (Map.lookup key available) + when + (strength sourceEvidence < SourceManifestVerified) + (Left (HistoryPayloadEvidenceTooWeak (target mapping) key)) sourceChecksum <- maybe (Left (HistoryPayloadChecksumMissing (target mapping) key)) diff --git a/src/Database/PostgreSQL/Migrate/Ledger/Sql.hs b/src/Database/PostgreSQL/Migrate/Ledger/Sql.hs --- a/src/Database/PostgreSQL/Migrate/Ledger/Sql.hs +++ b/src/Database/PostgreSQL/Migrate/Ledger/Sql.hs @@ -5,6 +5,7 @@ loadLedgerMetadataStatement, insertLedgerMetadataStatement, loadStoredMigrationsStatement, + storedMigrationExistsStatement, AppliedLedgerRow (..), FailedLedgerRow (..), insertAppliedMigrationStatement, @@ -99,6 +100,25 @@ ) Encoders.noParams (Decoders.rowList storedMigrationRow) + +storedMigrationExistsStatement :: LedgerConfig -> Statement MigrationId Bool +storedMigrationExistsStatement config = + Statement.unpreparable + ( Text.unwords + [ "SELECT EXISTS (SELECT 1 FROM", + qualifiedLedgerTable config "migrations", + "WHERE component = $1 AND migration = $2)" + ] + ) + migrationIdEncoder + (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.bool))) + +migrationIdEncoder :: Encoders.Params MigrationId +migrationIdEncoder = + mconcat + [ contramap (componentNameText . migrationIdComponent) (Encoders.param (Encoders.nonNullable Encoders.text)), + contramap (migrationNameText . migrationIdName) (Encoders.param (Encoders.nonNullable Encoders.text)) + ] storedMigrationRow :: Decoders.Row StoredMigration storedMigrationRow = diff --git a/src/Database/PostgreSQL/Migrate/Repair.hs b/src/Database/PostgreSQL/Migrate/Repair.hs --- a/src/Database/PostgreSQL/Migrate/Repair.hs +++ b/src/Database/PostgreSQL/Migrate/Repair.hs @@ -4,6 +4,7 @@ where import Data.Int (Int32, Int64) +import Data.List.NonEmpty qualified as NonEmpty import Data.Text qualified as Text import Data.Version (showVersion) import Database.PostgreSQL.Migrate.Ledger @@ -31,12 +32,29 @@ RepairRequest -> IO (Either RepairError RepairReport) repairMigration options provider plan request = do - result <- + (result, observedCleanupIssues) <- withRunLifecycle options provider $ \connection -> - Right <$> repairLocked options connection plan request + repairLocked options connection plan request >>= \case + Left (RepairRunnerError migrationError) -> pure (Left migrationError) + repairResult -> pure (Right repairResult) pure $ case result of - Left migrationError -> Left (RepairRunnerError migrationError) - Right repairResult -> repairResult + Left migrationError -> Left (RepairRunnerError (attachCleanup observedCleanupIssues migrationError)) + Right (Left repairError) -> Left repairError + Right + ( Right + RepairReport + { repairedMigration, + operation, + oldStatus, + newStatus + } + ) -> + Right RepairReport {repairedMigration, operation, oldStatus, newStatus, cleanupIssues = observedCleanupIssues} + where + attachCleanup cleanup migrationError = + case NonEmpty.nonEmpty cleanup of + Nothing -> migrationError + Just issues -> CleanupFailed migrationError issues repairLocked :: RunOptions -> @@ -83,7 +101,7 @@ targetId = repairMigrationId request verification = comparePlanWithLedger - RejectUnknownMigrations + (runUnknownMigrationsPolicy options) (planDescription plan) (storedMigrations snapshot) @@ -143,7 +161,8 @@ { repairedMigration = repairMigrationId request, operation = MarkApplied, oldStatus, - newStatus = Applied + newStatus = Applied, + cleanupIssues = [] } retry :: @@ -184,7 +203,8 @@ { repairedMigration = repairMigrationId request, operation = Retry, oldStatus, - newStatus = Applied + newStatus = Applied, + cleanupIssues = [] } runRepairTransaction :: diff --git a/src/Database/PostgreSQL/Migrate/Repair/Types.hs b/src/Database/PostgreSQL/Migrate/Repair/Types.hs --- a/src/Database/PostgreSQL/Migrate/Repair/Types.hs +++ b/src/Database/PostgreSQL/Migrate/Repair/Types.hs @@ -58,7 +58,8 @@ { repairedMigration :: !MigrationId, operation :: !RepairOperation, oldStatus :: !MigrationStatus, - newStatus :: !MigrationStatus + newStatus :: !MigrationStatus, + cleanupIssues :: ![CleanupIssue] } deriving stock (Generic, Eq, Show) diff --git a/src/Database/PostgreSQL/Migrate/Runner.hs b/src/Database/PostgreSQL/Migrate/Runner.hs --- a/src/Database/PostgreSQL/Migrate/Runner.hs +++ b/src/Database/PostgreSQL/Migrate/Runner.hs @@ -69,40 +69,44 @@ ConnectionProvider -> MigrationPlan -> IO (Either MigrationError MigrationReport) -runMigrationPlanWith options ConnectionProvider {useDedicatedConnection} plan = - withRunLifecycle - options - (ConnectionProvider useDedicatedConnection) - (\connection -> runLocked options connection plan) +runMigrationPlanWith options ConnectionProvider {useDedicatedConnection} plan = do + (result, observedCleanupIssues) <- + withRunLifecycle + options + (ConnectionProvider useDedicatedConnection) + (\connection -> runLocked options connection plan) + pure $ case attachCleanup observedCleanupIssues result of + Left migrationError -> Left migrationError + Right report -> Right report {cleanupIssues = observedCleanupIssues} withRunLifecycle :: RunOptions -> ConnectionProvider -> (Connection.Connection -> IO (Either MigrationError value)) -> - IO (Either MigrationError value) + IO (Either MigrationError value, [CleanupIssue]) withRunLifecycle options ConnectionProvider {useDedicatedConnection} action = case validateOptions options of - Left optionsError -> pure (Left optionsError) + Left optionsError -> pure (Left optionsError, []) Right () -> do acquired <- useDedicatedConnection (\connection -> runOnConnection options connection action) pure $ case acquired of - Left connectionError -> Left (ConnectionAcquisitionFailed connectionError) + Left connectionError -> (Left (ConnectionAcquisitionFailed connectionError), []) Right result -> result runOnConnection :: RunOptions -> Connection.Connection -> (Connection.Connection -> IO (Either MigrationError value)) -> - IO (Either MigrationError value) + IO (Either MigrationError value, [CleanupIssue]) runOnConnection options connection action = do serverVersion <- checkServerVersion connection case serverVersion of - Left migrationError -> pure (Left migrationError) + Left migrationError -> pure (Left migrationError, []) Right _ -> withStatementTimeoutResource options connection $ do waitEvent <- invokeEvent options (LockWaitStarted (runLockWait options)) case waitEvent of - Left eventError -> pure (Left eventError) + Left eventError -> pure (Left eventError, []) Right () -> withAdvisoryLockResource options connection $ \lockDuration -> do acquiredEvent <- invokeEvent options (LockAcquired lockDuration) @@ -113,13 +117,13 @@ withStatementTimeoutResource :: RunOptions -> Connection.Connection -> - IO (Either MigrationError value) -> - IO (Either MigrationError value) + IO (Either MigrationError value, [CleanupIssue]) -> + IO (Either MigrationError value, [CleanupIssue]) withStatementTimeoutResource options connection action = mask $ \restore -> do applied <- applyStatementTimeout connection (runStatementTimeout options) case applied of - Left migrationError -> pure (Left migrationError) + Left migrationError -> pure (Left migrationError, []) Right previous -> do captured <- try @SomeException (restore action) cleanup <- restoreStatementTimeout connection previous @@ -129,7 +133,7 @@ RunOptions -> Connection.Connection -> (NominalDiffTime -> IO (Either MigrationError value)) -> - IO (Either MigrationError value) + IO (Either MigrationError value, [CleanupIssue]) withAdvisoryLockResource options connection action = mask $ \restore -> do acquired <- @@ -140,24 +144,25 @@ (runLockWait options) ) case acquired of - Left migrationError -> pure (Left migrationError) + Left migrationError -> pure (Left migrationError, []) Right lockDuration -> do - captured <- try @SomeException (restore (action lockDuration)) + captured <- try @SomeException (restore ((,[]) <$> action lockDuration)) cleanup <- releaseAdvisoryLock connection (ledgerLockKey (runLedgerConfig options)) finishResource captured [cleanup] finishResource :: - Either SomeException (Either MigrationError value) -> + Either SomeException (Either MigrationError value, [CleanupIssue]) -> [Either CleanupIssue ()] -> - IO (Either MigrationError value) + IO (Either MigrationError value, [CleanupIssue]) finishResource captured cleanupResults = do - let (cleanupIssues, _) = partitionEithers cleanupResults + let (observedCleanupIssues, _) = partitionEithers cleanupResults case captured of Left exception | isAsyncException exception -> throwIO exception - | otherwise -> pure (attachCleanup cleanupIssues (Left (MigrationActionFailed exception))) - Right result -> pure (attachCleanup cleanupIssues result) + | otherwise -> pure (Left (MigrationActionFailed exception), observedCleanupIssues) + Right (result, existingCleanupIssues) -> + pure (result, existingCleanupIssues <> observedCleanupIssues) attachCleanup :: [CleanupIssue] -> @@ -166,12 +171,9 @@ attachCleanup cleanupIssues result = case NonEmpty.nonEmpty cleanupIssues of Nothing -> result - Just issues -> - Left - ( CleanupFailed - (case result of Left primary -> Just primary; Right _ -> Nothing) - issues - ) + Just issues -> case result of + Left primary -> Left (CleanupFailed primary issues) + Right value -> Right value runLocked :: RunOptions -> @@ -250,7 +252,8 @@ MigrationReport { startedAt = reportStartedAt, finishedAt = reportFinishedAt, - results + results, + cleanupIssues = [] } ) where @@ -304,13 +307,17 @@ Right (Left sessionError) -> finishFailure startedMonotonic (DatabaseSessionFailed sessionError) Right (Right ()) -> do - loaded <- runSession connection (loadLedger (runLedgerConfig options)) - case loaded of + stored <- + runSession + connection + ( Session.statement + identifier + (storedMigrationExistsStatement (runLedgerConfig options)) + ) + case stored of Left migrationError -> finishFailure startedMonotonic migrationError - Right snapshot - | any ((== identifier) . storedMigrationId) (storedMigrations snapshot) -> - finishSuccess startedMonotonic - | otherwise -> finishFailure startedMonotonic (TransactionCondemned identifier) + Right True -> finishSuccess startedMonotonic + Right False -> finishFailure startedMonotonic (TransactionCondemned identifier) where identifier = plannedId planned finishSuccess started = do @@ -623,7 +630,7 @@ WaitFor timeout | timeout < 0 -> Left (InvalidLockWait timeout) _ -> Right () case runStatementTimeout options of - Just timeout | timeout < 0 -> Left (InvalidStatementTimeout timeout) + Just timeout | timeout <= 0 -> Left (InvalidStatementTimeout timeout) _ -> Right () elapsedSince :: Word64 -> IO NominalDiffTime diff --git a/src/Database/PostgreSQL/Migrate/Runner/Lock.hs b/src/Database/PostgreSQL/Migrate/Runner/Lock.hs --- a/src/Database/PostgreSQL/Migrate/Runner/Lock.hs +++ b/src/Database/PostgreSQL/Migrate/Runner/Lock.hs @@ -80,7 +80,7 @@ IO (Either MigrationError (Maybe Text)) applyStatementTimeout _ Nothing = pure (Right Nothing) applyStatementTimeout connection (Just timeout) - | timeout < 0 = pure (Left (InvalidStatementTimeout timeout)) + | timeout <= 0 = pure (Left (InvalidStatementTimeout timeout)) | otherwise = do result <- Connection.use connection $ do diff --git a/src/Database/PostgreSQL/Migrate/Runner/Types.hs b/src/Database/PostgreSQL/Migrate/Runner/Types.hs --- a/src/Database/PostgreSQL/Migrate/Runner/Types.hs +++ b/src/Database/PostgreSQL/Migrate/Runner/Types.hs @@ -81,7 +81,8 @@ data MigrationReport = MigrationReport { startedAt :: !UTCTime, finishedAt :: !UTCTime, - results :: !(NonEmpty MigrationResult) + results :: !(NonEmpty MigrationResult), + cleanupIssues :: ![CleanupIssue] } deriving stock (Generic, Eq, Show) @@ -90,7 +91,7 @@ = AdvisoryUnlockReturnedFalse | AdvisoryUnlockFailed !Errors.SessionError | StatementTimeoutRestoreFailed !Errors.SessionError - deriving stock (Generic, Show) + deriving stock (Generic, Eq, Show) -- | Structured acquisition, validation, execution, event, or cleanup failure. data MigrationError @@ -111,7 +112,7 @@ | NonTransactionalMigrationFailed !MigrationId !Errors.SessionError | LedgerTransitionDidNotMatch !MigrationId !MigrationStatus !MigrationStatus | NonTransactionalFailureRecordingFailed !MigrationId !MigrationError !MigrationError - | CleanupFailed !(Maybe MigrationError) !(NonEmpty CleanupIssue) + | CleanupFailed !MigrationError !(NonEmpty CleanupIssue) deriving stock (Generic, Show) -- | Rank-2 provider that brackets one dedicated PostgreSQL connection per operation. @@ -141,11 +142,11 @@ withLockWait :: LockWait -> RunOptions -> RunOptions withLockWait lockWait options = options {lockWait} --- | Set or disable the temporary PostgreSQL statement timeout. +-- | Set a positive temporary PostgreSQL statement timeout, or use 'Nothing' for no override. withStatementTimeout :: Maybe NominalDiffTime -> RunOptions -> RunOptions withStatementTimeout statementTimeout options = options {statementTimeout} --- | Select how inspection treats unknown stored migrations. +-- | Select how execution, repair, and history import treat unknown stored migrations. withUnknownMigrationsPolicy :: UnknownMigrationsPolicy -> RunOptions -> RunOptions withUnknownMigrationsPolicy unknownMigrations RunOptions {ledger, lockWait, statementTimeout, emit} = RunOptions {ledger, lockWait, statementTimeout, unknownMigrations, emit} diff --git a/src/Database/PostgreSQL/Migrate/Sql.hs b/src/Database/PostgreSQL/Migrate/Sql.hs --- a/src/Database/PostgreSQL/Migrate/Sql.hs +++ b/src/Database/PostgreSQL/Migrate/Sql.hs @@ -20,9 +20,14 @@ import PgMigrate.Prelude validateSql :: ByteString -> Either SqlError SqlScan -validateSql bytes = do - validateUtf8 bytes - scanSql (Text.Encoding.decodeUtf8 bytes) +validateSql bytes + | utf8ByteOrderMark `ByteString.isPrefixOf` bytes = Left ByteOrderMarkFound + | otherwise = do + validateUtf8 bytes + scanSql (Text.Encoding.decodeUtf8 bytes) + +utf8ByteOrderMark :: ByteString +utf8ByteOrderMark = ByteString.pack [0xEF, 0xBB, 0xBF] validateUtf8 :: ByteString -> Either SqlError () validateUtf8 = go 0 . ByteString.unpack diff --git a/src/Database/PostgreSQL/Migrate/Sql/Scanner.hs b/src/Database/PostgreSQL/Migrate/Sql/Scanner.hs --- a/src/Database/PostgreSQL/Migrate/Sql/Scanner.hs +++ b/src/Database/PostgreSQL/Migrate/Sql/Scanner.hs @@ -18,9 +18,16 @@ = InvalidUtf8 { byteOffset :: !Int } + | ByteOrderMarkFound | UnknownDirective { directive :: !Text } + | -- | A @pg-migrate:@ line-comment directive appeared after SQL began. + -- Block comments never participate in the directive grammar. + MisplacedDirective + { directive :: !Text, + lineNumber :: !Int + } | DuplicateNoTransactionDirective | UnterminatedSqlConstruct { construct :: !Text @@ -66,8 +73,8 @@ scanSql :: Text -> Either SqlError SqlScan scanSql sql = do - (noTransaction, body) <- scanLeadingRegion False (Text.unpack sql) - statements <- scanStatements body + (noTransaction, bodyLine, body) <- scanLeadingRegion False 1 (Text.unpack sql) + statements <- scanStatements bodyLine body traverse_ validateStatement statements let statementCount = length statements case (noTransaction, statementCount) of @@ -76,17 +83,19 @@ (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) +scanLeadingRegion :: Bool -> Int -> String -> Either SqlError (Bool, Int, String) +scanLeadingRegion noTransaction line input = + let (leadingWhitespace, afterWhitespace) = span Char.isSpace input + nextLine = line + length (filter (== '\n') leadingWhitespace) + in case afterWhitespace of + '-' : '-' : rest -> do + let (comment, remaining) = break (== '\n') rest + noTransaction' <- inspectLeadingComment noTransaction comment + scanLeadingRegion noTransaction' nextLine remaining + '/' : '*' : rest -> do + (lineAfterComment, remaining) <- consumeLeadingBlockComment 1 nextLine rest + scanLeadingRegion noTransaction lineAfterComment remaining + remaining -> Right (noTransaction, nextLine, remaining) inspectLeadingComment :: Bool -> String -> Either SqlError Bool inspectLeadingComment alreadySeen comment = @@ -101,18 +110,19 @@ then Left (UnknownDirective commentText) else Right alreadySeen -consumeLeadingBlockComment :: Int -> String -> Either SqlError String -consumeLeadingBlockComment depth input = +consumeLeadingBlockComment :: Int -> Int -> String -> Either SqlError (Int, String) +consumeLeadingBlockComment depth line input = case input of [] -> Left (UnterminatedSqlConstruct "block comment") - '/' : '*' : rest -> consumeLeadingBlockComment (depth + 1) rest + '/' : '*' : rest -> consumeLeadingBlockComment (depth + 1) line rest '*' : '/' : rest - | depth == 1 -> Right rest - | otherwise -> consumeLeadingBlockComment (depth - 1) rest - _ : rest -> consumeLeadingBlockComment depth rest + | depth == 1 -> Right (line, rest) + | otherwise -> consumeLeadingBlockComment (depth - 1) line rest + '\n' : rest -> consumeLeadingBlockComment depth (line + 1) rest + _ : rest -> consumeLeadingBlockComment depth line rest -scanStatements :: String -> Either SqlError [Statement] -scanStatements = go 1 True emptyAccumulator [] +scanStatements :: Int -> String -> Either SqlError [Statement] +scanStatements initialLine = go initialLine True emptyAccumulator [] where go line lineOnlyWhitespace accumulator statements input = case input of @@ -122,8 +132,12 @@ character : rest | Char.isSpace character -> go line lineOnlyWhitespace (flushWord accumulator) statements rest - '-' : '-' : rest -> - go line lineOnlyWhitespace (flushWord accumulator) statements (dropLineComment rest) + '-' : '-' : rest -> do + let (comment, remaining) = break (== '\n') rest + commentText = Text.strip (Text.pack comment) + if "pg-migrate:" `Text.isPrefixOf` commentText + then Left (MisplacedDirective commentText line) + else go line lineOnlyWhitespace (flushWord accumulator) statements remaining '/' : '*' : rest -> do (nextLine, nextLineOnlyWhitespace, remaining) <- consumeBlockComment 1 line lineOnlyWhitespace rest @@ -164,9 +178,6 @@ 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 = diff --git a/test/integration/Main.hs b/test/integration/Main.hs --- a/test/integration/Main.hs +++ b/test/integration/Main.hs @@ -67,6 +67,7 @@ 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 "unlock failure preserves the migration report" (testCleanupIssuePreservesReport 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), @@ -75,10 +76,14 @@ 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 "repair honors the unknown-migrations policy" (testRepairUnknownPolicy 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 "native-then-import conflicts on the native row" (testHistoryExistingConflict settings), + testCase "suffix-only history import reports a prefix gap" (testHistorySuffixOnlyPrefixGap settings), + testCase "import-then-native applies only the remaining migration" (testHistoryImportThenNative settings), + testCase "history import honors the unknown-migrations policy" (testHistoryUnknownPolicy 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), @@ -212,6 +217,33 @@ snapshot <- useSession connection (loadLedger config) length (storedMigrations snapshot) @?= 2 +testCleanupIssuePreservesReport :: Settings.Settings -> IO () +testCleanupIssuePreservesReport settings = + withTestLedger settings "cleanup_success" $ \connection config -> do + let plan = + sqlPlan + "cleanup-success" + [ ( "0001-apply-and-unlock", + Text.unlines + [ "CREATE TABLE " <> quotedSchema config <> ".durable_effect (value integer NOT NULL);", + "SELECT pg_advisory_unlock_all()" + ] + ) + ] + options = withLedger config defaultRunOptions + firstReport <- runMigrationPlan options settings plan >>= requireRunRight + reportOutcomes firstReport @?= [AppliedNow] + case firstReport of + MigrationReport {cleanupIssues = [AdvisoryUnlockReturnedFalse]} -> pure () + other -> assertFailure ("expected preserved unlock issue, received " <> show other) + snapshot <- useSession connection (loadLedger config) + storedStatuses snapshot @?= [Applied] + secondReport <- runMigrationPlan options settings plan >>= requireRunRight + reportOutcomes secondReport @?= [AlreadyApplied] + case secondReport of + MigrationReport {cleanupIssues = []} -> pure () + other -> assertFailure ("expected clean second report, received " <> show other) + testTransactionalRollback :: Settings.Settings -> IO () testTransactionalRollback settings = withTestLedger settings "rollback" $ \connection config -> do @@ -327,7 +359,8 @@ { repairedMigration = targetId, operation = MarkApplied, oldStatus = Failed, - newStatus = Applied + newStatus = Applied, + cleanupIssues = [] } snapshot <- useSession connection (loadLedger config) storedStatuses snapshot @?= [Applied] @@ -360,7 +393,8 @@ { repairedMigration = targetId, operation = Retry, oldStatus = Failed, - newStatus = Applied + newStatus = Applied, + cleanupIssues = [] } snapshot <- useSession connection (loadLedger config) storedStatuses snapshot @?= [Applied] @@ -433,6 +467,25 @@ repairMigration options (connectionProviderFromSettings settings) plan request >>= assertRepairAlreadyApplied +testRepairUnknownPolicy :: Settings.Settings -> IO () +testRepairUnknownPolicy settings = + withTestLedger settings "repair_unknown_policy" $ \_ config -> do + let foreignPlan = sqlPlan "repair-foreign" [("0001", "SELECT 1")] + targetPlan = missingIndexPlan config "repair-policy" "idx_repair_policy" "missing_policy_table" + strictOptions = withLedger config defaultRunOptions + allowedOptions = strictOptions & withUnknownMigrationsPolicy AllowUnknownMigrations + targetId = requireRight (Migrate.migrationId "repair-policy" "0001-index") + foreignId = requireRight (Migrate.migrationId "repair-foreign" "0001") + request = requireRight (repairRequest targetId MarkApplied "shared ledger policy verified" Confirmed) + provider = connectionProviderFromSettings settings + _ <- runMigrationPlan strictOptions settings foreignPlan >>= requireRunRight + runMigrationPlan allowedOptions settings targetPlan >>= assertNonTransactionalFailure + repairMigration strictOptions provider targetPlan request + >>= assertRepairUnknownBlocked foreignId + report <- repairMigration allowedOptions provider targetPlan request >>= requireRepairRight + repairedMigration report @?= targetId + newStatus report @?= Applied + testCrashAmbiguity :: Settings.Settings -> IO () testCrashAmbiguity settings = withTestLedger settings "crash" $ \connection config -> @@ -520,6 +573,56 @@ auditCount <- useSession connection (Session.statement () (historyAuditCountStatement config)) auditCount @?= 0 +testHistorySuffixOnlyPrefixGap :: Settings.Settings -> IO () +testHistorySuffixOnlyPrefixGap settings = + withTestLedger settings "history_suffix_only" $ \_ config -> + importMigrationHistory + (historyOptions config) + (connectionProviderFromSettings settings) + (historySqlPlan config) + (historySqlImportMappings config False (2 :| [])) + >>= assertHistoryPrefixGap (migrationIdComponent (historyTarget 2)) 1 + +testHistoryImportThenNative :: Settings.Settings -> IO () +testHistoryImportThenNative settings = + withTestLedger settings "history_import_then_native" $ \connection config -> do + let plan = historySqlPlan config + options = historyOptions config + runOptions = withLedger config defaultRunOptions + imported <- + importMigrationHistory + options + (connectionProviderFromSettings settings) + plan + (historySqlImport config False) + >>= requireHistoryRight + historyOutcomes imported @?= zip (historyTarget <$> [1, 2]) (repeat Imported) + report <- runMigrationPlan runOptions settings plan >>= requireRunRight + reportOutcomes report @?= [AlreadyApplied, AlreadyApplied, AppliedNow] + tableNames <- useSession connection (Session.statement (ledgerSchema config) tableNamesStatement) + assertBool + "imported target actions were executed" + (all (`notElem` tableNames) ["import_action_1", "import_action_2"]) + assertBool "remaining native action was not executed" ("import_action_3" `elem` tableNames) + +testHistoryUnknownPolicy :: Settings.Settings -> IO () +testHistoryUnknownPolicy settings = + withTestLedger settings "history_unknown_policy" $ \_ config -> do + let foreignPlan = sqlPlan "history-foreign" [("0001", "SELECT 1")] + strictRunOptions = withLedger config defaultRunOptions + allowedRunOptions = strictRunOptions & withUnknownMigrationsPolicy AllowUnknownMigrations + strictImportOptions = withImportRunOptions strictRunOptions defaultImportOptions + allowedImportOptions = withImportRunOptions allowedRunOptions defaultImportOptions + provider = connectionProviderFromSettings settings + plan = historySqlPlan config + imported = historySqlImport config False + foreignId = requireRight (Migrate.migrationId "history-foreign" "0001") + _ <- runMigrationPlan strictRunOptions settings foreignPlan >>= requireRunRight + importMigrationHistory strictImportOptions provider plan imported + >>= assertHistoryUnknownBlocked foreignId + report <- importMigrationHistory allowedImportOptions provider plan imported >>= requireHistoryRight + historyOutcomes report @?= zip (historyTarget <$> [1, 2]) (repeat Imported) + testHistoryAtomicity :: Settings.Settings -> IO () testHistoryAtomicity settings = withTestLedger settings "history_atomicity" $ \connection config -> do @@ -1033,12 +1136,34 @@ Left repairError -> assertFailure ("expected repaired action failure, received " <> show repairError) Right report -> assertFailure ("expected repaired action failure, received " <> show report) +assertRepairUnknownBlocked :: MigrationId -> Either RepairError RepairReport -> IO () +assertRepairUnknownBlocked expected = \case + Left (RepairBlockedByVerification VerificationReport {issues}) -> + issues @?= [UnknownStoredMigration expected] + Left repairError -> assertFailure ("expected RepairBlockedByVerification, received " <> show repairError) + Right report -> assertFailure ("expected RepairBlockedByVerification, 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) +assertHistoryUnknownBlocked :: MigrationId -> Either HistoryImportError HistoryImportReport -> IO () +assertHistoryUnknownBlocked expected = \case + Left (HistoryImportRunnerError (PlanVerificationFailed VerificationReport {issues})) -> + issues @?= [UnknownStoredMigration expected] + Left importError -> assertFailure ("expected history PlanVerificationFailed, received " <> show importError) + Right report -> assertFailure ("expected history PlanVerificationFailed, received " <> show report) + +assertHistoryPrefixGap :: ComponentName -> Int -> Either HistoryImportError HistoryImportReport -> IO () +assertHistoryPrefixGap expectedComponent expectedPosition = \case + Left (HistoryImportValidationFailed (HistoryComponentPrefixGap actualComponent actualPosition)) -> do + actualComponent @?= expectedComponent + actualPosition @?= expectedPosition + Left importError -> assertFailure ("expected HistoryComponentPrefixGap, received " <> show importError) + Right report -> assertFailure ("expected HistoryComponentPrefixGap, received " <> show report) + assertHistoryDatabaseFailure :: Either HistoryImportError HistoryImportReport -> IO () assertHistoryDatabaseFailure = \case Left (HistoryImportRunnerError DatabaseSessionFailed {}) -> pure () @@ -1156,12 +1281,16 @@ historySqlImport :: LedgerConfig -> Bool -> HistoryImport historySqlImport config changed = + historySqlImportMappings config changed (1 :| [2]) + +historySqlImportMappings :: LedgerConfig -> Bool -> NonEmpty Int -> HistoryImport +historySqlImportMappings config changed mappingNumbers = requireRight ( historyImport "legacy-engine" (Map.fromList [(historyEvidenceKey number, historyEvidence number) | number <- [1 .. 3]]) [] - (historyMappingFor 1 :| [historyMappingFor 2]) + (historyMappingFor <$> mappingNumbers) "verified staging cutover" ) where diff --git a/test/unit/Test/History.hs b/test/unit/Test/History.hs --- a/test/unit/Test/History.hs +++ b/test/unit/Test/History.hs @@ -34,6 +34,7 @@ testCase "component gaps are rejected" testPrefixGap, testCase "unknown targets are rejected" testUnknownTarget, testCase "payload checksum mismatches are rejected" testChecksumMismatch, + testCase "same-payload evidence requires manifest strength" testPayloadEvidenceStrength, 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 @@ -189,6 +190,19 @@ imported = requireHistoryImport mismatchedEvidence [prefixMapping 1] [] resolveHistoryImport RejectEquivalentHistory prefixPlan mismatchedEvidence imported @?= Left (HistoryPayloadChecksumMismatch (prefixTarget 1) (prefixKey 1)) + +testPayloadEvidenceStrength :: IO () +testPayloadEvidenceStrength = do + let target = prefixTarget 1 + sourceKey = prefixKey 1 + checksum = migrationFingerprint "SELECT 1" + available = + Map.singleton + sourceKey + (requireRight (ledgerOnlyEvidence "legacy/0001.sql" Nothing (Just checksum) Aeson.Null)) + imported = requireHistoryImport available [historyMapping target (Evidence sourceKey) (SamePayload sourceKey)] [] + resolveHistoryImport RejectEquivalentHistory prefixPlan available imported + @?= Left (HistoryPayloadEvidenceTooWeak target sourceKey) testHaskellSamePayload :: IO () testHaskellSamePayload = do diff --git a/test/unit/Test/Runner.hs b/test/unit/Test/Runner.hs --- a/test/unit/Test/Runner.hs +++ b/test/unit/Test/Runner.hs @@ -17,6 +17,7 @@ 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 "statement timeout of zero is rejected before connection acquisition" testZeroStatementTimeout, testCase "repair requests require confirmation" testRepairConfirmation, testCase "repair requests require a non-empty reason" testRepairReason ] @@ -56,6 +57,20 @@ requireRight (classifyServerVersion (180000 :: Int32)) @?= 18 assertUnsupported 16 (classifyServerVersion 160010) assertUnsupported 19 (classifyServerVersion 190000) + +testZeroStatementTimeout :: IO () +testZeroStatementTimeout = do + let options = defaultRunOptions & withStatementTimeout (Just 0) + provider = connectionProvider (\_ -> error "zero timeout acquired a connection") + runMigrationPlanWith options provider (error "zero timeout evaluated the migration plan") + >>= assertInvalidStatementTimeout + applyStatementTimeout (error "zero timeout used a connection") (Just 0) + >>= assertInvalidStatementTimeout + +assertInvalidStatementTimeout :: (Show value) => Either MigrationError value -> IO () +assertInvalidStatementTimeout = \case + Left (InvalidStatementTimeout timeout) -> timeout @?= 0 + other -> error ("expected InvalidStatementTimeout 0, received " <> show other) assertUnsupported :: Int -> Either MigrationError Int -> IO () assertUnsupported expected = \case diff --git a/test/unit/Test/Sql.hs b/test/unit/Test/Sql.hs --- a/test/unit/Test/Sql.hs +++ b/test/unit/Test/Sql.hs @@ -26,8 +26,15 @@ 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" + testCase "a directive after the first SQL token is rejected" $ + assertDefinitionLeft + (InvalidSql (MisplacedDirective "pg-migrate: no-transaction" 2)) + ( sqlMigration + "0001-test" + "SELECT 1;\n-- pg-migrate: no-transaction\nSELECT 2" + ), + testCase "an ordinary comment after the first SQL token remains valid" $ + modeOf "SELECT 1;\n-- done" @?= Right Transactional, testCase "an unknown leading directive fails" $ assertDefinitionLeft @@ -77,10 +84,32 @@ assertDefinitionLeft (InvalidSql (InvalidUtf8 2)) (sqlMigration "0001-test" (ByteString.pack [0x61, 0xE2, 0x28, 0xA1])), + testCase "a leading UTF-8 byte-order mark is rejected" $ + assertDefinitionLeft + (InvalidSql ByteOrderMarkFound) + (sqlMigration "0001-test" (ByteString.pack [0xEF, 0xBB, 0xBF] <> "SELECT 1")), + testCase "a byte-order mark cannot hide a leading directive" $ + assertDefinitionLeft + (InvalidSql ByteOrderMarkFound) + ( sqlMigration + "0001-test" + ( ByteString.pack [0xEF, 0xBB, 0xBF] + <> "-- pg-migrate: no-transaction\nCREATE INDEX CONCURRENTLY example_idx ON example (id)" + ) + ), + -- U+FEFF away from byte offset zero is not an editor-added leading BOM, so + -- definition-time validation leaves its PostgreSQL meaning unchanged. + testCase "U+FEFF inside SQL remains ordinary payload" $ + modeOf ("SELECT 1" <> ByteString.pack [0xEF, 0xBB, 0xBF]) + @?= Right Transactional, testCase "psql meta-commands fail with their line" $ assertDefinitionLeft (InvalidSql (PsqlMetaCommand 2)) (sqlMigration "0001-test" "SELECT 1;\n \\echo unsupported"), + testCase "psql meta-command lines include the leading comment region" $ + assertDefinitionLeft + (InvalidSql (PsqlMetaCommand 4)) + (sqlMigration "0001-test" "-- a\n-- b\n\n\\copy example from stdin"), testCase "COPY FROM STDIN is unsupported" $ assertDefinitionLeft (InvalidSql CopyFromStdin)