diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,28 @@ # Changelog +## 1.1.0.0 — 2026-07-13 + +Major release: this set adds a field to `CoddImportCommand` and removes a public error +constructor. + +### Breaking changes + +- Added `allowEquivalent :: Bool` to `CoddImportCommand`, backed by the reusable parser's + new `--allow-equivalent` flag. +- Removed the unreachable `EmptyCoddSelection` constructor from `CoddDefinitionError`. + +### Fixes and behavior changes + +- Parse `--source-lock-key` through `Integer` and reject decimal or hexadecimal values + outside signed `Int64` bounds instead of silently wrapping them. +- Make `--strict-source` reject selected rows missing from a provided manifest as well as + manifest entries outside the selection. +- Stop attaching locally calculated, unverified checksums to `LedgerOnly` evidence. +- Preserve a committed `HistoryImportReport` when releasing the Codd source lock fails, + appending the source observation to `cleanupIssues`. +- Document the two optional error slots of `CoddUnlockFailed` and correct manifest/parser + API descriptions. + ## 1.0.0.0 — 2026-07-10 - Initial stable release of the Hasql-only Codd V1–V5 history adapter with source-first diff --git a/pg-migrate-import-codd.cabal b/pg-migrate-import-codd.cabal --- a/pg-migrate-import-codd.cabal +++ b/pg-migrate-import-codd.cabal @@ -1,6 +1,6 @@ cabal-version: 3.8 name: pg-migrate-import-codd -version: 1.0.0.0 +version: 1.1.0.0 synopsis: Import Codd migration history into pg-migrate category: Database maintainer: nadeem@gmail.com @@ -45,8 +45,8 @@ , containers >=0.7 && <0.8 , hasql >=1.10 && <1.11 , optparse-applicative >=0.19 && <0.20 - , pg-migrate >=1.0 && <1.1 - , pg-migrate-cli >=1.0 && <1.1 + , pg-migrate >=1.1 && <1.2 + , pg-migrate-cli >=1.1 && <1.2 , text >=2.1 && <2.2 , time >=1.12 && <1.15 @@ -80,6 +80,7 @@ hs-source-dirs: test/integration main-is: Main.hs build-depends: + , aeson >=2.2 && <2.3 , base >=4.20 && <4.22 , bytestring >=0.12 && <0.13 , containers >=0.7 && <0.8 diff --git a/src/Database/PostgreSQL/Migrate/History/Codd.hs b/src/Database/PostgreSQL/Migrate/History/Codd.hs --- a/src/Database/PostgreSQL/Migrate/History/Codd.hs +++ b/src/Database/PostgreSQL/Migrate/History/Codd.hs @@ -16,11 +16,12 @@ parseCoddManifest, readCoddHistory, importCoddHistory, + importCoddHistoryWithValidators, coddImportCommandParser, ) where -import Database.PostgreSQL.Migrate.History.Codd.Import (importCoddHistory) +import Database.PostgreSQL.Migrate.History.Codd.Import (importCoddHistory, importCoddHistoryWithValidators) import Database.PostgreSQL.Migrate.History.Codd.Ledger (readCoddHistory) import Database.PostgreSQL.Migrate.History.Codd.Manifest (parseCoddManifest) import Database.PostgreSQL.Migrate.History.Codd.Parser (coddImportCommandParser) diff --git a/src/Database/PostgreSQL/Migrate/History/Codd/Import.hs b/src/Database/PostgreSQL/Migrate/History/Codd/Import.hs --- a/src/Database/PostgreSQL/Migrate/History/Codd/Import.hs +++ b/src/Database/PostgreSQL/Migrate/History/Codd/Import.hs @@ -1,5 +1,6 @@ module Database.PostgreSQL.Migrate.History.Codd.Import ( importCoddHistory, + importCoddHistoryWithValidators, buildCoddEvidence, ) where @@ -12,7 +13,9 @@ import Data.Text qualified as Text import Database.PostgreSQL.Migrate import Database.PostgreSQL.Migrate.History.Codd.Ledger - ( readCoddHistoryOnConnection, + ( coddUnlockFailure, + readCoddHistoryOnConnection, + sourceUnlockCleanupIssue, withLockedCoddHistory, ) import Database.PostgreSQL.Migrate.History.Codd.Types @@ -29,26 +32,53 @@ NonEmpty HistoryMapping -> IO (Either CoddImportError HistoryImportReport) importCoddHistory options config targetProvider plan mappings = - case validateImportDefinition config plan mappings of + importCoddHistoryWithValidators options [] config targetProvider plan mappings + +-- | As 'importCoddHistory', with read-only state validators available to +-- 'EquivalentState' mappings. The source advisory lock remains held while the +-- target import validates state and writes its ledger rows. +importCoddHistoryWithValidators :: + ImportOptions -> + [StateValidator] -> + CoddSourceConfig -> + ConnectionProvider -> + MigrationPlan -> + NonEmpty HistoryMapping -> + IO (Either CoddImportError HistoryImportReport) +importCoddHistoryWithValidators options validators config targetProvider plan mappings = + case validateImportDefinition config validators plan mappings of Left err -> pure (Left err) - Right () -> - withLockedCoddHistory config $ \sourceConnection -> do - loaded <- readCoddHistoryOnConnection config sourceConnection - case loaded of - Left err -> pure (Left err) - Right history -> - case buildHistoryImport config history mappings of - Left err -> pure (Left err) - Right historyImportDefinition -> do - imported <- importMigrationHistory options targetProvider plan historyImportDefinition - pure (first CoddTargetImportFailed imported) + Right () -> do + (sourceResult, sourceUnlockIssues) <- + withLockedCoddHistory config $ \sourceConnection -> do + loaded <- readCoddHistoryOnConnection config sourceConnection + case loaded of + Left err -> pure (Left err) + Right history -> + case buildHistoryImport config history validators mappings of + Left err -> pure (Left err) + Right historyImportDefinition -> do + imported <- importMigrationHistory options targetProvider plan historyImportDefinition + pure (first CoddTargetImportFailed imported) + pure $ case sourceResult of + Left primary -> + case sourceUnlockIssues of + issue : _ -> Left (coddUnlockFailure (sourceLockKey config) (Just primary) issue) + [] -> Left primary + Right HistoryImportReport {importResults, cleanupIssues} -> + Right + HistoryImportReport + { importResults, + cleanupIssues = cleanupIssues <> (sourceUnlockCleanupIssue <$> sourceUnlockIssues) + } validateImportDefinition :: CoddSourceConfig -> + [StateValidator] -> MigrationPlan -> NonEmpty HistoryMapping -> Either CoddImportError () -validateImportDefinition config@CoddSourceConfig {selectedFilenames, confirmation, sourceManifest} plan mappings = do +validateImportDefinition config@CoddSourceConfig {selectedFilenames, confirmation, sourceManifest} validators plan mappings = do if any isSamePayload mappings && confirmation /= Confirmed then Left CoddConfirmationRequired else pure () @@ -56,7 +86,7 @@ then Left CoddSamePayloadRequiresManifest else pure () placeholderEvidence <- buildPlaceholderEvidence selectedFilenames - case historyImport "codd" placeholderEvidence [] mappings (importReason config) of + case historyImport "codd" placeholderEvidence validators mappings (importReason config) of Left err -> Left (CoddHistoryDefinitionFailed err) Right _ -> Right () first @@ -85,13 +115,14 @@ buildHistoryImport :: CoddSourceConfig -> CoddHistory -> + [StateValidator] -> NonEmpty HistoryMapping -> Either CoddImportError HistoryImport -buildHistoryImport config history mappings = do +buildHistoryImport config history validators mappings = do evidence <- buildCoddEvidence config history first CoddHistoryDefinitionFailed - (historyImport "codd" evidence [] mappings (importReason config)) + (historyImport "codd" evidence validators mappings (importReason config)) buildCoddEvidence :: CoddSourceConfig -> @@ -102,8 +133,11 @@ Just (CoddManifest manifest) | strictSource -> let selected = Set.fromList (filename <$> toList selectedRows) + missing = Set.toAscList (selected `Set.difference` Map.keysSet manifest) extras = Set.toAscList (Map.keysSet manifest `Set.difference` selected) - in if null extras then Right () else Left (CoddManifestHasUnexpected extras) + in case missing of + missingFilename : _ -> Left (CoddManifestEntryMissing missingFilename) + [] -> if null extras then Right () else Left (CoddManifestHasUnexpected extras) _ -> Right () Map.fromList . toList <$> traverse (rowEvidence config schemaVersion) selectedRows @@ -115,7 +149,6 @@ rowEvidence CoddSourceConfig {sourcePayloads, sourceManifest} version row@CoddHistoryRow {filename, appliedAt} = do key <- first CoddDefinitionFailed (coddEvidenceKey filename) let maybeBytes = Map.lookup filename sourcePayloads - maybeChecksum = migrationFingerprint <$> maybeBytes details = rowDetails version row timestamp = AbsoluteTime <$> appliedAt evidence <- @@ -123,23 +156,28 @@ Nothing -> first CoddHistoryDefinitionFailed - (ledgerOnlyEvidence (Text.pack filename) timestamp maybeChecksum details) - Just (CoddManifest manifest) -> do - expected <- maybe (Left (CoddManifestEntryMissing filename)) Right (Map.lookup filename manifest) - bytes <- maybe (Left (CoddSourcePayloadMissing filename)) Right maybeBytes - let actualChecksum = migrationFingerprint bytes - actual = checksumText actualChecksum - if actual /= expected - then Left (CoddManifestChecksumMismatch filename expected actual) - else + (ledgerOnlyEvidence (Text.pack filename) timestamp Nothing details) + Just (CoddManifest manifest) -> + case Map.lookup filename manifest of + Nothing -> first CoddHistoryDefinitionFailed - ( sourceManifestVerifiedEvidence - (Text.pack filename) - timestamp - (Just actualChecksum) - details - ) + (ledgerOnlyEvidence (Text.pack filename) timestamp Nothing details) + Just expected -> do + bytes <- maybe (Left (CoddSourcePayloadMissing filename)) Right maybeBytes + let actualChecksum = migrationFingerprint bytes + actual = checksumText actualChecksum + if actual /= expected + then Left (CoddManifestChecksumMismatch filename expected actual) + else + first + CoddHistoryDefinitionFailed + ( sourceManifestVerifiedEvidence + (Text.pack filename) + timestamp + (Just actualChecksum) + details + ) Right (key, evidence) rowDetails :: CoddSchemaVersion -> CoddHistoryRow -> Aeson.Value diff --git a/src/Database/PostgreSQL/Migrate/History/Codd/Ledger.hs b/src/Database/PostgreSQL/Migrate/History/Codd/Ledger.hs --- a/src/Database/PostgreSQL/Migrate/History/Codd/Ledger.hs +++ b/src/Database/PostgreSQL/Migrate/History/Codd/Ledger.hs @@ -1,6 +1,9 @@ module Database.PostgreSQL.Migrate.History.Codd.Ledger ( readCoddHistory, withLockedCoddHistory, + SourceUnlockIssue, + coddUnlockFailure, + sourceUnlockCleanupIssue, readCoddHistoryOnConnection, classifyCoddSchema, validateCoddRows, @@ -13,11 +16,13 @@ import Data.Map.Strict qualified as Map import Data.Set qualified as Set import Data.Text qualified as Text +import Database.PostgreSQL.Migrate (CleanupIssue (..)) import Database.PostgreSQL.Migrate.History.Codd.Types import Database.PostgreSQL.Migrate.Internal (useConnectionProvider) 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 @@ -25,43 +30,61 @@ -- | Read and verify selected legacy rows without mutating source objects. readCoddHistory :: CoddSourceConfig -> IO (Either CoddImportError CoddHistory) -readCoddHistory config = withLockedCoddHistory config (readCoddHistoryOnConnection config) +readCoddHistory config@CoddSourceConfig {sourceLockKey} = do + (result, unlockIssues) <- + withLockedCoddHistory config (readCoddHistoryOnConnection config) + pure $ case (result, unlockIssues) of + (Left primary, issue : _) -> Left (coddUnlockFailure sourceLockKey (Just primary) issue) + (Left primary, []) -> Left primary + (Right _, issue : _) -> Left (coddUnlockFailure sourceLockKey Nothing issue) + (Right history, []) -> Right history +data SourceUnlockIssue + = SourceUnlockReturnedFalse + | SourceUnlockSessionFailed !Errors.SessionError + withLockedCoddHistory :: CoddSourceConfig -> (Connection.Connection -> IO (Either CoddImportError value)) -> - IO (Either CoddImportError value) + IO (Either CoddImportError value, [SourceUnlockIssue]) withLockedCoddHistory CoddSourceConfig {sourceProvider, sourceLockKey} action = do acquired <- useConnectionProvider sourceProvider $ \connection -> Exception.mask $ \restore -> do locked <- runSession connection (Session.statement sourceLockKey tryLockStatement) case locked of - Left err -> pure (Left err) - Right False -> pure (Left (CoddLockUnavailable sourceLockKey)) + Left err -> pure (Left err, []) + Right False -> pure (Left (CoddLockUnavailable sourceLockKey), []) Right True -> do - primary <- - restore (action connection) - `Exception.onException` releaseIgnoringFailure connection sourceLockKey - unlocked <- runSession connection (Session.statement sourceLockKey unlockStatement) - pure $ case unlocked of - Right True -> primary - Right False -> Left (CoddUnlockFailed sourceLockKey (either Just (const Nothing) primary) Nothing) - Left cleanupFailure -> - Left - ( CoddUnlockFailed - sourceLockKey - (either Just (const Nothing) primary) - (Just cleanupFailure) - ) + captured <- Exception.try @Exception.SomeException (restore (action connection)) + unlockIssues <- unlockSource connection sourceLockKey + case captured of + Left exception -> Exception.throwIO exception + Right primary -> pure (primary, unlockIssues) pure $ case acquired of - Left connectionError -> Left (CoddConnectionFailed connectionError) + Left connectionError -> (Left (CoddConnectionFailed connectionError), []) Right result -> result -releaseIgnoringFailure :: Connection.Connection -> Int64 -> IO () -releaseIgnoringFailure connection lockKey = do - _ <- Connection.use connection (Session.statement lockKey unlockStatement) - pure () +unlockSource :: Connection.Connection -> Int64 -> IO [SourceUnlockIssue] +unlockSource connection lockKey = do + unlocked <- Connection.use connection (Session.statement lockKey unlockStatement) + pure $ case unlocked of + Left sessionError -> [SourceUnlockSessionFailed sessionError] + Right False -> [SourceUnlockReturnedFalse] + Right True -> [] + +coddUnlockFailure :: Int64 -> Maybe CoddImportError -> SourceUnlockIssue -> CoddImportError +coddUnlockFailure lockKey primary unlockIssue = + case unlockIssue of + SourceUnlockReturnedFalse -> CoddUnlockFailed lockKey primary Nothing + SourceUnlockSessionFailed sessionError -> + CoddUnlockFailed lockKey primary (Just (CoddSessionFailed sessionError)) + +sourceUnlockCleanupIssue :: SourceUnlockIssue -> CleanupIssue +sourceUnlockCleanupIssue unlockIssue = + case unlockIssue of + SourceUnlockReturnedFalse -> AdvisoryUnlockReturnedFalse + SourceUnlockSessionFailed sessionError -> AdvisoryUnlockFailed sessionError readCoddHistoryOnConnection :: CoddSourceConfig -> diff --git a/src/Database/PostgreSQL/Migrate/History/Codd/Manifest.hs b/src/Database/PostgreSQL/Migrate/History/Codd/Manifest.hs --- a/src/Database/PostgreSQL/Migrate/History/Codd/Manifest.hs +++ b/src/Database/PostgreSQL/Migrate/History/Codd/Manifest.hs @@ -8,7 +8,7 @@ import Database.PostgreSQL.Migrate.History.Codd.Types import PgMigrate.History.Codd.Prelude --- | Parse the exact ordered Codd manifest selection. +-- | Parse expected SHA-256 checksums keyed by Codd source filename. parseCoddManifest :: Text -> Either CoddDefinitionError CoddManifest parseCoddManifest contents = CoddManifest <$> foldl parseLine (Right Map.empty) (zip [1 ..] (Text.lines contents)) diff --git a/src/Database/PostgreSQL/Migrate/History/Codd/Parser.hs b/src/Database/PostgreSQL/Migrate/History/Codd/Parser.hs --- a/src/Database/PostgreSQL/Migrate/History/Codd/Parser.hs +++ b/src/Database/PostgreSQL/Migrate/History/Codd/Parser.hs @@ -16,7 +16,7 @@ import PgMigrate.History.Codd.Prelude import Text.Read qualified as Read --- | Build the reusable, target-aware Codd import parser. +-- | Build the reusable Codd import parser; the plan parameter is reserved. coddImportCommandParser :: MigrationPlan -> Parser CoddImportCommand coddImportCommandParser _ = CoddImportCommand @@ -41,16 +41,24 @@ <*> optional (strOption (long "source-directory" <> metavar "PATH" <> help "Directory containing exact selected Codd SQL payloads")) <*> switch (long "strict-source" <> help "Reject every unselected source row and unexpected manifest entry") <*> flag NotConfirmed Confirmed (long "confirm" <> help "Confirm Codd source evidence when SamePayload is mapped") + <*> switch (long "allow-equivalent" <> help "Opt in to mappings proven by read-only state validators") <*> flag TextOutput JsonOutput (long "json" <> help "Emit JSON schema version 1 conventions") lockKeyReader :: ReadM Int64 lockKeyReader = eitherReader $ \input -> case input of '0' : 'x' : hexadecimal -> - case Numeric.readHex hexadecimal of - [(parsed, "")] | parsed <= fromIntegral (maxBound :: Int64) -> Right parsed + case (Numeric.readHex hexadecimal :: [(Integer, String)]) of + [(parsed, "")] -> checkedInt64 parsed _ -> Left "expected an Int64 decimal or 0x hexadecimal advisory-lock key" _ -> - case Read.readMaybe input of - Just parsed -> Right parsed + case (Read.readMaybe input :: Maybe Integer) of + Just parsed -> checkedInt64 parsed Nothing -> Left "expected an Int64 decimal or 0x hexadecimal advisory-lock key" + where + checkedInt64 parsed + | parsed < toInteger (minBound :: Int64) = Left rangeError + | parsed > toInteger (maxBound :: Int64) = Left rangeError + | otherwise = Right (fromInteger parsed) + + rangeError = "expected an Int64 decimal or 0x hexadecimal advisory-lock key" diff --git a/src/Database/PostgreSQL/Migrate/History/Codd/Types.hs b/src/Database/PostgreSQL/Migrate/History/Codd/Types.hs --- a/src/Database/PostgreSQL/Migrate/History/Codd/Types.hs +++ b/src/Database/PostgreSQL/Migrate/History/Codd/Types.hs @@ -41,7 +41,7 @@ confirmation :: !Confirmation } --- | Ordered exact source filenames selected for import. +-- | Unordered expected SHA-256 checksums keyed by source filename. newtype CoddManifest = CoddManifest { manifestChecksums :: Map FilePath Text } @@ -76,8 +76,7 @@ -- | Invalid source identifiers, manifest, mappings, or adapter options. data CoddDefinitionError - = EmptyCoddSelection - | EmptyCoddFilename + = EmptyCoddFilename | DuplicateCoddFilename !FilePath | EmptyCoddImportReason | InvalidCoddManifestLine !Int @@ -87,6 +86,10 @@ deriving stock (Generic, Eq, Show) -- | Structured source-read, validation, lock, or target-import failure. +-- +-- In 'CoddUnlockFailed', the first optional error is the primary source-read or +-- import failure. The second is the unlock session failure; it is 'Nothing' when +-- @pg_advisory_unlock@ returned false rather than raising a session error. data CoddImportError = CoddDefinitionFailed !CoddDefinitionError | CoddConnectionFailed !Errors.ConnectionError @@ -119,6 +122,7 @@ sourceDirectory :: !(Maybe FilePath), strict :: !Bool, confirmation :: !Confirmation, + allowEquivalent :: !Bool, outputFormat :: !OutputFormat } deriving stock (Generic, Eq, Show) diff --git a/test/integration/Main.hs b/test/integration/Main.hs --- a/test/integration/Main.hs +++ b/test/integration/Main.hs @@ -1,6 +1,7 @@ module Main (main) where import Control.Exception qualified as Exception +import Data.Aeson qualified as Aeson import Data.ByteString (ByteString) import Data.ByteString qualified as ByteString import Data.Foldable (toList) @@ -45,7 +46,10 @@ testCase "partial and duplicate rows are rejected" (testInvalidRows settings), testCase "lenient selection reports extras and strict selection rejects them" (testSelection settings), testCase "legacy lock contention prevents target acquisition" (testLockContention settings), - testCase "import is audited, action-free, source-preserving, and idempotent" (testImportLifecycle settings) + testCase "strict source rejects a selected row omitted from the manifest" (testStrictManifestSymmetry settings), + testCase "import is audited, action-free, source-preserving, and idempotent" (testImportLifecycle settings), + testCase "source unlock failure preserves the committed import report" (testUnlockFailurePreservesImportReport settings), + testCase "a partial manifest supports mixed payload and state evidence" (testMixedEvidenceImport settings) ] testSupportedFixture :: Settings.Settings -> CoddSchemaVersion -> Assertion @@ -94,6 +98,19 @@ unlocked <- useSession holder (Session.statement defaultCoddLockKey unlockStatement) unlocked @?= True +testStrictManifestSymmetry :: Settings.Settings -> Assertion +testStrictManifestSymmetry settings = + withCleanSchemas settings $ do + runScript settings (fixtureSql CoddV5 <> appliedInsertSql CoddV5 selectedFilename) + result <- + importCoddHistory + importOptions + (strictMissingManifestConfig settings) + (connectionProviderFromSettings settings) + targetPlan + (targetMapping :| []) + assertCoddError (\case CoddManifestEntryMissing filename -> filename == selectedFilename; _ -> False) result + testImportLifecycle :: Settings.Settings -> Assertion testImportLifecycle settings = withCleanSchemas settings $ do @@ -110,6 +127,105 @@ afterSnapshot <- sourceSnapshot settings CoddV5 afterSnapshot @?= before +testUnlockFailurePreservesImportReport :: Settings.Settings -> Assertion +testUnlockFailurePreservesImportReport settings = + withCleanSchemas settings $ do + runScript settings unlockingFixtureSql + report <- runImport settings >>= requireCoddRight + importOutcomes report @?= [Imported] + let HistoryImportReport {cleanupIssues = observedCleanupIssues} = report + observedCleanupIssues @?= [AdvisoryUnlockReturnedFalse] + facts <- query settings targetFactsStatement + facts @?= (1, 1, False, True, True) + +testMixedEvidenceImport :: Settings.Settings -> Assertion +testMixedEvidenceImport settings = + withCleanSchemas settings $ do + runScript settings (fixtureSql CoddV5 <> appliedInsertSql CoddV5 mixedSameFilename <> appliedInsertSql CoddV5 mixedEquivalentFilename) + first <- runMixedImport settings >>= requireCoddRight + importOutcomes first @?= [Imported, Imported] + facts <- query settings mixedTargetFactsStatement + facts @?= (2, 2, False, False) + second <- runMixedImport settings >>= requireCoddRight + importOutcomes second @?= [AlreadyImported, AlreadyImported] + +runMixedImport :: Settings.Settings -> IO (Either CoddImportError HistoryImportReport) +runMixedImport settings = + importCoddHistoryWithValidators + (withEquivalentHistory AllowEquivalentHistory importOptions) + [mixedStateValidator] + (mixedSourceConfig settings) + (connectionProviderFromSettings settings) + mixedTargetPlan + mixedMappings + +mixedSourceConfig :: Settings.Settings -> CoddSourceConfig +mixedSourceConfig settings = + expectRight + ( coddSourceConfig + (connectionProviderFromSettings settings) + (mixedSameFilename :| [mixedEquivalentFilename]) + False + (Map.singleton mixedSameFilename mixedSamePayload) + (Just mixedManifest) + "verified mixed-evidence cutover" + Confirmed + ) + +mixedManifest :: CoddManifest +mixedManifest = expectRight (parseCoddManifest (checksumText mixedSamePayload <> " " <> Text.pack mixedSameFilename <> "\n")) + +mixedMappings :: NonEmpty HistoryMapping +mixedMappings = + historyMapping mixedSameTarget (Evidence mixedSameSourceKey) (SamePayload mixedSameSourceKey) + :| [ historyMapping + mixedEquivalentTarget + (AllOf (Evidence mixedEquivalentSourceKey :| [Evidence mixedStateKey])) + EquivalentState + ] + +mixedStateValidator :: StateValidator +mixedStateValidator = stateValidator mixedStateKey (pure (Right (Aeson.object ["state" Aeson..= ("verified" :: Text)]))) + +mixedStateKey :: EvidenceKey +mixedStateKey = expectRight (evidenceKey "codd:mixed-equivalent-state") + +mixedSameSourceKey :: EvidenceKey +mixedSameSourceKey = expectRight (coddEvidenceKey mixedSameFilename) + +mixedEquivalentSourceKey :: EvidenceKey +mixedEquivalentSourceKey = expectRight (coddEvidenceKey mixedEquivalentFilename) + +mixedSameTarget :: MigrationId +mixedSameTarget = expectRight (migrationId "codd-target" "0001-mixed-same") + +mixedEquivalentTarget :: MigrationId +mixedEquivalentTarget = expectRight (migrationId "codd-target" "0002-mixed-equivalent") + +mixedTargetPlan :: MigrationPlan +mixedTargetPlan = + expectRight + ( migrationPlan + ( expectRight + ( migrationComponent + "codd-target" + Set.empty + ( expectRight (sqlMigration "0001-mixed-same" mixedSamePayload) + :| [expectRight (sqlMigration "0002-mixed-equivalent" mixedEquivalentPayload)] + ) + ) + :| [] + ) + ) + +mixedSameFilename, mixedEquivalentFilename :: FilePath +mixedSameFilename = "20240101000000-mixed-same.sql" +mixedEquivalentFilename = "20240101000001-mixed-equivalent.sql" + +mixedSamePayload, mixedEquivalentPayload :: ByteString +mixedSamePayload = "CREATE TABLE pgmigrate_codd_target.mixed_same_should_not_exist (id bigint)" +mixedEquivalentPayload = "CREATE TABLE pgmigrate_codd_target.mixed_equivalent_should_not_exist (id bigint)" + runImport :: Settings.Settings -> IO (Either CoddImportError HistoryImportReport) runImport settings = importCoddHistory @@ -145,6 +261,19 @@ Confirmed ) +strictMissingManifestConfig :: Settings.Settings -> CoddSourceConfig +strictMissingManifestConfig settings = + expectRight + ( coddSourceConfig + (connectionProviderFromSettings settings) + (selectedFilename :| []) + True + Map.empty + (Just (expectRight (parseCoddManifest ""))) + "strict Codd cutover" + Confirmed + ) + targetManifest :: CoddManifest targetManifest = expectRight (parseCoddManifest (checksumText targetPayload <> " " <> Text.pack selectedFilename <> "\n")) @@ -219,6 +348,28 @@ where required = Decoders.column . Decoders.nonNullable +mixedTargetFactsStatement :: Statement () (Int64, Int64, Bool, Bool) +mixedTargetFactsStatement = + Statement.unpreparable + ( Text.unwords + [ "SELECT (SELECT count(*) FROM " <> targetSchema <> ".migrations),", + "(SELECT count(*) FROM " <> targetSchema <> ".history_imports),", + "to_regclass('" <> targetSchema <> ".mixed_same_should_not_exist') IS NOT NULL,", + "to_regclass('" <> targetSchema <> ".mixed_equivalent_should_not_exist') IS NOT NULL" + ] + ) + Encoders.noParams + ( Decoders.singleRow + ( (,,,) + <$> required Decoders.int8 + <*> required Decoders.int8 + <*> required Decoders.bool + <*> required Decoders.bool + ) + ) + where + required = Decoders.column . Decoders.nonNullable + targetSchemaExistsStatement :: Statement Text Bool targetSchemaExistsStatement = Statement.preparable @@ -252,6 +403,23 @@ CoddV3 -> ", application_duration interval, num_applied_statements int, no_txn_failed_at timestamptz);" CoddV4 -> ", application_duration interval, num_applied_statements int, no_txn_failed_at timestamptz, txnid bigint, connid int);" CoddV5 -> ", application_duration interval, num_applied_statements int, no_txn_failed_at timestamptz, txnid bigint, connid int);" + ] + +unlockingFixtureSql :: Text +unlockingFixtureSql = + Text.unwords + [ "CREATE SCHEMA codd;", + "CREATE VIEW codd.sql_migrations AS SELECT", + "1::integer AS id,", + "'2024-01-01 00:00:00+00'::timestamptz AS migration_timestamp,", + "CASE WHEN pg_advisory_unlock(" <> Text.pack (show defaultCoddLockKey) <> ")", + "THEN '2024-01-01 00:00:01+00'::timestamptz ELSE NULL::timestamptz END AS applied_at,", + "'" <> Text.pack selectedFilename <> "'::text AS name,", + "NULL::interval AS application_duration,", + "1::integer AS num_applied_statements,", + "NULL::timestamptz AS no_txn_failed_at,", + "NULL::bigint AS txnid,", + "NULL::integer AS connid;" ] fixtureSchema :: CoddSchemaVersion -> Text diff --git a/test/unit/Test/Evidence.hs b/test/unit/Test/Evidence.hs --- a/test/unit/Test/Evidence.hs +++ b/test/unit/Test/Evidence.hs @@ -22,6 +22,8 @@ "evidence" [ testCase "manifest-verified payload evidence is constructed" testVerifiedEvidence, testCase "manifest checksum mismatches are distinct" testManifestMismatch, + testCase "strict source rejects selected rows missing from the manifest" testStrictManifestMissing, + testCase "lenient source permits selected rows missing from the manifest" testLenientManifestMissing, testCase "SamePayload confirmation fails before connection acquisition" testConfirmationPreflight, testCase "unknown targets fail before connection acquisition" testTargetPreflight ] @@ -40,6 +42,18 @@ Left (CoddManifestChecksumMismatch "migration.sql" _ actual) -> actual @?= payloadChecksum result -> assertFailure ("expected manifest mismatch, received: " <> show result) +testStrictManifestMissing :: Assertion +testStrictManifestMissing = + case buildCoddEvidence (sourceConfigWithStrict True Confirmed (Just emptyManifest)) history of + Left (CoddManifestEntryMissing "migration.sql") -> pure () + result -> assertFailure ("expected missing manifest entry, received: " <> show result) + +testLenientManifestMissing :: Assertion +testLenientManifestMissing = + case buildCoddEvidence (sourceConfigWithStrict False Confirmed (Just emptyManifest)) history of + Left err -> assertFailure (show err) + Right evidence -> Map.size evidence @?= 1 + testConfirmationPreflight :: Assertion testConfirmationPreflight = do let key = expectRight (coddEvidenceKey "migration.sql") @@ -75,12 +89,15 @@ other -> assertFailure ("expected target preflight failure, received: " <> show other) sourceConfig :: Confirmation -> Maybe CoddManifest -> CoddSourceConfig -sourceConfig confirmation manifest = +sourceConfig = sourceConfigWithStrict False + +sourceConfigWithStrict :: Bool -> Confirmation -> Maybe CoddManifest -> CoddSourceConfig +sourceConfigWithStrict strict confirmation manifest = expectRight ( coddSourceConfig unusedProvider ("migration.sql" :| []) - False + strict (Map.singleton "migration.sql" payload) manifest "fixture import" @@ -89,6 +106,9 @@ matchingManifest :: CoddManifest matchingManifest = expectRight (parseCoddManifest (payloadChecksum <> " migration.sql\n")) + +emptyManifest :: CoddManifest +emptyManifest = expectRight (parseCoddManifest "") history :: CoddHistory history = diff --git a/test/unit/Test/Parser.hs b/test/unit/Test/Parser.hs --- a/test/unit/Test/Parser.hs +++ b/test/unit/Test/Parser.hs @@ -1,6 +1,7 @@ module Test.Parser (tests) where import Data.ByteString.Char8 qualified as ByteString +import Data.Int (Int64) import Data.List.NonEmpty (NonEmpty (..)) import Data.Set qualified as Set import Database.PostgreSQL.Migrate @@ -15,7 +16,12 @@ testGroup "parser" [ testCase "parser records explicit artifacts without reading them" testCommand, - testCase "invalid lock keys fail in the parser" testInvalidLock + testCase "invalid lock keys fail in the parser" (assertLockFailure "nope"), + testCase "accepts 0x7FFFFFFFFFFFFFFF" (lockKeyFor "0x7FFFFFFFFFFFFFFF" @?= maxBound), + testCase "accepts negative decimal advisory-lock keys" (lockKeyFor "-1" @?= -1), + testCase "rejects 0x8000000000000000" (assertLockFailure "0x8000000000000000"), + testCase "rejects 0xFFFFFFFFFFFFFFFF (wrap guard)" (assertLockFailure "0xFFFFFFFFFFFFFFFF"), + testCase "rejects out-of-range decimal" (assertLockFailure "18446744073709551615") ] testCommand :: Assertion @@ -31,6 +37,7 @@ "migrations", "--strict-source", "--confirm", + "--allow-equivalent", "--json" ] of CoddImportCommand @@ -40,6 +47,7 @@ sourceDirectory, strict, confirmation, + allowEquivalent, outputFormat } -> do lockKey @?= defaultCoddLockKey @@ -48,11 +56,15 @@ sourceDirectory @?= Just "migrations" strict @?= True confirmation @?= Confirmed + allowEquivalent @?= True outputFormat @?= JsonOutput -testInvalidLock :: Assertion -testInvalidLock = - case execParserPure defaultPrefs commandInfo ["--source-lock-key", "nope", "--mapping", "map.json"] of +lockKeyFor :: String -> Int64 +lockKeyFor input = lockKey (parseSuccess ["--source-lock-key", input, "--mapping", "map.json"]) + +assertLockFailure :: String -> Assertion +assertLockFailure input = + case execParserPure defaultPrefs commandInfo ["--source-lock-key", input, "--mapping", "map.json"] of Failure _ -> pure () result -> assertFailure ("expected parser failure, received: " <> show result)