diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,11 @@ ## [Unreleased] +## 0.6.0.0 — 2026-07-31 + +No changes this release. Released with the package set for the `keiro-dsl` +0.6.0.0 work. + ## 0.5.0.0 — 2026-07-31 No changes this release. Released with the package set for the `keiro-dsl` diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -6,8 +6,8 @@ import Data.Int (Int64) import Data.Text qualified as Text import Data.Text.IO qualified as Text.IO -import Database.PostgreSQL.Migrate ( - Confirmation (..), +import Database.PostgreSQL.Migrate + ( Confirmation (..), HistoryImportError (..), HistoryImportOutcome (..), HistoryImportReport (..), @@ -17,36 +17,36 @@ connectionProviderFromSettings, defaultImportOptions, defaultRunOptions, - ) + ) import Database.PostgreSQL.Migrate.CLI -import Database.PostgreSQL.Migrate.History.Codd ( - CoddImportError (..), +import Database.PostgreSQL.Migrate.History.Codd + ( CoddImportError (..), defaultCoddLockKey, importCoddHistory, withCoddLockKey, - ) -import Database.PostgreSQL.Migrate.Internal ( - componentNameText, + ) +import Database.PostgreSQL.Migrate.Internal + ( componentNameText, migrationIdComponent, migrationIdName, migrationNameText, - ) + ) import Hasql.Connection.Settings qualified as Settings -import Keiro.Migrations ( - CoddLedgerPreflight (..), +import Keiro.Migrations + ( CoddLedgerPreflight (..), frameworkMigrationPlan, keiroMigrations, preflightFreshLedgerOverCodd, renderCoddPreflight, - ) -import Keiro.Migrations.History.Codd ( - frameworkCoddHistoryMappings, + ) +import Keiro.Migrations.History.Codd + ( frameworkCoddHistoryMappings, frameworkCoddSourceConfig, - ) -import Keiro.Migrations.SchemaCheck ( - renderSchemaDrift, + ) +import Keiro.Migrations.SchemaCheck + ( renderSchemaDrift, verifyExpectedSchema, - ) + ) import Kiroku.Store.Migrations qualified as Kiroku import Numeric qualified import Options.Applicative @@ -57,315 +57,315 @@ main :: IO () main = do - kiroku <- either (fail . show) pure Kiroku.kirokuMigrations - keiro <- either (fail . show) pure keiroMigrations - plan <- either (fail . show) pure (frameworkMigrationPlan kiroku keiro) - invocation <- - execParser - ( info - (keiroInvocationParser plan <**> helper) - (fullDesc <> progDesc "Manage the Kiroku and Keiro migration components") - ) - defaultDatabaseUrl <- lookupEnv "DATABASE_URL" - let defaultSettings = - Settings.connectionString (Text.pack (maybe "" id defaultDatabaseUrl)) - runKeiroInvocation defaultSettings plan invocation + kiroku <- either (fail . show) pure Kiroku.kirokuMigrations + keiro <- either (fail . show) pure keiroMigrations + plan <- either (fail . show) pure (frameworkMigrationPlan kiroku keiro) + invocation <- + execParser + ( info + (keiroInvocationParser plan <**> helper) + (fullDesc <> progDesc "Manage the Kiroku and Keiro migration components") + ) + defaultDatabaseUrl <- lookupEnv "DATABASE_URL" + let defaultSettings = + Settings.connectionString (Text.pack (maybe "" id defaultDatabaseUrl)) + runKeiroInvocation defaultSettings plan invocation data KeiroInvocation = KeiroInvocation - { allowFreshLedgerOverCodd :: Bool - , keiroCommand :: KeiroCommand - } + { allowFreshLedgerOverCodd :: Bool, + keiroCommand :: KeiroCommand + } runKeiroInvocation :: - Settings.Settings -> - MigrationPlan -> - KeiroInvocation -> - IO () + Settings.Settings -> + MigrationPlan -> + KeiroInvocation -> + IO () runKeiroInvocation - defaultSettings - plan - KeiroInvocation{allowFreshLedgerOverCodd, keiroCommand} = do - if allowFreshLedgerOverCodd && not (isUpCommand keiroCommand) - then do - Text.IO.hPutStrLn - stderr - "--allow-fresh-ledger-over-codd applies only to up" - Exit.exitFailure - else pure () - case keiroCommand of - Framework command -> do - preflightFrameworkUp defaultSettings allowFreshLedgerOverCodd command - let environment = cliEnvironment defaultSettings plan defaultRunOptions - outcome <- runMigrationCommand environment command - case commandOutputFormat command of - TextOutput -> Text.IO.putStrLn (renderMigrationCommandText outcome) - JsonOutput -> LazyByteString.putStrLn (Aeson.encode (renderMigrationCommandJson outcome)) - Exit.exitWith - (case exitClass outcome of ExitSucceeded -> Exit.ExitSuccess; _ -> Exit.ExitFailure 1) - VerifySchema options -> - runVerifySchema defaultSettings options - ImportCoddHistory options -> - runImportCoddHistory defaultSettings plan options + defaultSettings + plan + KeiroInvocation {allowFreshLedgerOverCodd, keiroCommand} = do + if allowFreshLedgerOverCodd && not (isUpCommand keiroCommand) + then do + Text.IO.hPutStrLn + stderr + "--allow-fresh-ledger-over-codd applies only to up" + Exit.exitFailure + else pure () + case keiroCommand of + Framework command -> do + preflightFrameworkUp defaultSettings allowFreshLedgerOverCodd command + let environment = cliEnvironment defaultSettings plan defaultRunOptions + outcome <- runMigrationCommand environment command + case commandOutputFormat command of + TextOutput -> Text.IO.putStrLn (renderMigrationCommandText outcome) + JsonOutput -> LazyByteString.putStrLn (Aeson.encode (renderMigrationCommandJson outcome)) + Exit.exitWith + (case exitClass outcome of ExitSucceeded -> Exit.ExitSuccess; _ -> Exit.ExitFailure 1) + VerifySchema options -> + runVerifySchema defaultSettings options + ImportCoddHistory options -> + runImportCoddHistory defaultSettings plan options isUpCommand :: KeiroCommand -> Bool isUpCommand keiroCommand = - case keiroCommand of - Framework Up{} -> True - _ -> False + case keiroCommand of + Framework Up {} -> True + _ -> False preflightFrameworkUp :: - Settings.Settings -> - Bool -> - MigrationCommand -> - IO () + Settings.Settings -> + Bool -> + MigrationCommand -> + IO () preflightFrameworkUp defaultSettings allowFreshLedgerOverCodd command = - case command of - Up UpOptions{connection = ConnectionOptions{databaseSettings}} - | not allowFreshLedgerOverCodd -> do - result <- - preflightFreshLedgerOverCodd - (maybe defaultSettings id databaseSettings) - case result of - Left migrationError -> do - Text.IO.hPutStrLn - stderr - ( "codd-ledger preflight failed: " - <> Text.pack (show migrationError) - ) - Exit.exitFailure - Right CoddPreflightClear -> pure () - Right blocked@CoddPreflightBlocked{} -> do - Text.IO.hPutStrLn stderr (renderCoddPreflight blocked) - Exit.exitFailure - _ -> pure () + case command of + Up UpOptions {connection = ConnectionOptions {databaseSettings}} + | not allowFreshLedgerOverCodd -> do + result <- + preflightFreshLedgerOverCodd + (maybe defaultSettings id databaseSettings) + case result of + Left migrationError -> do + Text.IO.hPutStrLn + stderr + ( "codd-ledger preflight failed: " + <> Text.pack (show migrationError) + ) + Exit.exitFailure + Right CoddPreflightClear -> pure () + Right blocked@CoddPreflightBlocked {} -> do + Text.IO.hPutStrLn stderr (renderCoddPreflight blocked) + Exit.exitFailure + _ -> pure () data KeiroCommand - = Framework MigrationCommand - | VerifySchema VerifySchemaOptions - | ImportCoddHistory ImportCoddOptions + = Framework MigrationCommand + | VerifySchema VerifySchemaOptions + | ImportCoddHistory ImportCoddOptions newtype VerifySchemaOptions = VerifySchemaOptions - { verifySchemaDatabaseSettings :: Maybe Settings.Settings - } + { verifySchemaDatabaseSettings :: Maybe Settings.Settings + } data ImportCoddOptions = ImportCoddOptions - { importTargetSettings :: Maybe Settings.Settings - , importSourceSettings :: Maybe Settings.Settings - , importSourceLockKey :: Int64 - , importReason :: Text.Text - , importConfirmation :: Confirmation - , importJsonOutput :: Bool - } + { importTargetSettings :: Maybe Settings.Settings, + importSourceSettings :: Maybe Settings.Settings, + importSourceLockKey :: Int64, + importReason :: Text.Text, + importConfirmation :: Confirmation, + importJsonOutput :: Bool + } keiroInvocationParser :: MigrationPlan -> Parser KeiroInvocation keiroInvocationParser plan = - KeiroInvocation - <$> switch - ( long "allow-fresh-ledger-over-codd" - <> help - "Allow up to initialize native history even when a codd ledger exists" - ) - <*> keiroCommandParser plan + KeiroInvocation + <$> switch + ( long "allow-fresh-ledger-over-codd" + <> help + "Allow up to initialize native history even when a codd ledger exists" + ) + <*> keiroCommandParser plan keiroCommandParser :: MigrationPlan -> Parser KeiroCommand keiroCommandParser plan = - (Framework <$> migrationCommandParser plan) - <|> subparser - ( commandGroup "Keiro" - <> Options.Applicative.command - "verify-schema" - ( info - (VerifySchema <$> verifySchemaOptionsParser <**> helper) - (progDesc "Compare live keiro schema objects against the embedded expected snapshot") - ) - <> Options.Applicative.command - "import-codd-history" - ( info - (ImportCoddHistory <$> importCoddOptionsParser <**> helper) - (progDesc "Import verified codd history into the native migration ledger") - ) + (Framework <$> migrationCommandParser plan) + <|> subparser + ( commandGroup "Keiro" + <> Options.Applicative.command + "verify-schema" + ( info + (VerifySchema <$> verifySchemaOptionsParser <**> helper) + (progDesc "Compare live keiro schema objects against the embedded expected snapshot") ) + <> Options.Applicative.command + "import-codd-history" + ( info + (ImportCoddHistory <$> importCoddOptionsParser <**> helper) + (progDesc "Import verified codd history into the native migration ledger") + ) + ) verifySchemaOptionsParser :: Parser VerifySchemaOptions verifySchemaOptionsParser = - VerifySchemaOptions - <$> optional - ( option - databaseSettingsReader - ( long "database-url" - <> metavar "URL" - <> help "PostgreSQL URI or keyword/value connection string; defaults to DATABASE_URL" - ) - ) + VerifySchemaOptions + <$> optional + ( option + databaseSettingsReader + ( long "database-url" + <> metavar "URL" + <> help "PostgreSQL URI or keyword/value connection string; defaults to DATABASE_URL" + ) + ) databaseSettingsReader :: ReadM Settings.Settings databaseSettingsReader = - Settings.connectionString . Text.pack <$> str + Settings.connectionString . Text.pack <$> str importCoddOptionsParser :: Parser ImportCoddOptions importCoddOptionsParser = - ImportCoddOptions - <$> optional - ( option - databaseSettingsReader - ( long "database-url" - <> metavar "URL" - <> help "Target PostgreSQL connection string; defaults to DATABASE_URL" - ) - ) - <*> optional - ( option - databaseSettingsReader - ( long "source-database-url" - <> metavar "URL" - <> help "Codd source connection string; defaults to the target database" - ) - ) - <*> option - lockKeyReader - ( long "source-lock-key" - <> metavar "INT64" - <> value defaultCoddLockKey - <> showDefault - <> help "Cooperating legacy wrapper advisory-lock key (decimal or 0x hexadecimal)" - ) - <*> (Text.pack <$> strOption (long "reason" <> metavar "TEXT" <> help "Audited reason for the history import")) - <*> flag - NotConfirmed - Confirmed - (long "confirm" <> help "Confirm the checked-in codd source evidence") - <*> switch (long "json" <> help "Emit JSON schema version 1 conventions") + ImportCoddOptions + <$> optional + ( option + databaseSettingsReader + ( long "database-url" + <> metavar "URL" + <> help "Target PostgreSQL connection string; defaults to DATABASE_URL" + ) + ) + <*> optional + ( option + databaseSettingsReader + ( long "source-database-url" + <> metavar "URL" + <> help "Codd source connection string; defaults to the target database" + ) + ) + <*> option + lockKeyReader + ( long "source-lock-key" + <> metavar "INT64" + <> value defaultCoddLockKey + <> showDefault + <> help "Cooperating legacy wrapper advisory-lock key (decimal or 0x hexadecimal)" + ) + <*> (Text.pack <$> strOption (long "reason" <> metavar "TEXT" <> help "Audited reason for the history import")) + <*> flag + NotConfirmed + Confirmed + (long "confirm" <> help "Confirm the checked-in codd source evidence") + <*> switch (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 :: [(Integer, String)]) of - [(parsed, "")] -> checkedInt64 parsed - _ -> Left lockKeyError - _ -> - case (Read.readMaybe input :: Maybe Integer) of - Just parsed -> checkedInt64 parsed - Nothing -> Left lockKeyError + case input of + '0' : 'x' : hexadecimal -> + case (Numeric.readHex hexadecimal :: [(Integer, String)]) of + [(parsed, "")] -> checkedInt64 parsed + _ -> Left lockKeyError + _ -> + case (Read.readMaybe input :: Maybe Integer) of + Just parsed -> checkedInt64 parsed + Nothing -> Left lockKeyError where checkedInt64 parsed - | parsed < toInteger (minBound :: Int64) = Left lockKeyError - | parsed > toInteger (maxBound :: Int64) = Left lockKeyError - | otherwise = Right (fromInteger parsed) + | parsed < toInteger (minBound :: Int64) = Left lockKeyError + | parsed > toInteger (maxBound :: Int64) = Left lockKeyError + | otherwise = Right (fromInteger parsed) lockKeyError = "expected an Int64 decimal or 0x hexadecimal advisory-lock key" runVerifySchema :: Settings.Settings -> VerifySchemaOptions -> IO () -runVerifySchema defaultSettings VerifySchemaOptions{verifySchemaDatabaseSettings} = do - result <- - verifyExpectedSchema - (maybe defaultSettings id verifySchemaDatabaseSettings) - case result of - Left migrationError -> do - Text.IO.putStrLn - ("schema verification failed: " <> Text.pack (show migrationError)) - Exit.exitFailure - Right [] -> - Text.IO.putStrLn "schema verification succeeded" - Right drifts -> do - traverse_ (Text.IO.putStrLn . renderSchemaDrift) drifts - Exit.exitFailure +runVerifySchema defaultSettings VerifySchemaOptions {verifySchemaDatabaseSettings} = do + result <- + verifyExpectedSchema + (maybe defaultSettings id verifySchemaDatabaseSettings) + case result of + Left migrationError -> do + Text.IO.putStrLn + ("schema verification failed: " <> Text.pack (show migrationError)) + Exit.exitFailure + Right [] -> + Text.IO.putStrLn "schema verification succeeded" + Right drifts -> do + traverse_ (Text.IO.putStrLn . renderSchemaDrift) drifts + Exit.exitFailure runImportCoddHistory :: - Settings.Settings -> - MigrationPlan -> - ImportCoddOptions -> - IO () + Settings.Settings -> + MigrationPlan -> + ImportCoddOptions -> + IO () runImportCoddHistory - defaultSettings - plan - ImportCoddOptions - { importTargetSettings - , importSourceSettings - , importSourceLockKey - , importReason - , importConfirmation - , importJsonOutput - } = do - let targetSettings = maybe defaultSettings id importTargetSettings - sourceSettings = maybe targetSettings id importSourceSettings - targetProvider = connectionProviderFromSettings targetSettings - sourceProvider = connectionProviderFromSettings sourceSettings - case frameworkCoddSourceConfig - sourceProvider - True - importReason - importConfirmation of - Left definitionError -> do - Text.IO.hPutStrLn - stderr - ("codd history import definition failed: " <> Text.pack (show definitionError)) - Exit.exitFailure - Right baseConfig -> do - let config = - if importSourceLockKey == defaultCoddLockKey - then baseConfig - else withCoddLockKey importSourceLockKey baseConfig - result <- - importCoddHistory - defaultImportOptions - config - targetProvider - plan - frameworkCoddHistoryMappings - case result of - Left importError -> do - Text.IO.hPutStrLn stderr (renderCoddImportError importError) - Exit.exitFailure - Right report - | importJsonOutput -> - LazyByteString.putStrLn - (Aeson.encode (renderHistoryImportJson "codd" report)) - | otherwise -> - Text.IO.putStr (renderHistoryImportText report) + defaultSettings + plan + ImportCoddOptions + { importTargetSettings, + importSourceSettings, + importSourceLockKey, + importReason, + importConfirmation, + importJsonOutput + } = do + let targetSettings = maybe defaultSettings id importTargetSettings + sourceSettings = maybe targetSettings id importSourceSettings + targetProvider = connectionProviderFromSettings targetSettings + sourceProvider = connectionProviderFromSettings sourceSettings + case frameworkCoddSourceConfig + sourceProvider + True + importReason + importConfirmation of + Left definitionError -> do + Text.IO.hPutStrLn + stderr + ("codd history import definition failed: " <> Text.pack (show definitionError)) + Exit.exitFailure + Right baseConfig -> do + let config = + if importSourceLockKey == defaultCoddLockKey + then baseConfig + else withCoddLockKey importSourceLockKey baseConfig + result <- + importCoddHistory + defaultImportOptions + config + targetProvider + plan + frameworkCoddHistoryMappings + case result of + Left importError -> do + Text.IO.hPutStrLn stderr (renderCoddImportError importError) + Exit.exitFailure + Right report + | importJsonOutput -> + LazyByteString.putStrLn + (Aeson.encode (renderHistoryImportJson "codd" report)) + | otherwise -> + Text.IO.putStr (renderHistoryImportText report) renderHistoryImportText :: HistoryImportReport -> Text.Text -renderHistoryImportText HistoryImportReport{importResults} = - Text.unlines (renderResult <$> toList importResults) +renderHistoryImportText HistoryImportReport {importResults} = + Text.unlines (renderResult <$> toList importResults) where - renderResult HistoryImportResult{importedMigration, importOutcome} = - outcomeText importOutcome <> " " <> migrationIdText importedMigration + renderResult HistoryImportResult {importedMigration, importOutcome} = + outcomeText importOutcome <> " " <> migrationIdText importedMigration outcomeText Imported = "imported" outcomeText AlreadyImported = "already imported" migrationIdText :: MigrationId -> Text.Text migrationIdText identifier = - componentNameText (migrationIdComponent identifier) - <> "/" - <> migrationNameText (migrationIdName identifier) + componentNameText (migrationIdComponent identifier) + <> "/" + <> migrationNameText (migrationIdName identifier) renderCoddImportError :: CoddImportError -> Text.Text renderCoddImportError importError = - "codd history import failed: " - <> Text.pack (show importError) - <> recoveryHint importError + "codd history import failed: " + <> Text.pack (show importError) + <> recoveryHint importError where - recoveryHint CoddSelectedFilenameMissing{} = filenameRealignmentHint - recoveryHint CoddStrictSourceHasUnselected{} = filenameRealignmentHint - recoveryHint (CoddTargetImportFailed HistoryImportConflict{}) = - " The native ledger already has rows without import evidence; see the recovery " - <> "procedure in docs/user/upgrading-to-the-keiro-schema.md." + recoveryHint CoddSelectedFilenameMissing {} = filenameRealignmentHint + recoveryHint CoddStrictSourceHasUnselected {} = filenameRealignmentHint + recoveryHint (CoddTargetImportFailed HistoryImportConflict {}) = + " The native ledger already has rows without import evidence; see the recovery " + <> "procedure in docs/user/upgrading-to-the-keiro-schema.md." recoveryHint _ = "" filenameRealignmentHint = - " If this ledger predates the 2026-07-05 filename realignment, run " - <> "keiro-migrations/ledger-fixups/" - <> "2026-07-05-realign-keiro-migration-timestamps.sql first." + " If this ledger predates the 2026-07-05 filename realignment, run " + <> "keiro-migrations/ledger-fixups/" + <> "2026-07-05-realign-keiro-migration-timestamps.sql first." commandOutputFormat :: MigrationCommand -> OutputFormat commandOutputFormat command = - case command of - Plan PlanOptions{output = OutputOptions format} -> format - List ListOptions{output = OutputOptions format} -> format - Check CheckOptions{output = OutputOptions format} -> format - Status StatusOptions{output = OutputOptions format} -> format - Verify VerifyOptions{output = OutputOptions format} -> format - Up UpOptions{output = OutputOptions format} -> format - Repair RepairOptions{output = OutputOptions format} -> format - New NewOptions{output = OutputOptions format} -> format + case command of + Plan PlanOptions {output = OutputOptions format} -> format + List ListOptions {output = OutputOptions format} -> format + Check CheckOptions {output = OutputOptions format} -> format + Status StatusOptions {output = OutputOptions format} -> format + Verify VerifyOptions {output = OutputOptions format} -> format + Up UpOptions {output = OutputOptions format} -> format + Repair RepairOptions {output = OutputOptions format} -> format + New NewOptions {output = OutputOptions format} -> format diff --git a/app/WriteExpectedSchema.hs b/app/WriteExpectedSchema.hs --- a/app/WriteExpectedSchema.hs +++ b/app/WriteExpectedSchema.hs @@ -1,6 +1,6 @@ -module Main ( - main, -) +module Main + ( main, + ) where import Codd.Extras.WriteSchema (writeExpectedSchemaMain) @@ -9,5 +9,5 @@ main :: IO () main = - writeExpectedSchemaMain "keiro" ["keiro"] "keiro-migrations/expected-schema" $ \settings -> - runAllKeiroMigrationsNoCheck settings (secondsToDiffTime 5) + writeExpectedSchemaMain "keiro" ["keiro"] "keiro-migrations/expected-schema" $ \settings -> + runAllKeiroMigrationsNoCheck settings (secondsToDiffTime 5) diff --git a/keiro-migrations.cabal b/keiro-migrations.cabal --- a/keiro-migrations.cabal +++ b/keiro-migrations.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: keiro-migrations -version: 0.5.0.0 +version: 0.6.0.0 synopsis: Schema migrations for keiro description: Embedded PostgreSQL schema migrations and a migration runner for the Keiro diff --git a/src/Keiro/Migrations.hs b/src/Keiro/Migrations.hs --- a/src/Keiro/Migrations.hs +++ b/src/Keiro/Migrations.hs @@ -1,5 +1,5 @@ -module Keiro.Migrations ( - CoddLedgerPreflight (..), +module Keiro.Migrations + ( CoddLedgerPreflight (..), ConnectionProvider, DefinitionError, MigrationComponent, @@ -19,14 +19,15 @@ missingMigrations, preflightFreshLedgerOverCodd, renderCoddPreflight, -) where + ) +where import Control.Exception (finally) import Data.Int (Int64) import Data.List.NonEmpty (NonEmpty (..)) import Data.Text (Text) -import Database.PostgreSQL.Migrate ( - ConnectionProvider, +import Database.PostgreSQL.Migrate + ( ConnectionProvider, DefinitionError, MigrationComponent, MigrationError (..), @@ -39,7 +40,7 @@ defaultRunOptions, migrationPlan, migrationStatusWith, - ) + ) import Database.PostgreSQL.Migrate qualified as Migrate import Hasql.Connection qualified as Connection import Hasql.Connection.Settings qualified as Settings @@ -49,149 +50,148 @@ import Hasql.Session qualified as Session import Hasql.Statement (Statement) import Hasql.Statement qualified as Statement -import Keiro.Migrations.Internal.Definition ( - embeddedMigrationEntries, +import Keiro.Migrations.Internal.Definition + ( embeddedMigrationEntries, keiroMigrations, - ) + ) -- | Whether a codd ledger makes initializing an empty native ledger unsafe. data CoddLedgerPreflight - = CoddPreflightClear - | CoddPreflightBlocked - { coddLedgerTable :: Text - -- ^ The detected @codd.sql_migrations@ table. - , nativeLedgerAbsent :: Bool - -- ^ 'True' when @pgmigrate.migrations@ is absent; 'False' when it is empty. - } - deriving stock (Eq, Show) + = CoddPreflightClear + | CoddPreflightBlocked + { -- | The detected @codd.sql_migrations@ table. + coddLedgerTable :: Text, + -- | 'True' when @pgmigrate.migrations@ is absent; 'False' when it is empty. + nativeLedgerAbsent :: Bool + } + deriving stock (Eq, Show) -- | Refuse to initialize a fresh native ledger over a retired codd ledger. preflightFreshLedgerOverCodd :: - Settings.Settings -> - IO (Either MigrationError CoddLedgerPreflight) + Settings.Settings -> + IO (Either MigrationError CoddLedgerPreflight) preflightFreshLedgerOverCodd settings = do - acquired <- Connection.acquire settings - case acquired of - Left connectionError -> - pure (Left (ConnectionAcquisitionFailed connectionError)) - Right connection -> do - result <- - Connection.use connection coddLedgerPreflightSession - `finally` Connection.release connection - pure $ case result of - Left sessionError -> Left (DatabaseSessionFailed sessionError) - Right preflight -> Right preflight + acquired <- Connection.acquire settings + case acquired of + Left connectionError -> + pure (Left (ConnectionAcquisitionFailed connectionError)) + Right connection -> do + result <- + Connection.use connection coddLedgerPreflightSession + `finally` Connection.release connection + pure $ case result of + Left sessionError -> Left (DatabaseSessionFailed sessionError) + Right preflight -> Right preflight -- | Render the blocked state as an operator-facing refusal. renderCoddPreflight :: CoddLedgerPreflight -> Text renderCoddPreflight preflight = - case preflight of - CoddPreflightClear -> "" - CoddPreflightBlocked{coddLedgerTable, nativeLedgerAbsent} -> - "refusing to run up: this database has a codd migration ledger (" - <> coddLedgerTable - <> ") and " - <> nativeHistoryState nativeLedgerAbsent - <> ". Running up here would initialize a fresh ledger over the codd one " - <> "and re-plan every migration. Follow " - <> "docs/user/upgrading-to-the-keiro-schema.md (import the codd history " - <> "first), or pass --allow-fresh-ledger-over-codd if a fresh native " - <> "ledger over the retired codd ledger is genuinely intended." + case preflight of + CoddPreflightClear -> "" + CoddPreflightBlocked {coddLedgerTable, nativeLedgerAbsent} -> + "refusing to run up: this database has a codd migration ledger (" + <> coddLedgerTable + <> ") and " + <> nativeHistoryState nativeLedgerAbsent + <> ". Running up here would initialize a fresh ledger over the codd one " + <> "and re-plan every migration. Follow " + <> "docs/user/upgrading-to-the-keiro-schema.md (import the codd history " + <> "first), or pass --allow-fresh-ledger-over-codd if a fresh native " + <> "ledger over the retired codd ledger is genuinely intended." where nativeHistoryState True = "no native pg-migrate history" nativeHistoryState False = "an empty native pg-migrate history" coddLedgerPreflightSession :: Session CoddLedgerPreflight coddLedgerPreflightSession = do - (currentCoddExists, legacyCoddExists, nativeLedgerExists) <- - Session.statement () ledgerPresenceStatement - case detectedCoddLedger currentCoddExists legacyCoddExists of - Nothing -> pure CoddPreflightClear - Just coddLedgerTable - | not nativeLedgerExists -> - pure CoddPreflightBlocked{coddLedgerTable, nativeLedgerAbsent = True} - | otherwise -> do - nativeRows <- Session.statement () nativeLedgerCountStatement - pure $ - if nativeRows == 0 - then - CoddPreflightBlocked - { coddLedgerTable - , nativeLedgerAbsent = False - } - else CoddPreflightClear + (currentCoddExists, legacyCoddExists, nativeLedgerExists) <- + Session.statement () ledgerPresenceStatement + case detectedCoddLedger currentCoddExists legacyCoddExists of + Nothing -> pure CoddPreflightClear + Just coddLedgerTable + | not nativeLedgerExists -> + pure CoddPreflightBlocked {coddLedgerTable, nativeLedgerAbsent = True} + | otherwise -> do + nativeRows <- Session.statement () nativeLedgerCountStatement + pure $ + if nativeRows == 0 + then + CoddPreflightBlocked + { coddLedgerTable, + nativeLedgerAbsent = False + } + else CoddPreflightClear detectedCoddLedger :: Bool -> Bool -> Maybe Text detectedCoddLedger currentCoddExists legacyCoddExists - | currentCoddExists = Just "codd.sql_migrations" - | legacyCoddExists = Just "codd_schema.sql_migrations" - | otherwise = Nothing + | currentCoddExists = Just "codd.sql_migrations" + | legacyCoddExists = Just "codd_schema.sql_migrations" + | otherwise = Nothing ledgerPresenceStatement :: Statement () (Bool, Bool, Bool) ledgerPresenceStatement = - Statement.preparable - """ - SELECT to_regclass('codd.sql_migrations') IS NOT NULL, - to_regclass('codd_schema.sql_migrations') IS NOT NULL, - to_regclass('pgmigrate.migrations') IS NOT NULL - """ - Encoders.noParams - ( Decoders.singleRow - ( (,,) - <$> column Decoders.bool - <*> column Decoders.bool - <*> column Decoders.bool - ) + Statement.preparable + """ + SELECT to_regclass('codd.sql_migrations') IS NOT NULL, + to_regclass('codd_schema.sql_migrations') IS NOT NULL, + to_regclass('pgmigrate.migrations') IS NOT NULL + """ + Encoders.noParams + ( Decoders.singleRow + ( (,,) + <$> column Decoders.bool + <*> column Decoders.bool + <*> column Decoders.bool ) + ) where column = Decoders.column . Decoders.nonNullable nativeLedgerCountStatement :: Statement () Int64 nativeLedgerCountStatement = - Statement.preparable - "SELECT count(*) FROM pgmigrate.migrations" - Encoders.noParams - (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.int8))) + Statement.preparable + "SELECT count(*) FROM pgmigrate.migrations" + Encoders.noParams + (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.int8))) -- | Boot-time answer to "does this database carry every migration this binary expects?". data StartupHandshake = StartupHandshake - { pendingMigrations :: [MigrationId] - -- ^ Declared migrations with no applied ledger row, in plan order. - , ledgerIssues :: [VerificationIssue] - -- ^ Checksum, position, kind, gap, status, or unknown-row problems. - } - deriving stock (Eq, Show) + { -- | Declared migrations with no applied ledger row, in plan order. + pendingMigrations :: [MigrationId], + -- | Checksum, position, kind, gap, status, or unknown-row problems. + ledgerIssues :: [VerificationIssue] + } + deriving stock (Eq, Show) -- | Whether the database is safe for this binary to serve requests. handshakePassed :: StartupHandshake -> Bool handshakePassed handshake = - null (pendingMigrations handshake) && null (ledgerIssues handshake) + null (pendingMigrations handshake) && null (ledgerIssues handshake) -- | Read-only boot-time migration check; safe to call from every replica. missingMigrations :: - RunOptions -> - ConnectionProvider -> - MigrationPlan -> - IO (Either MigrationError StartupHandshake) + RunOptions -> + ConnectionProvider -> + MigrationPlan -> + IO (Either MigrationError StartupHandshake) missingMigrations options provider plan = - fmap toStartupHandshake <$> migrationStatusWith options provider plan + fmap toStartupHandshake <$> migrationStatusWith options provider plan where toStartupHandshake :: Migrate.StatusReport -> StartupHandshake toStartupHandshake (Migrate.StatusReport statusIssues _ pending _) = - StartupHandshake - { pendingMigrations = pending - , ledgerIssues = statusIssues - } - -{- | Compose the concrete Kiroku and Keiro components in dependency order. + StartupHandshake + { pendingMigrations = pending, + ledgerIssues = statusIssues + } -The first argument must be Kiroku's component and the second must be Keiro's. -The native planner validates both identity and ordering, so swapped or unrelated -components fail with a structured 'PlanError'. --} +-- | Compose the concrete Kiroku and Keiro components in dependency order. +-- +-- The first argument must be Kiroku's component and the second must be Keiro's. +-- The native planner validates both identity and ordering, so swapped or unrelated +-- components fail with a structured 'PlanError'. frameworkMigrationPlan :: - MigrationComponent -> - MigrationComponent -> - Either PlanError MigrationPlan + MigrationComponent -> + MigrationComponent -> + Either PlanError MigrationPlan frameworkMigrationPlan kiroku keiro = - migrationPlan (kiroku :| [keiro]) + migrationPlan (kiroku :| [keiro]) diff --git a/src/Keiro/Migrations/ExpectedSchema.hs b/src/Keiro/Migrations/ExpectedSchema.hs --- a/src/Keiro/Migrations/ExpectedSchema.hs +++ b/src/Keiro/Migrations/ExpectedSchema.hs @@ -1,9 +1,10 @@ {-# LANGUAGE TemplateHaskell #-} -module Keiro.Migrations.ExpectedSchema ( - expectedSchemaFiles, +module Keiro.Migrations.ExpectedSchema + ( expectedSchemaFiles, withMaterializedExpectedSchema, -) where + ) +where import Codd.Extras.ExpectedSchema qualified as ExpectedSchema import Data.ByteString (ByteString) @@ -16,4 +17,4 @@ withMaterializedExpectedSchema :: (FilePath -> IO a) -> IO a withMaterializedExpectedSchema action = - ExpectedSchema.withMaterializedExpectedSchema "keiro-expected-schema" expectedSchemaFiles action + ExpectedSchema.withMaterializedExpectedSchema "keiro-expected-schema" expectedSchemaFiles action diff --git a/src/Keiro/Migrations/History/Codd.hs b/src/Keiro/Migrations/History/Codd.hs --- a/src/Keiro/Migrations/History/Codd.hs +++ b/src/Keiro/Migrations/History/Codd.hs @@ -1,13 +1,14 @@ {-# LANGUAGE TemplateHaskell #-} -module Keiro.Migrations.History.Codd ( - frameworkCoddHistoryMappings, +module Keiro.Migrations.History.Codd + ( frameworkCoddHistoryMappings, frameworkCoddSourceConfig, keiroCoddHistoryMappings, keiroCoddManifestText, keiroCoddSourcePayloads, keiroLegacyMigrationNames, -) where + ) +where import Data.Bifunctor (first) import Data.ByteString (ByteString) @@ -15,113 +16,113 @@ import Data.List.NonEmpty (NonEmpty (..)) import Data.Map.Strict qualified as Map import Data.Text (Text) -import Database.PostgreSQL.Migrate ( - Confirmation, +import Database.PostgreSQL.Migrate + ( Confirmation, ConnectionProvider, EvidenceRequirement (Evidence), HistoryMapping, PayloadRelation (SamePayload), historyMapping, migrationId, - ) -import Database.PostgreSQL.Migrate.History.Codd ( - CoddDefinitionError, + ) +import Database.PostgreSQL.Migrate.History.Codd + ( CoddDefinitionError, CoddSourceConfig, coddEvidenceKey, coddSourceConfig, parseCoddManifest, - ) + ) import Keiro.Migrations.Internal.Definition (embeddedMigrationEntries) import Keiro.Migrations.Internal.EmbedFile (embedTextFile) import Kiroku.Store.Migrations.History.Codd qualified as Kiroku keiroLegacyMigrationNames :: NonEmpty FilePath keiroLegacyMigrationNames = - "2026-05-17-13-58-15-keiro-bootstrap.sql" - :| [ "2026-05-19-12-55-02-keiro-outbox.sql" - , "2026-05-19-13-05-23-keiro-inbox.sql" - , "2026-06-03-05-14-28-keiro-timer-recovery.sql" - , "2026-06-03-16-10-05-keiro-workflow-steps.sql" - , "2026-06-03-18-19-41-keiro-awakeables.sql" - , "2026-06-03-19-49-23-keiro-workflow-children.sql" - , "2026-06-04-02-12-28-keiro-workflow-generation.sql" - , "2026-06-04-03-53-34-keiro-subscription-shards.sql" - , "2026-06-15-13-22-31-keiro-messaging-crash-recovery.sql" - , "2026-06-15-15-07-25-keiro-workflows-instances.sql" - , "2026-06-15-17-53-48-keiro-workflow-gc-index.sql" - , "2026-06-15-18-01-33-keiro-workflows-wake-after.sql" - , "2026-06-15-21-49-37-keiro-projection-dedup.sql" - , "2026-07-02-00-15-48-keiro-outbox-claim-order-index.sql" - , "2026-07-02-00-58-54-keiro-inbox-drop-received-idx.sql" - ] + "2026-05-17-13-58-15-keiro-bootstrap.sql" + :| [ "2026-05-19-12-55-02-keiro-outbox.sql", + "2026-05-19-13-05-23-keiro-inbox.sql", + "2026-06-03-05-14-28-keiro-timer-recovery.sql", + "2026-06-03-16-10-05-keiro-workflow-steps.sql", + "2026-06-03-18-19-41-keiro-awakeables.sql", + "2026-06-03-19-49-23-keiro-workflow-children.sql", + "2026-06-04-02-12-28-keiro-workflow-generation.sql", + "2026-06-04-03-53-34-keiro-subscription-shards.sql", + "2026-06-15-13-22-31-keiro-messaging-crash-recovery.sql", + "2026-06-15-15-07-25-keiro-workflows-instances.sql", + "2026-06-15-17-53-48-keiro-workflow-gc-index.sql", + "2026-06-15-18-01-33-keiro-workflows-wake-after.sql", + "2026-06-15-21-49-37-keiro-projection-dedup.sql", + "2026-07-02-00-15-48-keiro-outbox-claim-order-index.sql", + "2026-07-02-00-58-54-keiro-inbox-drop-received-idx.sql" + ] keiroCoddHistoryMappings :: NonEmpty HistoryMapping keiroCoddHistoryMappings = - zipWithNonEmpty mapping keiroLegacyMigrationNames nativeMigrationNames + zipWithNonEmpty mapping keiroLegacyMigrationNames nativeMigrationNames where mapping sourceFilename targetName = - historyMapping - (definitionInvariant (migrationId "keiro" targetName)) - (Evidence sourceKey) - (SamePayload sourceKey) + historyMapping + (definitionInvariant (migrationId "keiro" targetName)) + (Evidence sourceKey) + (SamePayload sourceKey) where sourceKey = definitionInvariant (first show (coddEvidenceKey sourceFilename)) frameworkCoddHistoryMappings :: NonEmpty HistoryMapping frameworkCoddHistoryMappings = - Kiroku.kirokuCoddHistoryMappings <> keiroCoddHistoryMappings + Kiroku.kirokuCoddHistoryMappings <> keiroCoddHistoryMappings frameworkCoddSourceConfig :: - ConnectionProvider -> - Bool -> - Text -> - Confirmation -> - Either CoddDefinitionError CoddSourceConfig + ConnectionProvider -> + Bool -> + Text -> + Confirmation -> + Either CoddDefinitionError CoddSourceConfig frameworkCoddSourceConfig sourceProvider strictSource reason confirmation = - coddSourceConfig - sourceProvider - (Kiroku.kirokuLegacyMigrationNames <> keiroLegacyMigrationNames) - strictSource - (Kiroku.kirokuCoddSourcePayloads <> keiroCoddSourcePayloads) - (Just combinedManifest) - reason - confirmation + coddSourceConfig + sourceProvider + (Kiroku.kirokuLegacyMigrationNames <> keiroLegacyMigrationNames) + strictSource + (Kiroku.kirokuCoddSourcePayloads <> keiroCoddSourcePayloads) + (Just combinedManifest) + reason + confirmation where combinedManifest = - definitionInvariant - (parseCoddManifest (Kiroku.kirokuCoddManifestText <> keiroCoddManifestText)) + definitionInvariant + (parseCoddManifest (Kiroku.kirokuCoddManifestText <> keiroCoddManifestText)) nativeMigrationNames :: NonEmpty Text nativeMigrationNames = - "0001-keiro-bootstrap" - :| [ "0002-keiro-outbox" - , "0003-keiro-inbox" - , "0004-keiro-timer-recovery" - , "0005-keiro-workflow-steps" - , "0006-keiro-awakeables" - , "0007-keiro-workflow-children" - , "0008-keiro-workflow-generation" - , "0009-keiro-subscription-shards" - , "0010-keiro-messaging-crash-recovery" - , "0011-keiro-workflows-instances" - , "0012-keiro-workflow-gc-index" - , "0013-keiro-workflows-wake-after" - , "0014-keiro-projection-dedup" - , "0015-keiro-outbox-claim-order-index" - , "0016-keiro-inbox-drop-received-idx" - ] + "0001-keiro-bootstrap" + :| [ "0002-keiro-outbox", + "0003-keiro-inbox", + "0004-keiro-timer-recovery", + "0005-keiro-workflow-steps", + "0006-keiro-awakeables", + "0007-keiro-workflow-children", + "0008-keiro-workflow-generation", + "0009-keiro-subscription-shards", + "0010-keiro-messaging-crash-recovery", + "0011-keiro-workflows-instances", + "0012-keiro-workflow-gc-index", + "0013-keiro-workflows-wake-after", + "0014-keiro-projection-dedup", + "0015-keiro-outbox-claim-order-index", + "0016-keiro-inbox-drop-received-idx" + ] keiroCoddSourcePayloads :: Map.Map FilePath ByteString keiroCoddSourcePayloads = - Map.fromList - (zip (toList keiroLegacyMigrationNames) (snd <$> toList embeddedMigrationEntries)) + Map.fromList + (zip (toList keiroLegacyMigrationNames) (snd <$> toList embeddedMigrationEntries)) keiroCoddManifestText :: Text keiroCoddManifestText = $(embedTextFile "migrations.lock") zipWithNonEmpty :: (a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c zipWithNonEmpty combine (firstA :| restA) (firstB :| restB) = - combine firstA firstB :| zipWith combine restA restB + combine firstA firstB :| zipWith combine restA restB definitionInvariant :: (Show error) => Either error value -> value definitionInvariant = either (error . ("invalid checked-in Keiro migration definition: " <>) . show) id diff --git a/src/Keiro/Migrations/Internal/Definition.hs b/src/Keiro/Migrations/Internal/Definition.hs --- a/src/Keiro/Migrations/Internal/Definition.hs +++ b/src/Keiro/Migrations/Internal/Definition.hs @@ -9,28 +9,29 @@ -- runtime regardless. {-# OPTIONS_GHC -fplugin=Database.PostgreSQL.Migrate.Embed.RecompilePlugin #-} -module Keiro.Migrations.Internal.Definition ( - embeddedMigrationEntries, +module Keiro.Migrations.Internal.Definition + ( embeddedMigrationEntries, keiroMigrations, -) where + ) +where import Data.ByteString (ByteString) import Data.List.NonEmpty (NonEmpty) import Data.Set qualified as Set -import Database.PostgreSQL.Migrate ( - DefinitionError, +import Database.PostgreSQL.Migrate + ( DefinitionError, MigrationComponent, migrationComponentFromEmbeddedSql, - ) + ) import Database.PostgreSQL.Migrate.Embed (embedMigrationManifest) embeddedMigrationEntries :: NonEmpty (FilePath, ByteString) embeddedMigrationEntries = - $(embedMigrationManifest "migrations/manifest") + $(embedMigrationManifest "migrations/manifest") keiroMigrations :: Either DefinitionError MigrationComponent keiroMigrations = - migrationComponentFromEmbeddedSql - "keiro" - (Set.singleton "kiroku") - embeddedMigrationEntries + migrationComponentFromEmbeddedSql + "keiro" + (Set.singleton "kiroku") + embeddedMigrationEntries diff --git a/src/Keiro/Migrations/Internal/EmbedFile.hs b/src/Keiro/Migrations/Internal/EmbedFile.hs --- a/src/Keiro/Migrations/Internal/EmbedFile.hs +++ b/src/Keiro/Migrations/Internal/EmbedFile.hs @@ -10,10 +10,10 @@ embedTextFile :: FilePath -> Q Exp embedTextFile inputPath = do - path <- TH.makeRelativeToProject inputPath - TH.addDependentFile path - bytes <- TH.runIO (ByteString.readFile path) - case Text.Encoding.decodeUtf8' bytes of - Left decodeError -> fail ("invalid UTF-8 in " <> path <> ": " <> show decodeError) - Right contents -> - pure (AppE (VarE 'Text.pack) (LitE (StringL (Text.unpack contents)))) + path <- TH.makeRelativeToProject inputPath + TH.addDependentFile path + bytes <- TH.runIO (ByteString.readFile path) + case Text.Encoding.decodeUtf8' bytes of + Left decodeError -> fail ("invalid UTF-8 in " <> path <> ": " <> show decodeError) + Right contents -> + pure (AppE (VarE 'Text.pack) (LitE (StringL (Text.unpack contents)))) diff --git a/src/Keiro/Migrations/LegacyCodd.hs b/src/Keiro/Migrations/LegacyCodd.hs --- a/src/Keiro/Migrations/LegacyCodd.hs +++ b/src/Keiro/Migrations/LegacyCodd.hs @@ -1,13 +1,12 @@ {-# LANGUAGE TemplateHaskell #-} -{- | Transitional Codd-only tools retained for expected-schema snapshots, -remediation drills, and historical ledger fixups. - -Normal migration execution uses 'Keiro.Migrations' and does not build this -module unless the @legacy-codd-tools@ Cabal flag is enabled. --} -module Keiro.Migrations.LegacyCodd ( - LedgerSchema (..), +-- | Transitional Codd-only tools retained for expected-schema snapshots, +-- remediation drills, and historical ledger fixups. +-- +-- Normal migration execution uses 'Keiro.Migrations' and does not build this +-- module unless the @legacy-codd-tools@ Cabal flag is enabled. +module Keiro.Migrations.LegacyCodd + ( LedgerSchema (..), MigrationStatus (..), VerifyOutcome (..), embeddedMigrationNames, @@ -19,7 +18,8 @@ runAllKeiroMigrationsNoCheck, runKirokuMigrationsNoCheck, verifySchema, -) where + ) +where import Codd (ApplyResult, CoddSettings (..), VerifySchemas) import Codd.Extras.Ledger (LedgerSchema (..), MigrationStatus (..), VerifyOutcome (..)) @@ -37,67 +37,67 @@ runAllKeiroMigrations :: CoddSettings -> DiffTime -> VerifySchemas -> IO ApplyResult runAllKeiroMigrations settings connectTimeout verifySchemas = - MigrationSet.applyMigrationSets settings connectTimeout verifySchemas frameworkMigrationSets + MigrationSet.applyMigrationSets settings connectTimeout verifySchemas frameworkMigrationSets runAllKeiroMigrationsNoCheck :: CoddSettings -> DiffTime -> IO () runAllKeiroMigrationsNoCheck settings connectTimeout = - void $ MigrationSet.applyMigrationSetsNoCheck settings connectTimeout frameworkMigrationSets + void $ MigrationSet.applyMigrationSetsNoCheck settings connectTimeout frameworkMigrationSets runKirokuMigrationsNoCheck :: CoddSettings -> DiffTime -> IO () runKirokuMigrationsNoCheck settings connectTimeout = - void $ MigrationSet.applyMigrationSetNoCheck settings connectTimeout kirokuMigrationSet + void $ MigrationSet.applyMigrationSetNoCheck settings connectTimeout kirokuMigrationSet verifySchema :: CoddSettings -> DiffTime -> IO VerifyOutcome verifySchema = - MigrationSet.verifyExpectedSchema - expectedLedgerNames - MigrationSet.ExpectedSchema - { MigrationSet.label = "keiro-expected-schema" - , MigrationSet.files = expectedSchemaFiles - } + MigrationSet.verifyExpectedSchema + expectedLedgerNames + MigrationSet.ExpectedSchema + { MigrationSet.label = "keiro-expected-schema", + MigrationSet.files = expectedSchemaFiles + } missingMigrations :: CoddSettings -> DiffTime -> IO [FilePath] missingMigrations settings connectTimeout = - MigrationSet.missingMigrationsForNames expectedLedgerNames (migsConnString settings) connectTimeout + MigrationSet.missingMigrationsForNames expectedLedgerNames (migsConnString settings) connectTimeout migrationStatus :: CoddSettings -> DiffTime -> IO MigrationStatus migrationStatus settings connectTimeout = - MigrationSet.migrationStatusForNames expectedLedgerNames (migsConnString settings) connectTimeout + MigrationSet.migrationStatusForNames expectedLedgerNames (migsConnString settings) connectTimeout frameworkMigrationSets :: [MigrationSet] frameworkMigrationSets = - [ kirokuMigrationSet - , keiroMigrationSet - ] + [ kirokuMigrationSet, + keiroMigrationSet + ] kirokuMigrationSet :: MigrationSet kirokuMigrationSet = - MigrationSet.MigrationSet - { MigrationSet.label = "Kiroku legacy evidence" - , MigrationSet.files = sourceFiles Kiroku.kirokuLegacyMigrationNames Kiroku.kirokuCoddSourcePayloads - } + MigrationSet.MigrationSet + { MigrationSet.label = "Kiroku legacy evidence", + MigrationSet.files = sourceFiles Kiroku.kirokuLegacyMigrationNames Kiroku.kirokuCoddSourcePayloads + } keiroMigrationSet :: MigrationSet keiroMigrationSet = - MigrationSet.MigrationSet - { MigrationSet.label = "Keiro legacy evidence" - , MigrationSet.files = embeddedMigrationFiles - } + MigrationSet.MigrationSet + { MigrationSet.label = "Keiro legacy evidence", + MigrationSet.files = embeddedMigrationFiles + } sourceFiles :: - (Foldable collection) => - collection FilePath -> - Map.Map FilePath ByteString -> - [(FilePath, ByteString)] + (Foldable collection) => + collection FilePath -> + Map.Map FilePath ByteString -> + [(FilePath, ByteString)] sourceFiles names payloads = - [ (name, requirePayload name) - | name <- toList names - ] + [ (name, requirePayload name) + | name <- toList names + ] where requirePayload name = - case Map.lookup name payloads of - Just payload -> payload - Nothing -> error ("missing checked-in legacy payload for " <> name) + case Map.lookup name payloads of + Just payload -> payload + Nothing -> error ("missing checked-in legacy payload for " <> name) embeddedMigrationFiles :: [(FilePath, ByteString)] embeddedMigrationFiles = $(embedDir "sql-migrations") @@ -107,12 +107,12 @@ embeddedMigrationNames :: [FilePath] embeddedMigrationNames = - MigrationSet.migrationNames keiroMigrationSet + MigrationSet.migrationNames keiroMigrationSet kirokuEmbeddedMigrationNames :: [FilePath] kirokuEmbeddedMigrationNames = - MigrationSet.migrationNames kirokuMigrationSet + MigrationSet.migrationNames kirokuMigrationSet expectedLedgerNames :: [FilePath] expectedLedgerNames = - MigrationSet.migrationNamesForSets frameworkMigrationSets + MigrationSet.migrationNamesForSets frameworkMigrationSets diff --git a/src/Keiro/Migrations/New.hs b/src/Keiro/Migrations/New.hs --- a/src/Keiro/Migrations/New.hs +++ b/src/Keiro/Migrations/New.hs @@ -1,18 +1,18 @@ -{- | Generate a new timestamped Keiro migration skeleton. - -The embedded migrations are ordered by their @YYYY-MM-DD-HH-MM-SS-slug.sql@ -file names (lexicographic order == chronological order because every field is -fixed-width and zero-padded). 'newMigrationFile' stamps the /real/ current UTC -time, so two migrations authored at different moments can never collide and -always sort in authoring order -- no hand-assigned slots to coordinate. --} -module Keiro.Migrations.New ( - newMigrationFile, +-- | Generate a new timestamped Keiro migration skeleton. +-- +-- The embedded migrations are ordered by their @YYYY-MM-DD-HH-MM-SS-slug.sql@ +-- file names (lexicographic order == chronological order because every field is +-- fixed-width and zero-padded). 'newMigrationFile' stamps the /real/ current UTC +-- time, so two migrations authored at different moments can never collide and +-- always sort in authoring order -- no hand-assigned slots to coordinate. +module Keiro.Migrations.New + ( newMigrationFile, defaultMigrationsDir, migrationFileName, migrationSlug, migrationTemplate, -) where + ) +where import Codd.Extras.New qualified as New import Data.Time (UTCTime) @@ -31,21 +31,21 @@ migrationTemplate :: String -> String migrationTemplate description = - unlines - [ "-- " <> description - , "--" - , "-- Create objects fully qualified in the keiro schema (no session path pin)." - , "-- Example:" - , "-- CREATE TABLE IF NOT EXISTS keiro.keiro_example (" - , "-- id UUID PRIMARY KEY" - , "-- );" - , "" - , "-- TODO: write the migration body. Prefer idempotent DDL (IF NOT EXISTS)." - ] + unlines + [ "-- " <> description, + "--", + "-- Create objects fully qualified in the keiro schema (no session path pin).", + "-- Example:", + "-- CREATE TABLE IF NOT EXISTS keiro.keiro_example (", + "-- id UUID PRIMARY KEY", + "-- );", + "", + "-- TODO: write the migration body. Prefer idempotent DDL (IF NOT EXISTS)." + ] migrationFileConfig :: New.MigrationFileConfig migrationFileConfig = - New.MigrationFileConfig - { New.migrationSlugPrefix = Just "keiro" - , New.migrationTemplate = migrationTemplate - } + New.MigrationFileConfig + { New.migrationSlugPrefix = Just "keiro", + New.migrationTemplate = migrationTemplate + } diff --git a/src/Keiro/Migrations/SchemaCheck.hs b/src/Keiro/Migrations/SchemaCheck.hs --- a/src/Keiro/Migrations/SchemaCheck.hs +++ b/src/Keiro/Migrations/SchemaCheck.hs @@ -1,13 +1,14 @@ {-# LANGUAGE TemplateHaskell #-} -module Keiro.Migrations.SchemaCheck ( - SchemaDrift (..), +module Keiro.Migrations.SchemaCheck + ( SchemaDrift (..), compareSchemaSnapshot, expectedSchemaSnapshot, renderSchemaDrift, snapshotSchema, verifyExpectedSchema, -) where + ) +where import Control.Exception (finally) import Data.Int (Int32) @@ -30,196 +31,196 @@ -- | One named difference between the expected and live schema snapshots. data SchemaDrift - = MissingObject Text - | UnexpectedObject Text - | ChangedObject - { driftKey :: Text - , expectedDefinition :: Text - , actualDefinition :: Text - } - deriving stock (Eq, Show) + = MissingObject Text + | UnexpectedObject Text + | ChangedObject + { driftKey :: Text, + expectedDefinition :: Text, + actualDefinition :: Text + } + deriving stock (Eq, Show) -- | Compare canonical snapshots by their @kindname@ object identity. compareSchemaSnapshot :: Text -> Text -> [SchemaDrift] compareSchemaSnapshot expected actual = - mapMaybe driftFor allKeys + mapMaybe driftFor allKeys where expectedObjects = snapshotObjects expected actualObjects = snapshotObjects actual allKeys = - Set.toAscList - (Map.keysSet expectedObjects `Set.union` Map.keysSet actualObjects) + Set.toAscList + (Map.keysSet expectedObjects `Set.union` Map.keysSet actualObjects) driftFor key = - case (Map.lookup key expectedObjects, Map.lookup key actualObjects) of - (Just (expectedLine, _), Nothing) -> - Just (MissingObject expectedLine) - (Nothing, Just (actualLine, _)) -> - Just (UnexpectedObject actualLine) - (Just (_, expectedValue), Just (_, actualValue)) - | expectedValue /= actualValue -> - Just - ChangedObject - { driftKey = key - , expectedDefinition = expectedValue - , actualDefinition = actualValue - } - _ -> Nothing + case (Map.lookup key expectedObjects, Map.lookup key actualObjects) of + (Just (expectedLine, _), Nothing) -> + Just (MissingObject expectedLine) + (Nothing, Just (actualLine, _)) -> + Just (UnexpectedObject actualLine) + (Just (_, expectedValue), Just (_, actualValue)) + | expectedValue /= actualValue -> + Just + ChangedObject + { driftKey = key, + expectedDefinition = expectedValue, + actualDefinition = actualValue + } + _ -> Nothing -- | Render a drift as one operator-facing line with the affected object name. renderSchemaDrift :: SchemaDrift -> Text renderSchemaDrift drift = - case drift of - MissingObject line -> - let (kind, name, definition) = splitSnapshotLine line - in "schema drift: missing " - <> kind - <> " " - <> name - <> " (expected: " - <> definition - <> ")" - UnexpectedObject line -> - let (kind, name, definition) = splitSnapshotLine line - in "schema drift: unexpected " - <> kind - <> " " - <> name - <> " (actual: " - <> definition - <> ")" - ChangedObject{driftKey, expectedDefinition, actualDefinition} -> - let (kind, name) = splitSnapshotKey driftKey - in "schema drift: changed " - <> kind - <> " " - <> name - <> " (expected: " - <> expectedDefinition - <> "; actual: " - <> actualDefinition - <> ")" + case drift of + MissingObject line -> + let (kind, name, definition) = splitSnapshotLine line + in "schema drift: missing " + <> kind + <> " " + <> name + <> " (expected: " + <> definition + <> ")" + UnexpectedObject line -> + let (kind, name, definition) = splitSnapshotLine line + in "schema drift: unexpected " + <> kind + <> " " + <> name + <> " (actual: " + <> definition + <> ")" + ChangedObject {driftKey, expectedDefinition, actualDefinition} -> + let (kind, name) = splitSnapshotKey driftKey + in "schema drift: changed " + <> kind + <> " " + <> name + <> " (expected: " + <> expectedDefinition + <> "; actual: " + <> actualDefinition + <> ")" -- | Read a sorted canonical snapshot of tables, columns, constraints, and indexes. snapshotSchema :: Text -> Session Text snapshotSchema schema = - Text.unlines <$> Session.statement schema schemaSnapshotStatement + Text.unlines <$> Session.statement schema schemaSnapshotStatement -- | PostgreSQL 18 snapshot generated from the complete embedded migration plan. expectedSchemaSnapshot :: Text expectedSchemaSnapshot = - $(embedTextFile "expected-schema/native/keiro-v18.txt") + $(embedTextFile "expected-schema/native/keiro-v18.txt") -- | Compare the live @keiro@ schema with the embedded PostgreSQL 18 snapshot. verifyExpectedSchema :: - Settings.Settings -> - IO (Either MigrationError [SchemaDrift]) + Settings.Settings -> + IO (Either MigrationError [SchemaDrift]) verifyExpectedSchema settings = do - acquired <- Connection.acquire settings - case acquired of - Left connectionError -> - pure (Left (ConnectionAcquisitionFailed connectionError)) - Right connection -> do - result <- - Connection.use connection liveSnapshotSession - `finally` Connection.release connection - pure $ case result of - Left sessionError -> Left (DatabaseSessionFailed sessionError) - Right (Left migrationError) -> Left migrationError - Right (Right actual) -> - Right (compareSchemaSnapshot expectedSchemaSnapshot actual) + acquired <- Connection.acquire settings + case acquired of + Left connectionError -> + pure (Left (ConnectionAcquisitionFailed connectionError)) + Right connection -> do + result <- + Connection.use connection liveSnapshotSession + `finally` Connection.release connection + pure $ case result of + Left sessionError -> Left (DatabaseSessionFailed sessionError) + Right (Left migrationError) -> Left migrationError + Right (Right actual) -> + Right (compareSchemaSnapshot expectedSchemaSnapshot actual) where liveSnapshotSession :: Session (Either MigrationError Text) liveSnapshotSession = do - serverVersionNumber <- Session.statement () serverVersionStatement - let majorVersion = fromIntegral serverVersionNumber `div` 10000 - if majorVersion == (18 :: Int) - then Right <$> snapshotSchema "keiro" - else pure (Left (UnsupportedPostgresVersion majorVersion)) + serverVersionNumber <- Session.statement () serverVersionStatement + let majorVersion = fromIntegral serverVersionNumber `div` 10000 + if majorVersion == (18 :: Int) + then Right <$> snapshotSchema "keiro" + else pure (Left (UnsupportedPostgresVersion majorVersion)) snapshotObjects :: Text -> Map Text (Text, Text) snapshotObjects = - Map.fromList . mapMaybe parseSnapshotLine . Text.lines + Map.fromList . mapMaybe parseSnapshotLine . Text.lines where parseSnapshotLine line = - case Text.splitOn "\t" line of - kind : name : definitionParts -> - Just - ( kind <> "\t" <> name - , (line, Text.intercalate "\t" definitionParts) - ) - _ -> Nothing + case Text.splitOn "\t" line of + kind : name : definitionParts -> + Just + ( kind <> "\t" <> name, + (line, Text.intercalate "\t" definitionParts) + ) + _ -> Nothing splitSnapshotLine :: Text -> (Text, Text, Text) splitSnapshotLine line = - case Text.splitOn "\t" line of - kind : name : definitionParts -> - (kind, name, Text.intercalate "\t" definitionParts) - _ -> ("object", line, line) + case Text.splitOn "\t" line of + kind : name : definitionParts -> + (kind, name, Text.intercalate "\t" definitionParts) + _ -> ("object", line, line) splitSnapshotKey :: Text -> (Text, Text) splitSnapshotKey key = - case Text.splitOn "\t" key of - [kind, name] -> (kind, name) - _ -> ("object", key) + case Text.splitOn "\t" key of + [kind, name] -> (kind, name) + _ -> ("object", key) schemaSnapshotStatement :: Statement Text [Text] schemaSnapshotStatement = - Statement.preparable - """ - WITH configured AS MATERIALIZED ( - SELECT set_config('search_path', 'pg_catalog', true) AS search_path - ) - SELECT line - FROM configured - CROSS JOIN LATERAL ( - SELECT 'table' || E'\t' || c.relname || E'\t' || 'kind=r' AS line - FROM pg_class c - JOIN pg_namespace n ON n.oid = c.relnamespace - WHERE n.nspname = $1 - AND c.relkind = 'r' - AND configured.search_path = 'pg_catalog' - UNION ALL - SELECT 'column' || E'\t' || c.relname || '.' || a.attname || E'\t' - || format_type(a.atttypid, a.atttypmod) - || CASE WHEN a.attnotnull THEN ' not null' ELSE '' END - || coalesce(' default ' || pg_get_expr(d.adbin, d.adrelid), '') - FROM pg_attribute a - JOIN pg_class c ON c.oid = a.attrelid - JOIN pg_namespace n ON n.oid = c.relnamespace - LEFT JOIN pg_attrdef d - ON d.adrelid = a.attrelid AND d.adnum = a.attnum - WHERE n.nspname = $1 - AND c.relkind = 'r' - AND a.attnum > 0 - AND NOT a.attisdropped - AND configured.search_path = 'pg_catalog' - UNION ALL - SELECT 'constraint' || E'\t' || rel.relname || '.' || con.conname || E'\t' - || pg_get_constraintdef(con.oid) - FROM pg_constraint con - JOIN pg_class rel ON rel.oid = con.conrelid - JOIN pg_namespace n ON n.oid = rel.relnamespace - WHERE n.nspname = $1 - AND configured.search_path = 'pg_catalog' - UNION ALL - SELECT 'index' || E'\t' || ci.relname || E'\t' - || pg_get_indexdef(i.indexrelid) - FROM pg_index i - JOIN pg_class ci ON ci.oid = i.indexrelid - JOIN pg_class ct ON ct.oid = i.indrelid - JOIN pg_namespace n ON n.oid = ct.relnamespace - WHERE n.nspname = $1 - AND configured.search_path = 'pg_catalog' - ) snapshot - ORDER BY line COLLATE "C" - """ - (Encoders.param (Encoders.nonNullable Encoders.text)) - (Decoders.rowList (Decoders.column (Decoders.nonNullable Decoders.text))) + Statement.preparable + """ + WITH configured AS MATERIALIZED ( + SELECT set_config('search_path', 'pg_catalog', true) AS search_path + ) + SELECT line + FROM configured + CROSS JOIN LATERAL ( + SELECT 'table' || E'\t' || c.relname || E'\t' || 'kind=r' AS line + FROM pg_class c + JOIN pg_namespace n ON n.oid = c.relnamespace + WHERE n.nspname = $1 + AND c.relkind = 'r' + AND configured.search_path = 'pg_catalog' + UNION ALL + SELECT 'column' || E'\t' || c.relname || '.' || a.attname || E'\t' + || format_type(a.atttypid, a.atttypmod) + || CASE WHEN a.attnotnull THEN ' not null' ELSE '' END + || coalesce(' default ' || pg_get_expr(d.adbin, d.adrelid), '') + FROM pg_attribute a + JOIN pg_class c ON c.oid = a.attrelid + JOIN pg_namespace n ON n.oid = c.relnamespace + LEFT JOIN pg_attrdef d + ON d.adrelid = a.attrelid AND d.adnum = a.attnum + WHERE n.nspname = $1 + AND c.relkind = 'r' + AND a.attnum > 0 + AND NOT a.attisdropped + AND configured.search_path = 'pg_catalog' + UNION ALL + SELECT 'constraint' || E'\t' || rel.relname || '.' || con.conname || E'\t' + || pg_get_constraintdef(con.oid) + FROM pg_constraint con + JOIN pg_class rel ON rel.oid = con.conrelid + JOIN pg_namespace n ON n.oid = rel.relnamespace + WHERE n.nspname = $1 + AND configured.search_path = 'pg_catalog' + UNION ALL + SELECT 'index' || E'\t' || ci.relname || E'\t' + || pg_get_indexdef(i.indexrelid) + FROM pg_index i + JOIN pg_class ci ON ci.oid = i.indexrelid + JOIN pg_class ct ON ct.oid = i.indrelid + JOIN pg_namespace n ON n.oid = ct.relnamespace + WHERE n.nspname = $1 + AND configured.search_path = 'pg_catalog' + ) snapshot + ORDER BY line COLLATE "C" + """ + (Encoders.param (Encoders.nonNullable Encoders.text)) + (Decoders.rowList (Decoders.column (Decoders.nonNullable Decoders.text))) serverVersionStatement :: Statement () Int32 serverVersionStatement = - Statement.preparable - "SELECT current_setting('server_version_num')::integer" - Encoders.noParams - (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.int4))) + Statement.preparable + "SELECT current_setting('server_version_num')::integer" + Encoders.noParams + (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.int4))) diff --git a/test-legacy/Main.hs b/test-legacy/Main.hs --- a/test-legacy/Main.hs +++ b/test-legacy/Main.hs @@ -1,6 +1,6 @@ -module Main ( - main, -) +module Main + ( main, + ) where import Codd (ApplyResult (..), CoddSettings (..), VerifySchemas (LaxCheck, StrictCheck)) @@ -26,8 +26,8 @@ import Hasql.Pool.Config qualified as Pool.Config import Hasql.Session qualified as Session import Hasql.Statement (Statement, preparable) -import Keiro.Migrations.LegacyCodd ( - MigrationStatus (..), +import Keiro.Migrations.LegacyCodd + ( MigrationStatus (..), VerifyOutcome (..), embeddedMigrationNames, embeddedMigrationSources, @@ -38,367 +38,363 @@ runAllKeiroMigrationsNoCheck, runKirokuMigrationsNoCheck, verifySchema, - ) + ) import Keiro.Migrations.New (migrationFileName, migrationSlug, newMigrationFile) import System.Directory (doesDirectoryExist, doesFileExist, listDirectory) import System.FilePath (takeFileName) import System.IO.Temp (withSystemTempDirectory) import Test.Hspec -{- | Pin the ephemeral PostgreSQL superuser to the fixed name @keiro@ so the -captured snapshot identity (roles, database owner, per-object owners) is -deterministic across machines and CI rather than the local OS username. This is -the portability fix for the strict drift gate. --} +-- | Pin the ephemeral PostgreSQL superuser to the fixed name @keiro@ so the +-- captured snapshot identity (roles, database owner, per-object owners) is +-- deterministic across machines and CI rather than the local OS username. This is +-- the portability fix for the strict drift gate. keiroPgConfig :: Pg.Config -keiroPgConfig = Pg.defaultConfig{Pg.user = "keiro"} +keiroPgConfig = Pg.defaultConfig {Pg.user = "keiro"} -{- | Start a cached ephemeral server whose PostgreSQL superuser is the fixed -name @keiro@. Mirrors 'Pg.withCached' but pins the user; 'Pg.withCachedConfig' -is not exported, so we use 'Pg.startCached' + 'finally'. --} +-- | Start a cached ephemeral server whose PostgreSQL superuser is the fixed +-- name @keiro@. Mirrors 'Pg.withCached' but pins the user; 'Pg.withCachedConfig' +-- is not exported, so we use 'Pg.startCached' + 'finally'. withKeiroPg :: (Pg.Database -> IO a) -> IO (Either Pg.StartError a) withKeiroPg action = do - started <- Pg.startCached keiroPgConfig Pg.defaultCacheConfig - case started of - Left err -> pure (Left err) - Right db -> Right <$> (action db `finally` Pg.stop db) + started <- Pg.startCached keiroPgConfig Pg.defaultCacheConfig + case started of + Left err -> pure (Left err) + Right db -> Right <$> (action db `finally` Pg.stop db) main :: IO () main = - hspec $ do - migrationFileNameSpec - migrationIntegritySpec - scaffolderSpec - migrationUpgradeSpec - describe "Keiro codd migrations" $ do - it "applies Kiroku and Keiro migrations to a fresh database and is repeatable" $ do - result <- withKeiroPg $ \db -> do - let connStr = Pg.connectionString db - coddSettings = testCoddSettings connStr "keiro-migrations/expected-schema" + hspec $ do + migrationFileNameSpec + migrationIntegritySpec + scaffolderSpec + migrationUpgradeSpec + describe "Keiro codd migrations" $ do + it "applies Kiroku and Keiro migrations to a fresh database and is repeatable" $ do + result <- withKeiroPg $ \db -> do + let connStr = Pg.connectionString db + coddSettings = testCoddSettings connStr "keiro-migrations/expected-schema" - runAllKeiroMigrationsNoCheck coddSettings (secondsToDiffTime 5) - assertTablesExist connStr "kiroku" kirokuTables - assertTablesExist connStr "keiro" keiroTables - assertTablesAbsent connStr "kiroku" keiroTables - assertTablesAbsent connStr "public" keiroTables - assertTablesAbsent connStr "public" kirokuTables + runAllKeiroMigrationsNoCheck coddSettings (secondsToDiffTime 5) + assertTablesExist connStr "kiroku" kirokuTables + assertTablesExist connStr "keiro" keiroTables + assertTablesAbsent connStr "kiroku" keiroTables + assertTablesAbsent connStr "public" keiroTables + assertTablesAbsent connStr "public" kirokuTables - runAllKeiroMigrationsNoCheck coddSettings (secondsToDiffTime 5) - assertTablesExist connStr "kiroku" kirokuTables - assertTablesExist connStr "keiro" keiroTables - assertTablesAbsent connStr "kiroku" keiroTables - assertTablesAbsent connStr "public" keiroTables - assertColumnExists connStr "keiro" "keiro_timers" "last_error" + runAllKeiroMigrationsNoCheck coddSettings (secondsToDiffTime 5) + assertTablesExist connStr "kiroku" kirokuTables + assertTablesExist connStr "keiro" keiroTables + assertTablesAbsent connStr "kiroku" keiroTables + assertTablesAbsent connStr "public" keiroTables + assertColumnExists connStr "keiro" "keiro_timers" "last_error" - case result of - Left err -> expectationFailure ("Failed to start ephemeral PostgreSQL: " <> show err) - Right () -> pure () + case result of + Left err -> expectationFailure ("Failed to start ephemeral PostgreSQL: " <> show err) + Right () -> pure () - it "matches the checked-in expected schema" $ do - expectedSchemaDir <- findExpectedSchemaDir - result <- withKeiroPg $ \db -> do - let coddSettings = testCoddSettings (Pg.connectionString db) expectedSchemaDir - runAllKeiroMigrations coddSettings (secondsToDiffTime 5) StrictCheck + it "matches the checked-in expected schema" $ do + expectedSchemaDir <- findExpectedSchemaDir + result <- withKeiroPg $ \db -> do + let coddSettings = testCoddSettings (Pg.connectionString db) expectedSchemaDir + runAllKeiroMigrations coddSettings (secondsToDiffTime 5) StrictCheck - case result of - Left err -> expectationFailure ("Failed to start ephemeral PostgreSQL: " <> show err) - Right (SchemasMatch _) -> pure () - Right SchemasNotVerified -> expectationFailure "StrictCheck did not verify schemas" - Right (SchemasDiffer _) -> expectationFailure "StrictCheck returned a schema mismatch without throwing" + case result of + Left err -> expectationFailure ("Failed to start ephemeral PostgreSQL: " <> show err) + Right (SchemasMatch _) -> pure () + Right SchemasNotVerified -> expectationFailure "StrictCheck did not verify schemas" + Right (SchemasDiffer _) -> expectationFailure "StrictCheck returned a schema mismatch without throwing" - it "reports schema drift under LaxCheck" $ do - expectedSchemaDir <- findExpectedSchemaDir - result <- withKeiroPg $ \db -> do - let connStr = Pg.connectionString db - coddSettings = testCoddSettings connStr expectedSchemaDir - runAllKeiroMigrationsNoCheck coddSettings (secondsToDiffTime 5) - runDb - connStr - "drift drill" - (Session.script "ALTER TABLE keiro.keiro_timers ALTER COLUMN last_error SET NOT NULL;") - runAllKeiroMigrations coddSettings (secondsToDiffTime 5) LaxCheck + it "reports schema drift under LaxCheck" $ do + expectedSchemaDir <- findExpectedSchemaDir + result <- withKeiroPg $ \db -> do + let connStr = Pg.connectionString db + coddSettings = testCoddSettings connStr expectedSchemaDir + runAllKeiroMigrationsNoCheck coddSettings (secondsToDiffTime 5) + runDb + connStr + "drift drill" + (Session.script "ALTER TABLE keiro.keiro_timers ALTER COLUMN last_error SET NOT NULL;") + runAllKeiroMigrations coddSettings (secondsToDiffTime 5) LaxCheck - case result of - Left err -> expectationFailure ("Failed to start ephemeral PostgreSQL: " <> show err) - Right (SchemasDiffer _) -> pure () - Right SchemasNotVerified -> expectationFailure "LaxCheck did not verify schemas" - Right (SchemasMatch _) -> expectationFailure "LaxCheck did not report schema drift" + case result of + Left err -> expectationFailure ("Failed to start ephemeral PostgreSQL: " <> show err) + Right (SchemasDiffer _) -> pure () + Right SchemasNotVerified -> expectationFailure "LaxCheck did not verify schemas" + Right (SchemasMatch _) -> expectationFailure "LaxCheck did not report schema drift" -{- | Guard against the recurring mistake of hand-assigning rounded, sentinel -migration timestamps (e.g. @2026-05-17-00-00-00-...@, @...-01-00-00-...@). -Migrations must be created with @keiro-migrate new@ ("Keiro.Migrations.New"), -which stamps the real current UTC time to the second, so filenames sort in true -authoring order and never collide in codd's timestamp-keyed ledger. --} +-- | Guard against the recurring mistake of hand-assigning rounded, sentinel +-- migration timestamps (e.g. @2026-05-17-00-00-00-...@, @...-01-00-00-...@). +-- Migrations must be created with @keiro-migrate new@ ("Keiro.Migrations.New"), +-- which stamps the real current UTC time to the second, so filenames sort in true +-- authoring order and never collide in codd's timestamp-keyed ledger. migrationFileNameSpec :: Spec migrationFileNameSpec = - describe "migration file names" $ do - it "carry real UTC authoring timestamps, not hand-assigned sentinels" $ do - files <- migrationFiles - files `shouldNotBe` [] - sentinelViolations files `shouldHaveNoViolations` "sentinel timestamp violations" + describe "migration file names" $ do + it "carry real UTC authoring timestamps, not hand-assigned sentinels" $ do + files <- migrationFiles + files `shouldNotBe` [] + sentinelViolations files `shouldHaveNoViolations` "sentinel timestamp violations" - it "have unique, strictly increasing timestamps" $ do - files <- migrationFiles - duplicateTimestampViolations files `shouldHaveNoViolations` "duplicate timestamp violations" + it "have unique, strictly increasing timestamps" $ do + files <- migrationFiles + duplicateTimestampViolations files `shouldHaveNoViolations` "duplicate timestamp violations" migrationIntegritySpec :: Spec migrationIntegritySpec = - describe "migration integrity guards" $ do - it "embeds exactly the checked-in sql-migrations directory" $ do - diskNames <- sort <$> migrationFiles - embeddedMigrationNames `shouldBe` diskNames + describe "migration integrity guards" $ do + it "embeds exactly the checked-in sql-migrations directory" $ do + diskNames <- sort <$> migrationFiles + embeddedMigrationNames `shouldBe` diskNames - it "matches the checked-in SHA-256 manifest" $ do - manifestPath <- findLockfile - parsed <- parseChecksumManifest <$> TIO.readFile manifestPath - case parsed of - Left err -> expectationFailure (T.unpack err) - Right manifest -> - checksumViolations manifest embeddedMigrationSources - `shouldHaveNoViolations` "checksum manifest violations" + it "matches the checked-in SHA-256 manifest" $ do + manifestPath <- findLockfile + parsed <- parseChecksumManifest <$> TIO.readFile manifestPath + case parsed of + Left err -> expectationFailure (T.unpack err) + Right manifest -> + checksumViolations manifest embeddedMigrationSources + `shouldHaveNoViolations` "checksum manifest violations" - it "keeps future migration bodies schema-qualified and codd-safe" $ do - lintViolations - LintConfig - { requiredQualifier = "keiro." - , exemptFiles = [] - } - embeddedMigrationSources - `shouldHaveNoViolations` "migration body lint violations" + it "keeps future migration bodies schema-qualified and codd-safe" $ do + lintViolations + LintConfig + { requiredQualifier = "keiro.", + exemptFiles = [] + } + embeddedMigrationSources + `shouldHaveNoViolations` "migration body lint violations" - it "keeps timestamps unique across the combined Kiroku and Keiro ledger" $ do - duplicateTimestampViolations expectedLedgerNames - `shouldHaveNoViolations` "combined-ledger duplicate timestamp violations" + it "keeps timestamps unique across the combined Kiroku and Keiro ledger" $ do + duplicateTimestampViolations expectedLedgerNames + `shouldHaveNoViolations` "combined-ledger duplicate timestamp violations" - it "records every embedded Kiroku and Keiro migration in the codd v5 ledger" $ do - result <- withKeiroPg $ \db -> do - let connStr = Pg.connectionString db - coddSettings = testCoddSettings connStr "keiro-migrations/expected-schema" - runAllKeiroMigrationsNoCheck coddSettings (secondsToDiffTime 5) - schema <- detectLedgerSchema connStr - schema `shouldBe` "codd" - names <- ledgerNames connStr schema - names `shouldBe` map T.pack expectedLedgerNames - case result of - Left err -> expectationFailure ("Failed to start ephemeral PostgreSQL: " <> show err) - Right () -> pure () + it "records every embedded Kiroku and Keiro migration in the codd v5 ledger" $ do + result <- withKeiroPg $ \db -> do + let connStr = Pg.connectionString db + coddSettings = testCoddSettings connStr "keiro-migrations/expected-schema" + runAllKeiroMigrationsNoCheck coddSettings (secondsToDiffTime 5) + schema <- detectLedgerSchema connStr + schema `shouldBe` "codd" + names <- ledgerNames connStr schema + names `shouldBe` map T.pack expectedLedgerNames + case result of + Left err -> expectationFailure ("Failed to start ephemeral PostgreSQL: " <> show err) + Right () -> pure () - it "serializes concurrent combined applies with the shared advisory lock" $ do - result <- withKeiroPg $ \db -> do - let connStr = Pg.connectionString db - coddSettings = testCoddSettings connStr "keiro-migrations/expected-schema" - concurrently - (runAllKeiroMigrationsNoCheck coddSettings (secondsToDiffTime 5)) - (runAllKeiroMigrationsNoCheck coddSettings (secondsToDiffTime 5)) - schema <- detectLedgerSchema connStr - names <- ledgerNames connStr schema - names `shouldBe` map T.pack expectedLedgerNames - count <- ledgerRowCount connStr schema - count `shouldBe` fromIntegral (length expectedLedgerNames) - case result of - Left err -> expectationFailure ("Failed to start ephemeral PostgreSQL: " <> show err) - Right () -> pure () + it "serializes concurrent combined applies with the shared advisory lock" $ do + result <- withKeiroPg $ \db -> do + let connStr = Pg.connectionString db + coddSettings = testCoddSettings connStr "keiro-migrations/expected-schema" + concurrently + (runAllKeiroMigrationsNoCheck coddSettings (secondsToDiffTime 5)) + (runAllKeiroMigrationsNoCheck coddSettings (secondsToDiffTime 5)) + schema <- detectLedgerSchema connStr + names <- ledgerNames connStr schema + names `shouldBe` map T.pack expectedLedgerNames + count <- ledgerRowCount connStr schema + count `shouldBe` fromIntegral (length expectedLedgerNames) + case result of + Left err -> expectationFailure ("Failed to start ephemeral PostgreSQL: " <> show err) + Right () -> pure () - it "reports every embedded migration as pending on an empty database" $ do - result <- withKeiroPg $ \db -> do - let coddSettings = testCoddSettings (Pg.connectionString db) "keiro-migrations/expected-schema" - verifySchema coddSettings (secondsToDiffTime 5) `shouldReturn` VerifyPending expectedLedgerNames - status <- migrationStatus coddSettings (secondsToDiffTime 5) - statusApplied status `shouldBe` [] - statusPending status `shouldBe` expectedLedgerNames - missingMigrations coddSettings (secondsToDiffTime 5) `shouldReturn` expectedLedgerNames - case result of - Left err -> expectationFailure ("Failed to start ephemeral PostgreSQL: " <> show err) - Right () -> pure () + it "reports every embedded migration as pending on an empty database" $ do + result <- withKeiroPg $ \db -> do + let coddSettings = testCoddSettings (Pg.connectionString db) "keiro-migrations/expected-schema" + verifySchema coddSettings (secondsToDiffTime 5) `shouldReturn` VerifyPending expectedLedgerNames + status <- migrationStatus coddSettings (secondsToDiffTime 5) + statusApplied status `shouldBe` [] + statusPending status `shouldBe` expectedLedgerNames + missingMigrations coddSettings (secondsToDiffTime 5) `shouldReturn` expectedLedgerNames + case result of + Left err -> expectationFailure ("Failed to start ephemeral PostgreSQL: " <> show err) + Right () -> pure () - it "reports only Keiro migrations as pending after Kiroku-only apply" $ do - result <- withKeiroPg $ \db -> do - let coddSettings = testCoddSettings (Pg.connectionString db) "keiro-migrations/expected-schema" - runKirokuMigrationsNoCheck coddSettings (secondsToDiffTime 5) - verifySchema coddSettings (secondsToDiffTime 5) `shouldReturn` VerifyPending embeddedMigrationNames - status <- migrationStatus coddSettings (secondsToDiffTime 5) - map fst (statusApplied status) `shouldBe` kirokuEmbeddedMigrationNames - statusPending status `shouldBe` embeddedMigrationNames - missingMigrations coddSettings (secondsToDiffTime 5) `shouldReturn` embeddedMigrationNames - case result of - Left err -> expectationFailure ("Failed to start ephemeral PostgreSQL: " <> show err) - Right () -> pure () + it "reports only Keiro migrations as pending after Kiroku-only apply" $ do + result <- withKeiroPg $ \db -> do + let coddSettings = testCoddSettings (Pg.connectionString db) "keiro-migrations/expected-schema" + runKirokuMigrationsNoCheck coddSettings (secondsToDiffTime 5) + verifySchema coddSettings (secondsToDiffTime 5) `shouldReturn` VerifyPending embeddedMigrationNames + status <- migrationStatus coddSettings (secondsToDiffTime 5) + map fst (statusApplied status) `shouldBe` kirokuEmbeddedMigrationNames + statusPending status `shouldBe` embeddedMigrationNames + missingMigrations coddSettings (secondsToDiffTime 5) `shouldReturn` embeddedMigrationNames + case result of + Left err -> expectationFailure ("Failed to start ephemeral PostgreSQL: " <> show err) + Right () -> pure () - it "verifies the embedded Keiro expected schema after combined apply" $ do - result <- withKeiroPg $ \db -> do - let coddSettings = testCoddSettings (Pg.connectionString db) "keiro-migrations/expected-schema" - runAllKeiroMigrationsNoCheck coddSettings (secondsToDiffTime 5) - verifySchema coddSettings (secondsToDiffTime 5) `shouldReturn` VerifySucceeded - status <- migrationStatus coddSettings (secondsToDiffTime 5) - map fst (statusApplied status) `shouldBe` expectedLedgerNames - statusPending status `shouldBe` [] - missingMigrations coddSettings (secondsToDiffTime 5) `shouldReturn` [] - case result of - Left err -> expectationFailure ("Failed to start ephemeral PostgreSQL: " <> show err) - Right () -> pure () + it "verifies the embedded Keiro expected schema after combined apply" $ do + result <- withKeiroPg $ \db -> do + let coddSettings = testCoddSettings (Pg.connectionString db) "keiro-migrations/expected-schema" + runAllKeiroMigrationsNoCheck coddSettings (secondsToDiffTime 5) + verifySchema coddSettings (secondsToDiffTime 5) `shouldReturn` VerifySucceeded + status <- migrationStatus coddSettings (secondsToDiffTime 5) + map fst (statusApplied status) `shouldBe` expectedLedgerNames + statusPending status `shouldBe` [] + missingMigrations coddSettings (secondsToDiffTime 5) `shouldReturn` [] + case result of + Left err -> expectationFailure ("Failed to start ephemeral PostgreSQL: " <> show err) + Right () -> pure () - it "reports Keiro schema drift without applying migrations" $ do - result <- withKeiroPg $ \db -> do - let connStr = Pg.connectionString db - coddSettings = testCoddSettings connStr "keiro-migrations/expected-schema" - runAllKeiroMigrationsNoCheck coddSettings (secondsToDiffTime 5) - beforeCount <- ledgerRowCount connStr "codd" - runDb connStr "verify drift mutation" (Session.script "CREATE TABLE keiro.verify_drift (id int);") - verifySchema coddSettings (secondsToDiffTime 5) `shouldReturn` VerifyFailed - afterCount <- ledgerRowCount connStr "codd" - afterCount `shouldBe` beforeCount - case result of - Left err -> expectationFailure ("Failed to start ephemeral PostgreSQL: " <> show err) - Right () -> pure () + it "reports Keiro schema drift without applying migrations" $ do + result <- withKeiroPg $ \db -> do + let connStr = Pg.connectionString db + coddSettings = testCoddSettings connStr "keiro-migrations/expected-schema" + runAllKeiroMigrationsNoCheck coddSettings (secondsToDiffTime 5) + beforeCount <- ledgerRowCount connStr "codd" + runDb connStr "verify drift mutation" (Session.script "CREATE TABLE keiro.verify_drift (id int);") + verifySchema coddSettings (secondsToDiffTime 5) `shouldReturn` VerifyFailed + afterCount <- ledgerRowCount connStr "codd" + afterCount `shouldBe` beforeCount + case result of + Left err -> expectationFailure ("Failed to start ephemeral PostgreSQL: " <> show err) + Right () -> pure () - it "realigns historical sentinel ledger rows before a repeat migrate" $ do - fixupPath <- findLedgerFixup - fixupScript <- TIO.readFile fixupPath - result <- withKeiroPg $ \db -> do - let connStr = Pg.connectionString db - coddSettings = testCoddSettings connStr "keiro-migrations/expected-schema" - runAllKeiroMigrationsNoCheck coddSettings (secondsToDiffTime 5) - schema <- detectLedgerSchema connStr - rewindKeiroLedgerToSentinelNames connStr schema - sentinelNames <- ledgerNames connStr schema - sentinelNames `shouldSatisfy` any (`elem` map oldLedgerName keiroLedgerRemaps) - runDb connStr "keiro ledger fixup script" (Session.script fixupScript) - fixedNames <- ledgerNames connStr schema - fixedNames `shouldBe` map T.pack expectedLedgerNames - beforeCount <- ledgerRowCount connStr schema - runAllKeiroMigrationsNoCheck coddSettings (secondsToDiffTime 5) - afterCount <- ledgerRowCount connStr schema - afterCount `shouldBe` beforeCount - case result of - Left err -> expectationFailure ("Failed to start ephemeral PostgreSQL: " <> show err) - Right () -> pure () + it "realigns historical sentinel ledger rows before a repeat migrate" $ do + fixupPath <- findLedgerFixup + fixupScript <- TIO.readFile fixupPath + result <- withKeiroPg $ \db -> do + let connStr = Pg.connectionString db + coddSettings = testCoddSettings connStr "keiro-migrations/expected-schema" + runAllKeiroMigrationsNoCheck coddSettings (secondsToDiffTime 5) + schema <- detectLedgerSchema connStr + rewindKeiroLedgerToSentinelNames connStr schema + sentinelNames <- ledgerNames connStr schema + sentinelNames `shouldSatisfy` any (`elem` map oldLedgerName keiroLedgerRemaps) + runDb connStr "keiro ledger fixup script" (Session.script fixupScript) + fixedNames <- ledgerNames connStr schema + fixedNames `shouldBe` map T.pack expectedLedgerNames + beforeCount <- ledgerRowCount connStr schema + runAllKeiroMigrationsNoCheck coddSettings (secondsToDiffTime 5) + afterCount <- ledgerRowCount connStr schema + afterCount `shouldBe` beforeCount + case result of + Left err -> expectationFailure ("Failed to start ephemeral PostgreSQL: " <> show err) + Right () -> pure () -{- | Prove the scaffolder (`Keiro.Migrations.New`) is the producer that satisfies -the reactive filename guard. The deterministic check proves the slug convention; -the temp-dir check proves the live writer creates a schema-qualified template. --} +-- | Prove the scaffolder (`Keiro.Migrations.New`) is the producer that satisfies +-- the reactive filename guard. The deterministic check proves the slug convention; +-- the temp-dir check proves the live writer creates a schema-qualified template. scaffolderSpec :: Spec scaffolderSpec = - describe "migration scaffolder" $ do - it "stamps a real, non-sentinel UTC timestamp and a keiro-prefixed slug" $ do - let sampled = UTCTime (fromGregorian 2026 7 5) (secondsToDiffTime (19 * 3600 + 9 * 60 + 18)) - name = migrationFileName sampled "Add widget index" - takeFileName name `shouldBe` name - isTimestampShaped (take timestampWidth name) `shouldBe` True - handAssignedTimestamp name `shouldBe` False - migrationSlug "Add widget index" `shouldBe` "keiro-add-widget-index" + describe "migration scaffolder" $ do + it "stamps a real, non-sentinel UTC timestamp and a keiro-prefixed slug" $ do + let sampled = UTCTime (fromGregorian 2026 7 5) (secondsToDiffTime (19 * 3600 + 9 * 60 + 18)) + name = migrationFileName sampled "Add widget index" + takeFileName name `shouldBe` name + isTimestampShaped (take timestampWidth name) `shouldBe` True + handAssignedTimestamp name `shouldBe` False + migrationSlug "Add widget index" `shouldBe` "keiro-add-widget-index" - it "writes a well-named file into a temp dir with a qualified template" $ - withSystemTempDirectory "keiro-scaffolder" $ \dir -> do - path <- newMigrationFile dir "add widget index" - let base = takeFileName path - isTimestampShaped (take timestampWidth base) `shouldBe` True - length base `shouldSatisfy` (> timestampWidth) - body <- TIO.readFile path - (".sql" `isSuffixOf` path) `shouldBe` True - ("keiro.keiro_example" `T.isInfixOf` body) `shouldBe` True - ("search_path" `T.isInfixOf` body) `shouldBe` False + it "writes a well-named file into a temp dir with a qualified template" $ + withSystemTempDirectory "keiro-scaffolder" $ \dir -> do + path <- newMigrationFile dir "add widget index" + let base = takeFileName path + isTimestampShaped (take timestampWidth base) `shouldBe` True + length base `shouldSatisfy` (> timestampWidth) + body <- TIO.readFile path + (".sql" `isSuffixOf` path) `shouldBe` True + ("keiro.keiro_example" `T.isInfixOf` body) `shouldBe` True + ("search_path" `T.isInfixOf` body) `shouldBe` False migrationUpgradeSpec :: Spec migrationUpgradeSpec = - describe "keiro migration upgrade artifacts" $ do - it "remediates a 0.1.0.0-style kiroku-schema layout without losing rows" $ do - remediationPath <- findRemediationScript - remediationScript <- TIO.readFile remediationPath - expectedSchemaDir <- findExpectedSchemaDir - result <- withKeiroPg $ \db -> do - let connStr = Pg.connectionString db - coddSettings = testCoddSettings connStr expectedSchemaDir - runAllKeiroMigrationsNoCheck coddSettings (secondsToDiffTime 5) - schema <- detectLedgerSchema connStr - moveKeiroTablesBackToKiroku connStr - seedRemediationRows connStr - runDb connStr "keiro schema remediation script" (Session.script remediationScript) + describe "keiro migration upgrade artifacts" $ do + it "remediates a 0.1.0.0-style kiroku-schema layout without losing rows" $ do + remediationPath <- findRemediationScript + remediationScript <- TIO.readFile remediationPath + expectedSchemaDir <- findExpectedSchemaDir + result <- withKeiroPg $ \db -> do + let connStr = Pg.connectionString db + coddSettings = testCoddSettings connStr expectedSchemaDir + runAllKeiroMigrationsNoCheck coddSettings (secondsToDiffTime 5) + schema <- detectLedgerSchema connStr + moveKeiroTablesBackToKiroku connStr + seedRemediationRows connStr + runDb connStr "keiro schema remediation script" (Session.script remediationScript) - assertTablesExist connStr "keiro" keiroTables - assertTablesAbsent connStr "kiroku" keiroTables - assertSnapshotRowSurvived connStr - assertTimerRowSurvived connStr + assertTablesExist connStr "keiro" keiroTables + assertTablesAbsent connStr "kiroku" keiroTables + assertSnapshotRowSurvived connStr + assertTimerRowSurvived connStr - beforeCount <- ledgerRowCount connStr schema - runAllKeiroMigrationsNoCheck coddSettings (secondsToDiffTime 5) - afterCount <- ledgerRowCount connStr schema - afterCount `shouldBe` beforeCount + beforeCount <- ledgerRowCount connStr schema + runAllKeiroMigrationsNoCheck coddSettings (secondsToDiffTime 5) + afterCount <- ledgerRowCount connStr schema + afterCount `shouldBe` beforeCount - strictResult <- runAllKeiroMigrations coddSettings (secondsToDiffTime 5) StrictCheck - case strictResult of - SchemasMatch _ -> pure () - SchemasNotVerified -> expectationFailure "StrictCheck did not verify remediated schemas" - SchemasDiffer _ -> expectationFailure "StrictCheck returned a schema mismatch after remediation" + strictResult <- runAllKeiroMigrations coddSettings (secondsToDiffTime 5) StrictCheck + case strictResult of + SchemasMatch _ -> pure () + SchemasNotVerified -> expectationFailure "StrictCheck did not verify remediated schemas" + SchemasDiffer _ -> expectationFailure "StrictCheck returned a schema mismatch after remediation" - runDb connStr "idempotent keiro schema remediation script" (Session.script remediationScript) - assertTablesExist connStr "keiro" keiroTables - assertTablesAbsent connStr "kiroku" keiroTables - assertSnapshotRowSurvived connStr - assertTimerRowSurvived connStr - case result of - Left err -> expectationFailure ("Failed to start ephemeral PostgreSQL: " <> show err) - Right () -> pure () + runDb connStr "idempotent keiro schema remediation script" (Session.script remediationScript) + assertTablesExist connStr "keiro" keiroTables + assertTablesAbsent connStr "kiroku" keiroTables + assertSnapshotRowSurvived connStr + assertTimerRowSurvived connStr + case result of + Left err -> expectationFailure ("Failed to start ephemeral PostgreSQL: " <> show err) + Right () -> pure () -- | The migration @.sql@ files, wherever the suite is run from. migrationFiles :: IO [FilePath] migrationFiles = do - dir <- findMigrationsDir - filter (".sql" `isSuffixOf`) <$> listDirectory dir + dir <- findMigrationsDir + filter (".sql" `isSuffixOf`) <$> listDirectory dir findMigrationsDir :: IO FilePath findMigrationsDir = do - let candidates = ["keiro-migrations/sql-migrations", "sql-migrations"] - existing <- filterM doesDirectoryExist candidates - case existing of - dir : _ -> pure dir - [] -> - expectationFailure "Could not find keiro-migrations/sql-migrations" - >> pure "keiro-migrations/sql-migrations" + let candidates = ["keiro-migrations/sql-migrations", "sql-migrations"] + existing <- filterM doesDirectoryExist candidates + case existing of + dir : _ -> pure dir + [] -> + expectationFailure "Could not find keiro-migrations/sql-migrations" + >> pure "keiro-migrations/sql-migrations" findExpectedSchemaDir :: IO FilePath findExpectedSchemaDir = do - let candidates = - [ "keiro-migrations/expected-schema" - , "expected-schema" - ] - existing <- filterM doesDirectoryExist candidates - case existing of - dir : _ -> pure dir - [] -> - expectationFailure "Could not find keiro-migrations/expected-schema" - >> pure "keiro-migrations/expected-schema" + let candidates = + [ "keiro-migrations/expected-schema", + "expected-schema" + ] + existing <- filterM doesDirectoryExist candidates + case existing of + dir : _ -> pure dir + [] -> + expectationFailure "Could not find keiro-migrations/expected-schema" + >> pure "keiro-migrations/expected-schema" findLockfile :: IO FilePath findLockfile = findExistingFile ["keiro-migrations/migrations.lock", "migrations.lock"] findLedgerFixup :: IO FilePath findLedgerFixup = - findExistingFile - [ "keiro-migrations/ledger-fixups/2026-07-05-realign-keiro-migration-timestamps.sql" - , "ledger-fixups/2026-07-05-realign-keiro-migration-timestamps.sql" - ] + findExistingFile + [ "keiro-migrations/ledger-fixups/2026-07-05-realign-keiro-migration-timestamps.sql", + "ledger-fixups/2026-07-05-realign-keiro-migration-timestamps.sql" + ] findRemediationScript :: IO FilePath findRemediationScript = - findExistingFile - [ "keiro-migrations/remediation/2026-07-05-relocate-keiro-tables-to-keiro-schema.sql" - , "remediation/2026-07-05-relocate-keiro-tables-to-keiro-schema.sql" - ] + findExistingFile + [ "keiro-migrations/remediation/2026-07-05-relocate-keiro-tables-to-keiro-schema.sql", + "remediation/2026-07-05-relocate-keiro-tables-to-keiro-schema.sql" + ] findExistingFile :: [FilePath] -> IO FilePath findExistingFile candidates = do - existing <- filterM doesFileExist candidates - case existing of - path : _ -> pure path - [] -> expectationFailure ("Could not find any of: " <> show candidates) >> pure fallback + existing <- filterM doesFileExist candidates + case existing of + path : _ -> pure path + [] -> expectationFailure ("Could not find any of: " <> show candidates) >> pure fallback where fallback = - case candidates of - path : _ -> path - [] -> "." + case candidates of + path : _ -> path + [] -> "." expectedLedgerNames :: [FilePath] expectedLedgerNames = sort (kirokuEmbeddedMigrationNames <> embeddedMigrationNames) @@ -406,82 +402,82 @@ -- | Kiroku's own event-store tables, which remain in the kiroku schema. kirokuTables :: [Text] kirokuTables = - [ "events" - , "stream_events" - , "streams" - , "subscriptions" - ] + [ "events", + "stream_events", + "streams", + "subscriptions" + ] -- | Keiro's framework tables, which live in the dedicated keiro schema. keiroTables :: [Text] keiroTables = - [ "keiro_awakeables" - , "keiro_inbox" - , "keiro_outbox" - , "keiro_projection_dedup" - , "keiro_read_models" - , "keiro_snapshots" - , "keiro_subscription_shards" - , "keiro_timers" - , "keiro_workflow_children" - , "keiro_workflow_steps" - , "keiro_workflows" - ] + [ "keiro_awakeables", + "keiro_inbox", + "keiro_outbox", + "keiro_projection_dedup", + "keiro_read_models", + "keiro_snapshots", + "keiro_subscription_shards", + "keiro_timers", + "keiro_workflow_children", + "keiro_workflow_steps", + "keiro_workflows" + ] testCoddSettings :: Text -> FilePath -> CoddSettings testCoddSettings connStr expectedSchemaDir = - CoddSettings - { migsConnString = parseConnString connStr - , sqlMigrations = [] - , onDiskReps = Left expectedSchemaDir - , namespacesToCheck = IncludeSchemas [SqlSchema "keiro"] - , extraRolesToCheck = [] - , retryPolicy = singleTryPolicy - , txnIsolationLvl = DbDefault - , schemaAlgoOpts = SchemaAlgo False False False - } + CoddSettings + { migsConnString = parseConnString connStr, + sqlMigrations = [], + onDiskReps = Left expectedSchemaDir, + namespacesToCheck = IncludeSchemas [SqlSchema "keiro"], + extraRolesToCheck = [], + retryPolicy = singleTryPolicy, + txnIsolationLvl = DbDefault, + schemaAlgoOpts = SchemaAlgo False False False + } parseConnString :: Text -> ConnectionString parseConnString connStr = - case parseOnly (connStringParser <* endOfInput) connStr of - Left err -> error ("Could not parse ephemeral PostgreSQL connection string for codd: " <> err) - Right parsed -> parsed + case parseOnly (connStringParser <* endOfInput) connStr of + Left err -> error ("Could not parse ephemeral PostgreSQL connection string for codd: " <> err) + Right parsed -> parsed shouldHaveNoViolations :: [Text] -> String -> Expectation shouldHaveNoViolations [] _ = pure () shouldHaveNoViolations violations label = - expectationFailure (label <> ":\n" <> T.unpack (T.unlines violations)) + expectationFailure (label <> ":\n" <> T.unpack (T.unlines violations)) runDb :: Text -> String -> Session.Session a -> IO a runDb connStr label session = do - pool <- Pool.acquire poolConfig - result <- Pool.use pool session - Pool.release pool - case result of - Left err -> expectationFailure (label <> " failed: " <> show err) >> fail label - Right value -> pure value + pool <- Pool.acquire poolConfig + result <- Pool.use pool session + Pool.release pool + case result of + Left err -> expectationFailure (label <> " failed: " <> show err) >> fail label + Right value -> pure value where poolConfig = - Pool.Config.settings - [ Pool.Config.staticConnectionSettings (Conn.connectionString connStr) - , Pool.Config.size 1 - ] + Pool.Config.settings + [ Pool.Config.staticConnectionSettings (Conn.connectionString connStr), + Pool.Config.size 1 + ] detectLedgerSchema :: Text -> IO Text detectLedgerSchema connStr = do - (hasCodd, hasCoddSchema) <- runDb connStr "ledger schema detection" (Session.statement () ledgerSchemaStmt) - case (hasCodd, hasCoddSchema) of - (True, False) -> pure "codd" - (False, True) -> pure "codd_schema" - (False, False) -> expectationFailure "codd ledger table was not found" >> pure "codd" - (True, True) -> expectationFailure "both codd and codd_schema ledger tables exist" >> pure "codd" + (hasCodd, hasCoddSchema) <- runDb connStr "ledger schema detection" (Session.statement () ledgerSchemaStmt) + case (hasCodd, hasCoddSchema) of + (True, False) -> pure "codd" + (False, True) -> pure "codd_schema" + (False, False) -> expectationFailure "codd ledger table was not found" >> pure "codd" + (True, True) -> expectationFailure "both codd and codd_schema ledger tables exist" >> pure "codd" ledgerSchemaStmt :: Statement () (Bool, Bool) ledgerSchemaStmt = - preparable - "SELECT to_regclass('codd.sql_migrations') IS NOT NULL, to_regclass('codd_schema.sql_migrations') IS NOT NULL" - E.noParams - (D.singleRow ((,) <$> D.column (D.nonNullable D.bool) <*> D.column (D.nonNullable D.bool))) + preparable + "SELECT to_regclass('codd.sql_migrations') IS NOT NULL, to_regclass('codd_schema.sql_migrations') IS NOT NULL" + E.noParams + (D.singleRow ((,) <$> D.column (D.nonNullable D.bool) <*> D.column (D.nonNullable D.bool))) ledgerNames :: Text -> Text -> IO [Text] ledgerNames connStr "codd" = runDb connStr "codd ledger names" (Session.statement () ledgerNamesCoddStmt) @@ -490,17 +486,17 @@ ledgerNamesCoddStmt :: Statement () [Text] ledgerNamesCoddStmt = - preparable - "SELECT name::text FROM codd.sql_migrations ORDER BY name" - E.noParams - (D.rowList (D.column (D.nonNullable D.text))) + preparable + "SELECT name::text FROM codd.sql_migrations ORDER BY name" + E.noParams + (D.rowList (D.column (D.nonNullable D.text))) ledgerNamesCoddSchemaStmt :: Statement () [Text] ledgerNamesCoddSchemaStmt = - preparable - "SELECT name::text FROM codd_schema.sql_migrations ORDER BY name" - E.noParams - (D.rowList (D.column (D.nonNullable D.text))) + preparable + "SELECT name::text FROM codd_schema.sql_migrations ORDER BY name" + E.noParams + (D.rowList (D.column (D.nonNullable D.text))) ledgerRowCount :: Text -> Text -> IO Int32 ledgerRowCount connStr "codd" = runDb connStr "codd ledger row count" (Session.statement () ledgerCountCoddStmt) @@ -509,181 +505,181 @@ ledgerCountCoddStmt :: Statement () Int32 ledgerCountCoddStmt = - preparable - "SELECT count(*)::int FROM codd.sql_migrations" - E.noParams - (D.singleRow (D.column (D.nonNullable D.int4))) + preparable + "SELECT count(*)::int FROM codd.sql_migrations" + E.noParams + (D.singleRow (D.column (D.nonNullable D.int4))) ledgerCountCoddSchemaStmt :: Statement () Int32 ledgerCountCoddSchemaStmt = - preparable - "SELECT count(*)::int FROM codd_schema.sql_migrations" - E.noParams - (D.singleRow (D.column (D.nonNullable D.int4))) + preparable + "SELECT count(*)::int FROM codd_schema.sql_migrations" + E.noParams + (D.singleRow (D.column (D.nonNullable D.int4))) data KeiroLedgerRemap = KeiroLedgerRemap - { newLedgerName :: Text - , oldLedgerName :: Text - , oldLedgerTimestamp :: Text - } - deriving stock (Eq, Show) + { newLedgerName :: Text, + oldLedgerName :: Text, + oldLedgerTimestamp :: Text + } + deriving stock (Eq, Show) keiroLedgerRemaps :: [KeiroLedgerRemap] keiroLedgerRemaps = - [ KeiroLedgerRemap "2026-05-17-13-58-15-keiro-bootstrap.sql" "2026-05-17-00-00-00-keiro-bootstrap.sql" "2026-05-17 00:00:00+00" - , KeiroLedgerRemap "2026-05-19-12-55-02-keiro-outbox.sql" "2026-05-17-01-00-00-keiro-outbox.sql" "2026-05-17 01:00:00+00" - , KeiroLedgerRemap "2026-05-19-13-05-23-keiro-inbox.sql" "2026-05-17-02-00-00-keiro-inbox.sql" "2026-05-17 02:00:00+00" - , KeiroLedgerRemap "2026-06-03-05-14-28-keiro-timer-recovery.sql" "2026-05-17-03-00-00-keiro-timer-recovery.sql" "2026-05-17 03:00:00+00" - , KeiroLedgerRemap "2026-06-03-16-10-05-keiro-workflow-steps.sql" "2026-06-03-00-00-00-keiro-workflow-steps.sql" "2026-06-03 00:00:00+00" - , KeiroLedgerRemap "2026-06-03-18-19-41-keiro-awakeables.sql" "2026-06-03-01-00-00-keiro-awakeables.sql" "2026-06-03 01:00:00+00" - , KeiroLedgerRemap "2026-06-03-19-49-23-keiro-workflow-children.sql" "2026-06-03-02-00-00-keiro-workflow-children.sql" "2026-06-03 02:00:00+00" - , KeiroLedgerRemap "2026-06-04-02-12-28-keiro-workflow-generation.sql" "2026-06-05-00-00-00-keiro-workflow-generation.sql" "2026-06-05 00:00:00+00" - , KeiroLedgerRemap "2026-06-04-03-53-34-keiro-subscription-shards.sql" "2026-06-05-01-00-00-keiro-subscription-shards.sql" "2026-06-05 01:00:00+00" - , KeiroLedgerRemap "2026-06-15-15-07-25-keiro-workflows-instances.sql" "2026-06-11-00-00-04-keiro-workflows-instances.sql" "2026-06-11 00:00:04+00" - , KeiroLedgerRemap "2026-06-15-17-53-48-keiro-workflow-gc-index.sql" "2026-06-15-22-10-00-keiro-workflow-gc-index.sql" "2026-06-15 22:10:00+00" - , KeiroLedgerRemap "2026-06-15-18-01-33-keiro-workflows-wake-after.sql" "2026-06-15-22-20-00-keiro-workflows-wake-after.sql" "2026-06-15 22:20:00+00" - , KeiroLedgerRemap "2026-07-02-00-15-48-keiro-outbox-claim-order-index.sql" "2026-07-02-00-12-00-keiro-outbox-claim-order-index.sql" "2026-07-02 00:12:00+00" - , KeiroLedgerRemap "2026-07-02-00-58-54-keiro-inbox-drop-received-idx.sql" "2026-07-02-00-55-00-keiro-inbox-drop-received-idx.sql" "2026-07-02 00:55:00+00" - ] + [ KeiroLedgerRemap "2026-05-17-13-58-15-keiro-bootstrap.sql" "2026-05-17-00-00-00-keiro-bootstrap.sql" "2026-05-17 00:00:00+00", + KeiroLedgerRemap "2026-05-19-12-55-02-keiro-outbox.sql" "2026-05-17-01-00-00-keiro-outbox.sql" "2026-05-17 01:00:00+00", + KeiroLedgerRemap "2026-05-19-13-05-23-keiro-inbox.sql" "2026-05-17-02-00-00-keiro-inbox.sql" "2026-05-17 02:00:00+00", + KeiroLedgerRemap "2026-06-03-05-14-28-keiro-timer-recovery.sql" "2026-05-17-03-00-00-keiro-timer-recovery.sql" "2026-05-17 03:00:00+00", + KeiroLedgerRemap "2026-06-03-16-10-05-keiro-workflow-steps.sql" "2026-06-03-00-00-00-keiro-workflow-steps.sql" "2026-06-03 00:00:00+00", + KeiroLedgerRemap "2026-06-03-18-19-41-keiro-awakeables.sql" "2026-06-03-01-00-00-keiro-awakeables.sql" "2026-06-03 01:00:00+00", + KeiroLedgerRemap "2026-06-03-19-49-23-keiro-workflow-children.sql" "2026-06-03-02-00-00-keiro-workflow-children.sql" "2026-06-03 02:00:00+00", + KeiroLedgerRemap "2026-06-04-02-12-28-keiro-workflow-generation.sql" "2026-06-05-00-00-00-keiro-workflow-generation.sql" "2026-06-05 00:00:00+00", + KeiroLedgerRemap "2026-06-04-03-53-34-keiro-subscription-shards.sql" "2026-06-05-01-00-00-keiro-subscription-shards.sql" "2026-06-05 01:00:00+00", + KeiroLedgerRemap "2026-06-15-15-07-25-keiro-workflows-instances.sql" "2026-06-11-00-00-04-keiro-workflows-instances.sql" "2026-06-11 00:00:04+00", + KeiroLedgerRemap "2026-06-15-17-53-48-keiro-workflow-gc-index.sql" "2026-06-15-22-10-00-keiro-workflow-gc-index.sql" "2026-06-15 22:10:00+00", + KeiroLedgerRemap "2026-06-15-18-01-33-keiro-workflows-wake-after.sql" "2026-06-15-22-20-00-keiro-workflows-wake-after.sql" "2026-06-15 22:20:00+00", + KeiroLedgerRemap "2026-07-02-00-15-48-keiro-outbox-claim-order-index.sql" "2026-07-02-00-12-00-keiro-outbox-claim-order-index.sql" "2026-07-02 00:12:00+00", + KeiroLedgerRemap "2026-07-02-00-58-54-keiro-inbox-drop-received-idx.sql" "2026-07-02-00-55-00-keiro-inbox-drop-received-idx.sql" "2026-07-02 00:55:00+00" + ] rewindKeiroLedgerToSentinelNames :: Text -> Text -> IO () rewindKeiroLedgerToSentinelNames connStr schema = - runDb connStr "keiro ledger rewind to sentinel names" (Session.script script) + runDb connStr "keiro ledger rewind to sentinel names" (Session.script script) where qname = schema <> ".sql_migrations" -- Kept in sync with ledger-fixups/2026-07-05-realign-keiro-migration-timestamps.sql. script = - T.unlines - [ "UPDATE " <> qname <> " SET name = '" <> oldName <> "', migration_timestamp = '" <> oldTimestamp <> "' WHERE name = '" <> newName <> "';" - | KeiroLedgerRemap newName oldName oldTimestamp <- keiroLedgerRemaps - ] + T.unlines + [ "UPDATE " <> qname <> " SET name = '" <> oldName <> "', migration_timestamp = '" <> oldTimestamp <> "' WHERE name = '" <> newName <> "';" + | KeiroLedgerRemap newName oldName oldTimestamp <- keiroLedgerRemaps + ] moveKeiroTablesBackToKiroku :: Text -> IO () moveKeiroTablesBackToKiroku connStr = - runDb connStr "move keiro tables back to kiroku schema" (Session.script script) + runDb connStr "move keiro tables back to kiroku schema" (Session.script script) where tableArray = T.intercalate ", " ["'" <> table <> "'" | table <- keiroTables] script = - T.unlines - [ "DO $$" - , "DECLARE" - , " t text;" - , " tables text[] := ARRAY[" <> tableArray <> "];" - , "BEGIN" - , " FOREACH t IN ARRAY tables LOOP" - , " IF to_regclass('keiro.' || t) IS NOT NULL THEN" - , " EXECUTE format('ALTER TABLE keiro.%I SET SCHEMA kiroku', t);" - , " END IF;" - , " END LOOP;" - , "END" - , "$$;" - , "DROP SCHEMA IF EXISTS keiro;" - ] + T.unlines + [ "DO $$", + "DECLARE", + " t text;", + " tables text[] := ARRAY[" <> tableArray <> "];", + "BEGIN", + " FOREACH t IN ARRAY tables LOOP", + " IF to_regclass('keiro.' || t) IS NOT NULL THEN", + " EXECUTE format('ALTER TABLE keiro.%I SET SCHEMA kiroku', t);", + " END IF;", + " END LOOP;", + "END", + "$$;", + "DROP SCHEMA IF EXISTS keiro;" + ] seedRemediationRows :: Text -> IO () seedRemediationRows connStr = - runDb connStr "seed 0.1.0.0-layout keiro rows" (Session.script script) + runDb connStr "seed 0.1.0.0-layout keiro rows" (Session.script script) where script = - """ - INSERT INTO kiroku.keiro_snapshots - (stream_id, stream_version, state, state_codec_version, regfile_shape_hash) - VALUES - (4242, 7, '{"ok": true}'::jsonb, 3, 'shape-abc'); + """ + INSERT INTO kiroku.keiro_snapshots + (stream_id, stream_version, state, state_codec_version, regfile_shape_hash) + VALUES + (4242, 7, '{"ok": true}'::jsonb, 3, 'shape-abc'); - INSERT INTO kiroku.keiro_timers - (timer_id, process_manager_name, correlation_id, fire_at, payload, status) - VALUES - ('00000000-0000-4000-8000-000000000001', 'remediation-test', 'corr-1', - '2026-07-06 00:00:00+00', '{"wake": true}'::jsonb, 'scheduled'); - """ + INSERT INTO kiroku.keiro_timers + (timer_id, process_manager_name, correlation_id, fire_at, payload, status) + VALUES + ('00000000-0000-4000-8000-000000000001', 'remediation-test', 'corr-1', + '2026-07-06 00:00:00+00', '{"wake": true}'::jsonb, 'scheduled'); + """ assertSnapshotRowSurvived :: Text -> IO () assertSnapshotRowSurvived connStr = do - present <- runDb connStr "snapshot survival query" (Session.statement () snapshotSurvivedStmt) - present `shouldBe` True + present <- runDb connStr "snapshot survival query" (Session.statement () snapshotSurvivedStmt) + present `shouldBe` True snapshotSurvivedStmt :: Statement () Bool snapshotSurvivedStmt = - preparable - """ - SELECT EXISTS ( - SELECT 1 - FROM keiro.keiro_snapshots - WHERE stream_id = 4242 - AND stream_version = 7 - AND state = '{"ok": true}'::jsonb - AND state_codec_version = 3 - AND regfile_shape_hash = 'shape-abc' - ) - """ - E.noParams - (D.singleRow (D.column (D.nonNullable D.bool))) + preparable + """ + SELECT EXISTS ( + SELECT 1 + FROM keiro.keiro_snapshots + WHERE stream_id = 4242 + AND stream_version = 7 + AND state = '{"ok": true}'::jsonb + AND state_codec_version = 3 + AND regfile_shape_hash = 'shape-abc' + ) + """ + E.noParams + (D.singleRow (D.column (D.nonNullable D.bool))) assertTimerRowSurvived :: Text -> IO () assertTimerRowSurvived connStr = do - present <- runDb connStr "timer survival query" (Session.statement () timerSurvivedStmt) - present `shouldBe` True + present <- runDb connStr "timer survival query" (Session.statement () timerSurvivedStmt) + present `shouldBe` True timerSurvivedStmt :: Statement () Bool timerSurvivedStmt = - preparable - """ - SELECT EXISTS ( - SELECT 1 - FROM keiro.keiro_timers - WHERE timer_id = '00000000-0000-4000-8000-000000000001' - AND process_manager_name = 'remediation-test' - AND correlation_id = 'corr-1' - AND payload = '{"wake": true}'::jsonb - AND status = 'scheduled' - ) - """ - E.noParams - (D.singleRow (D.column (D.nonNullable D.bool))) + preparable + """ + SELECT EXISTS ( + SELECT 1 + FROM keiro.keiro_timers + WHERE timer_id = '00000000-0000-4000-8000-000000000001' + AND process_manager_name = 'remediation-test' + AND correlation_id = 'corr-1' + AND payload = '{"wake": true}'::jsonb + AND status = 'scheduled' + ) + """ + E.noParams + (D.singleRow (D.column (D.nonNullable D.bool))) assertTablesExist :: Text -> Text -> [Text] -> IO () assertTablesExist connStr schema tables = do - actualTables <- runDb connStr "table verification query" (Session.statement schema schemaTablesStmt) - let missing = filter (`notElem` actualTables) tables - missing `shouldBe` [] + actualTables <- runDb connStr "table verification query" (Session.statement schema schemaTablesStmt) + let missing = filter (`notElem` actualTables) tables + missing `shouldBe` [] assertTablesAbsent :: Text -> Text -> [Text] -> IO () assertTablesAbsent connStr schema tables = do - actualTables <- runDb connStr "table verification query" (Session.statement schema schemaTablesStmt) - let present = filter (`elem` actualTables) tables - present `shouldBe` [] + actualTables <- runDb connStr "table verification query" (Session.statement schema schemaTablesStmt) + let present = filter (`elem` actualTables) tables + present `shouldBe` [] assertColumnExists :: Text -> Text -> Text -> Text -> IO () assertColumnExists connStr schema table column = do - present <- runDb connStr "column verification query" (Session.statement (schema, table, column) columnExistsStmt) - present `shouldBe` True + present <- runDb connStr "column verification query" (Session.statement (schema, table, column) columnExistsStmt) + present `shouldBe` True columnExistsStmt :: Statement (Text, Text, Text) Bool columnExistsStmt = - preparable - """ - SELECT EXISTS ( - SELECT 1 FROM information_schema.columns - WHERE table_schema = $1 AND table_name = $2 AND column_name = $3 - ) - """ - ( contrazip3 - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.text)) - ) - (D.singleRow (D.column (D.nonNullable D.bool))) + preparable + """ + SELECT EXISTS ( + SELECT 1 FROM information_schema.columns + WHERE table_schema = $1 AND table_name = $2 AND column_name = $3 + ) + """ + ( contrazip3 + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + (E.param (E.nonNullable E.text)) + ) + (D.singleRow (D.column (D.nonNullable D.bool))) schemaTablesStmt :: Statement Text [Text] schemaTablesStmt = - preparable - """ - SELECT table_name::text - FROM information_schema.tables - WHERE table_schema = $1 - AND table_type = 'BASE TABLE' - ORDER BY table_name - """ - (E.param (E.nonNullable E.text)) - (D.rowList (D.column (D.nonNullable D.text))) + preparable + """ + SELECT table_name::text + FROM information_schema.tables + WHERE table_schema = $1 + AND table_type = 'BASE TABLE' + ORDER BY table_name + """ + (E.param (E.nonNullable E.text)) + (D.rowList (D.column (D.nonNullable D.text))) diff --git a/test/Lint.hs b/test/Lint.hs --- a/test/Lint.hs +++ b/test/Lint.hs @@ -1,7 +1,8 @@ -module Lint ( - LintConfig (..), +module Lint + ( LintConfig (..), lintViolations, -) where + ) +where import Data.ByteString (ByteString) import Data.List (sortOn) @@ -10,30 +11,29 @@ import Data.Text.Encoding qualified as Text.Encoding import Data.Text.Encoding.Error (lenientDecode) -{- | Pure migration-body lint, ported from codd-extras (Codd.Extras.Guards) when the -codd toolchain moved behind the legacy-codd-tools flag. The codd-era CONCURRENTLY -check is deliberately dropped: pg-migrate runs transactional migrations inside a -single transaction, and PostgreSQL rejects CREATE INDEX CONCURRENTLY in a -transaction block, so the mistake fails the first fresh-database test run instead -of needing a lint. Genuinely non-transactional migrations must carry pg-migrate's -"-- pg-migrate: no-transaction" leading comment, which review gates. --} +-- | Pure migration-body lint, ported from codd-extras (Codd.Extras.Guards) when the +-- codd toolchain moved behind the legacy-codd-tools flag. The codd-era CONCURRENTLY +-- check is deliberately dropped: pg-migrate runs transactional migrations inside a +-- single transaction, and PostgreSQL rejects CREATE INDEX CONCURRENTLY in a +-- transaction block, so the mistake fails the first fresh-database test run instead +-- of needing a lint. Genuinely non-transactional migrations must carry pg-migrate's +-- "-- pg-migrate: no-transaction" leading comment, which review gates. data LintConfig = LintConfig - { requiredQualifier :: Text - , exemptFiles :: [FilePath] - } - deriving stock (Eq, Show) + { requiredQualifier :: Text, + exemptFiles :: [FilePath] + } + deriving stock (Eq, Show) -- | Lint migration bodies with intentionally simple SQL heuristics. lintViolations :: LintConfig -> [(FilePath, ByteString)] -> [Text] lintViolations config sources = - concatMap lintOne (sortOn fst sources) + concatMap lintOne (sortOn fst sources) where lintOne (file, bytes) - | file `elem` exemptFiles config = [] - | otherwise = - searchPathViolation file body - <> concatMap (statementViolations file) statements + | file `elem` exemptFiles config = [] + | otherwise = + searchPathViolation file body + <> concatMap (statementViolations file) statements where body = Text.Encoding.decodeUtf8With lenientDecode bytes statements = map Text.strip . Text.splitOn ";" $ stripCommentLines body @@ -41,44 +41,44 @@ requiredLower = Text.toCaseFold (requiredQualifier config) searchPathViolation file body = - [ "migration body mentions search_path: " <> Text.pack file - | "search_path" `Text.isInfixOf` Text.toCaseFold (stripCommentLines body) - ] + [ "migration body mentions search_path: " <> Text.pack file + | "search_path" `Text.isInfixOf` Text.toCaseFold (stripCommentLines body) + ] statementViolations file statement = - case statementTarget statement of - Nothing -> [] - Just target - | requiredLower `Text.isPrefixOf` Text.toCaseFold (cleanTarget target) -> [] - | otherwise -> - [ "migration DDL target is not qualified with " - <> requiredQualifier config - <> " in " - <> Text.pack file - <> ": " - <> Text.take 120 (oneLine statement) - ] + case statementTarget statement of + Nothing -> [] + Just target + | requiredLower `Text.isPrefixOf` Text.toCaseFold (cleanTarget target) -> [] + | otherwise -> + [ "migration DDL target is not qualified with " + <> requiredQualifier config + <> " in " + <> Text.pack file + <> ": " + <> Text.take 120 (oneLine statement) + ] statementTarget :: Text -> Maybe Text statementTarget statement - | Text.null trimmed = Nothing - | lower `startsWithWords` ["create", "table"] = - targetAfter ["create", "table"] wordsOriginal - | lower `startsWithWords` ["alter", "table"] = - targetAfter ["alter", "table"] wordsOriginal - | lower `startsWithWords` ["drop", "index"] = - targetAfter ["drop", "index"] wordsOriginal - | lower `startsWithWords` ["create", "index"] = - targetAfterToken "on" wordsOriginal - | lower `startsWithWords` ["create", "unique", "index"] = - targetAfterToken "on" wordsOriginal - | lower `startsWithWords` ["create", "function"] = - targetAfter ["create", "function"] wordsOriginal - | lower `startsWithWords` ["create", "or", "replace", "function"] = - targetAfter ["create", "or", "replace", "function"] wordsOriginal - | lower `startsWithWords` ["create", "trigger"] = - targetAfterToken "on" wordsOriginal - | otherwise = Nothing + | Text.null trimmed = Nothing + | lower `startsWithWords` ["create", "table"] = + targetAfter ["create", "table"] wordsOriginal + | lower `startsWithWords` ["alter", "table"] = + targetAfter ["alter", "table"] wordsOriginal + | lower `startsWithWords` ["drop", "index"] = + targetAfter ["drop", "index"] wordsOriginal + | lower `startsWithWords` ["create", "index"] = + targetAfterToken "on" wordsOriginal + | lower `startsWithWords` ["create", "unique", "index"] = + targetAfterToken "on" wordsOriginal + | lower `startsWithWords` ["create", "function"] = + targetAfter ["create", "function"] wordsOriginal + | lower `startsWithWords` ["create", "or", "replace", "function"] = + targetAfter ["create", "or", "replace", "function"] wordsOriginal + | lower `startsWithWords` ["create", "trigger"] = + targetAfterToken "on" wordsOriginal + | otherwise = Nothing where trimmed = Text.strip statement lower = Text.toCaseFold trimmed @@ -86,32 +86,32 @@ startsWithWords :: Text -> [Text] -> Bool startsWithWords statement wordsExpected = - wordsExpected == take (length wordsExpected) (Text.words statement) + wordsExpected == take (length wordsExpected) (Text.words statement) targetAfter :: [Text] -> [Text] -> Maybe Text targetAfter prefix wordsOriginal = - skipIfNotExists (drop (length prefix) wordsOriginal) + skipIfNotExists (drop (length prefix) wordsOriginal) targetAfterToken :: Text -> [Text] -> Maybe Text targetAfterToken token wordsOriginal = - skipIfNotExists . drop 1 $ dropWhile ((/= token) . Text.toCaseFold) wordsOriginal + skipIfNotExists . drop 1 $ dropWhile ((/= token) . Text.toCaseFold) wordsOriginal skipIfNotExists :: [Text] -> Maybe Text skipIfNotExists (first : second : third : target : _) - | map Text.toCaseFold [first, second, third] == ["if", "not", "exists"] = Just target + | map Text.toCaseFold [first, second, third] == ["if", "not", "exists"] = Just target skipIfNotExists (first : second : target : _) - | map Text.toCaseFold [first, second] == ["if", "exists"] = Just target + | map Text.toCaseFold [first, second] == ["if", "exists"] = Just target skipIfNotExists (target : _) = Just target skipIfNotExists [] = Nothing stripCommentLines :: Text -> Text stripCommentLines = - Text.unlines . filter (not . Text.isPrefixOf "--" . Text.strip) . Text.lines + Text.unlines . filter (not . Text.isPrefixOf "--" . Text.strip) . Text.lines cleanTarget :: Text -> Text cleanTarget = - Text.dropAround (`elem` ("\"(),;" :: String)) + Text.dropAround (`elem` ("\"(),;" :: String)) oneLine :: Text -> Text oneLine = - Text.unwords . Text.words + Text.unwords . Text.words diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -20,804 +20,804 @@ import Data.Text.IO qualified as Text.IO import Database.PostgreSQL.Migrate import Database.PostgreSQL.Migrate.History.Codd -import Database.PostgreSQL.Migrate.Internal ( - ComponentDescription (..), - PlanDescription (..), - componentNameText, - migrationChecksumBytes, - planDescription, - ) -import Database.PostgreSQL.Migrate.Internal qualified as Migrate.Internal -import Database.PostgreSQL.Migrate.Test (withMigratedDatabase) -import EphemeralPg qualified as Pg -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 -import Keiro.Migrations -import Keiro.Migrations qualified as Keiro -import Keiro.Migrations.History.Codd -import Keiro.Migrations.SchemaCheck -import Kiroku.Store.Migrations qualified as Kiroku -import Kiroku.Store.Migrations.History.Codd qualified as Kiroku.Codd -import Lint -import Numeric qualified -import System.Directory (doesDirectoryExist, doesFileExist, listDirectory) -import System.Environment (lookupEnv) -import System.FilePath (takeExtension, ()) -import Test.Hspec - -main :: IO () -main = hspec $ do - describe "native Keiro migration definition" $ do - it "tracks twenty native files in manifest order" $ do - directory <- findMigrationsDirectory - manifest <- Text.lines <$> Text.IO.readFile (directory "manifest") - manifest `shouldBe` Text.pack <$> nativeMigrationFiles - - it "preserves every legacy payload byte recorded by migrations.lock" $ do - directory <- findMigrationsDirectory - lockPath <- findLockfile - lockEntries <- parseLockfile <$> Text.IO.readFile lockPath - forM_ (zip (toList keiroLegacyMigrationNames) nativeMigrationFiles) $ \(legacyName, nativeName) -> do - bytes <- ByteString.readFile (directory nativeName) - lookup legacyName lockEntries `shouldBe` Just (checksumText bytes) - - it "builds component keiro with dependency kiroku and twenty migrations" $ do - plan <- requirePlan - let PlanDescription components = planDescription plan - case toList components of - [ ComponentDescription{name = kirokuName, dependencies = kirokuDependencies, migrations = kirokuEntries} - , ComponentDescription{name = keiroName, dependencies = keiroDependencies, migrations = keiroEntries} - ] -> do - componentNameText kirokuName `shouldBe` "kiroku" - kirokuDependencies `shouldBe` mempty - length kirokuEntries `shouldBe` 8 - componentNameText keiroName `shouldBe` "keiro" - dependencyName <- requireRight (componentName "kiroku") - keiroDependencies `shouldBe` Set.singleton dependencyName - length keiroEntries `shouldBe` 20 - actual -> expectationFailure ("unexpected plan description: " <> show actual) - validateHistoryMappingTargets plan frameworkCoddHistoryMappings `shouldBe` Right () - - it "rejects missing and reversed Kiroku dependencies" $ do - kiroku <- requireRight Kiroku.kirokuMigrations - keiro <- requireRight keiroMigrations - migrationPlan (keiro :| []) `shouldSatisfy` isLeft - frameworkMigrationPlan keiro kiroku `shouldSatisfy` isLeft - - describe "native checksum lockfile" $ do - it "matches the manifest, directory membership, and every payload byte" $ do - directory <- findMigrationsDirectory - lockPath <- findNativeLockfile - lockEntries <- parseLockfile <$> Text.IO.readFile lockPath - manifestNames <- - fmap Text.unpack . Text.lines - <$> Text.IO.readFile (directory "manifest") - directoryNames <- - sort - . filter ((== ".sql") . takeExtension) - <$> listDirectory directory - let lockNames = fst <$> lockEntries - assertFileList - "migrations.native.lock entries differ from migrations/manifest" - manifestNames - lockNames - assertFileList - "migrations directory entries differ from migrations/manifest" - (sort manifestNames) - directoryNames - forM_ lockEntries $ \(filename, expectedChecksum) -> do - actualChecksum <- - checksumText - <$> ByteString.readFile (directory filename) - unless (actualChecksum == expectedChecksum) $ - expectationFailure - ( "migrations.native.lock checksum mismatch for " - <> filename - <> "\nexpected: " - <> Text.unpack expectedChecksum - <> "\nactual: " - <> Text.unpack actualChecksum - ) - - describe "migration body lint" $ do - let config = LintConfig{requiredQualifier = "keiro.", exemptFiles = []} - - it "flags an unqualified DDL target" $ do - let violations = - lintViolations - config - [("9999-fixture.sql", "CREATE TABLE widgets (id int);")] - violations `shouldSatisfy` \case - [violation] -> "9999-fixture.sql" `Text.isInfixOf` violation - _ -> False - - it "flags a search_path mention" $ do - lintViolations - config - [("9999-fixture.sql", "SET search_path TO keiro;")] - `shouldSatisfy` (not . null) - - it "ignores comment-only mentions" $ do - lintViolations - config - [("9999-fixture.sql", "-- Never set search_path in a migration.\nSELECT 1;")] - `shouldBe` [] - - it "passes all 20 embedded native bodies" $ do - lintViolations config (toList embeddedMigrationEntries) `shouldBe` [] - - describe "startup handshake" $ do - it "reports the full plan on a fresh database" $ do - plan <- requirePlan - withKeiroPg $ \database -> do - handshake <- - missingMigrations - defaultRunOptions - (connectionProviderFromSettings (Pg.connectionSettings database)) - plan - >>= requireRight - Keiro.pendingMigrations handshake `shouldBe` planMigrationIds plan - length (Keiro.pendingMigrations handshake) `shouldBe` 28 - Keiro.ledgerIssues handshake `shouldBe` [] - handshakePassed handshake `shouldBe` False - - it "passes on a fully migrated database" $ do - plan <- requirePlan - result <- withMigratedDatabase plan $ \connection -> do - handshake <- - missingMigrations defaultRunOptions (providerFor connection) plan - >>= requireRight - Keiro.pendingMigrations handshake `shouldBe` [] - Keiro.ledgerIssues handshake `shouldBe` [] - handshakePassed handshake `shouldBe` True - either (expectationFailure . show) pure result - - it "reports the Keiro tail after applying only Kiroku" $ do - plan <- requirePlan - withKeiroPg $ \database -> do - kiroku <- requireRight Kiroku.kirokuMigrations - kirokuOnly <- requireRight (migrationPlan (kiroku :| [])) - let settings = Pg.connectionSettings database - provider = connectionProviderFromSettings settings - _ <- runMigrationPlan defaultRunOptions settings kirokuOnly >>= requireRight - handshake <- - missingMigrations defaultRunOptions provider plan >>= requireRight - Keiro.pendingMigrations handshake `shouldBe` drop 8 (planMigrationIds plan) - length (Keiro.pendingMigrations handshake) `shouldBe` 20 - Keiro.ledgerIssues handshake `shouldBe` [] - handshakePassed handshake `shouldBe` False - - describe "native expected schema" $ do - it "classifies missing, unexpected, and changed objects" $ do - let expected = - Text.unlines - [ "column\twidgets.id\tinteger not null" - , "index\twidgets_id_idx\tCREATE INDEX widgets_id_idx ON keiro.widgets USING btree (id)" - ] - actual = - Text.unlines - [ "column\twidgets.id\tbigint not null" - , "table\twidgets\tkind=r" - ] - compareSchemaSnapshot expected actual - `shouldMatchList` [ ChangedObject - { driftKey = "column\twidgets.id" - , expectedDefinition = "integer not null" - , actualDefinition = "bigint not null" - } - , MissingObject - "index\twidgets_id_idx\tCREATE INDEX widgets_id_idx ON keiro.widgets USING btree (id)" - , UnexpectedObject "table\twidgets\tkind=r" - ] - - it "checked-in snapshot matches what the migrations build" $ do - plan <- requirePlan - snapshotPath <- findNativeExpectedSchema - regenerate <- maybe False (const True) <$> lookupEnv "KEIRO_REGENERATE_EXPECTED_SCHEMA" - result <- withMigratedDatabase plan $ \connection -> do - actual <- useSession connection (snapshotSchema "keiro") - if regenerate - then do - Text.IO.writeFile snapshotPath actual - putStrLn ("regenerated " <> snapshotPath) - else do - expected <- Text.IO.readFile snapshotPath - unless (expected == actual) $ - expectationFailure (snapshotMismatch snapshotPath expected actual) - either (expectationFailure . show) pure result - - it "detects named drift after a hand-altered database" $ do - plan <- requirePlan - withKeiroPg $ \database -> do - let settings = Pg.connectionSettings database - _ <- runMigrationPlan defaultRunOptions settings plan >>= requireRight - clean <- verifyExpectedSchema settings >>= requireRight - clean `shouldBe` [] - withConnection settings $ \connection -> - useSession - connection - ( Session.script - """ - DROP INDEX keiro.keiro_outbox_pending_idx; - ALTER TABLE keiro.keiro_outbox - ALTER COLUMN correlation_id TYPE character varying(64) - USING correlation_id::text; - """ - ) - drifts <- verifyExpectedSchema settings >>= requireRight - let rendered = renderSchemaDrift <$> drifts - rendered - `shouldSatisfy` any - (Text.isInfixOf "keiro_outbox_pending_idx") - rendered - `shouldSatisfy` any - (Text.isInfixOf "keiro_outbox.correlation_id") - - describe "fresh native databases" $ do - it "applies Kiroku then Keiro, verifies strictly, and is repeatable" $ do - plan <- requirePlan - result <- withMigratedDatabase plan $ \connection -> do - assertSchema connection - let provider = providerFor connection - rerun <- runMigrationPlanWith defaultRunOptions provider plan >>= requireRight - reportOutcomes rerun `shouldBe` replicate 28 AlreadyApplied - verified <- verifyMigrationPlanWith defaultRunOptions provider plan >>= requireRight - case verified of - VerificationReport verificationIssues applied pending unknown -> do - verificationIssues `shouldBe` [] - length applied `shouldBe` 28 - pending `shouldBe` [] - unknown `shouldBe` [] - either (expectationFailure . show) pure result - - it "serializes concurrent composed applies" $ do - plan <- requirePlan - withKeiroPg $ \database -> do - let settings = Pg.connectionSettings database - (first, second) <- - concurrently - (runMigrationPlan defaultRunOptions settings plan >>= requireRight) - (runMigrationPlan defaultRunOptions settings plan >>= requireRight) - sort [reportOutcomes first, reportOutcomes second] - `shouldBe` sort [replicate 28 AppliedNow, replicate 28 AlreadyApplied] - - describe "codd-ledger preflight" $ do - it "blocks a current codd ledger before native history exists" $ - assertBlockedCoddPreflight "codd" - - it "blocks a legacy codd_schema ledger before native history exists" $ - assertBlockedCoddPreflight "codd_schema" - - it "is clear on a fresh database" $ - withKeiroPg $ \database -> do - preflight <- - preflightFreshLedgerOverCodd (Pg.connectionSettings database) - >>= requireRight - preflight `shouldBe` CoddPreflightClear - - it "is clear after codd history has been imported" $ do - plan <- requirePlan - withKeiroPg $ \database -> do - let settings = Pg.connectionSettings database - provider = connectionProviderFromSettings settings - withConnection settings $ \connection -> do - applyLegacyPayloads connection - installCoddLedger connection "codd" False False - config <- - requireRight - (frameworkCoddSourceConfig provider True "preflight fixture" Confirmed) - _ <- - importCoddHistory - defaultImportOptions - config - provider - plan - frameworkCoddHistoryMappings - >>= requireRight - preflight <- preflightFreshLedgerOverCodd settings >>= requireRight - preflight `shouldBe` CoddPreflightClear - - describe "combined Codd history import" $ do - it "imports a shared Codd V5 ledger atomically without replaying target SQL" $ - importFixture "codd" - - it "imports the legacy codd_schema ledger shape" $ - importFixture "codd_schema" - - it "rejects one partial source row before creating the target ledger" $ do - plan <- requirePlan - withKeiroPg $ \database -> do - let settings = Pg.connectionSettings database - provider = connectionProviderFromSettings settings - withConnection settings $ \connection -> do - applyLegacyPayloads connection - installCoddLedger connection "codd" True False - config <- - requireRight - (frameworkCoddSourceConfig provider True "partial fixture must fail" Confirmed) - imported <- - importCoddHistory defaultImportOptions config provider plan frameworkCoddHistoryMappings - imported `shouldSatisfy` \case - Left CoddPartialMigration{} -> True - _ -> False - withConnection settings $ \connection -> do - targetExists <- useSession connection (Session.statement "pgmigrate" schemaExistsStatement) - targetExists `shouldBe` False - - it "rejects unselected shared-ledger rows in strict mode" $ do - plan <- requirePlan - withKeiroPg $ \database -> do - let settings = Pg.connectionSettings database - provider = connectionProviderFromSettings settings - withConnection settings $ \connection -> do - applyLegacyPayloads connection - installCoddLedger connection "codd" False True - config <- - requireRight - (frameworkCoddSourceConfig provider True "strict source fixture" Confirmed) - imported <- - importCoddHistory defaultImportOptions config provider plan frameworkCoddHistoryMappings - imported `shouldSatisfy` \case - Left CoddStrictSourceHasUnselected{} -> True - _ -> False - - describe "poisoned-ledger recovery" $ do - it "up before import poisons the ledger and the documented recovery restores the cutover" $ do - plan <- requirePlan - withKeiroPg $ \database -> do - let settings = Pg.connectionSettings database - provider = connectionProviderFromSettings settings - withConnection settings $ \connection -> do - applyLegacyPayloads connection - installCoddLedger connection "codd" False False - - incident <- runMigrationPlan defaultRunOptions settings plan - incident `shouldSatisfy` isLeft - assertPoisonedLedger settings - - config <- - requireRight - (frameworkCoddSourceConfig provider True "poisoned-ledger recovery fixture" Confirmed) - blockedImport <- - importCoddHistory - defaultImportOptions - config - provider - plan - frameworkCoddHistoryMappings - blockedImport `shouldSatisfy` \case - Left (CoddTargetImportFailed HistoryImportConflict{}) -> True - _ -> False - - assertPoisonedLedger settings - withConnection settings $ \connection -> - useSession connection (Session.script "DROP SCHEMA pgmigrate CASCADE;") - - recoveredImport <- - importCoddHistory - defaultImportOptions - config - provider - plan - frameworkCoddHistoryMappings - >>= requireRight - importOutcomes recoveredImport `shouldBe` replicate 23 Imported - - expectedPending <- postCoddImportPendingIssues - verifiedBeforeUp <- - verifyMigrationPlan defaultRunOptions settings plan >>= requireRight - case verifiedBeforeUp of - VerificationReport verificationIssues _ _ _ -> - verificationIssues `shouldBe` expectedPending - - up <- runMigrationPlan defaultRunOptions settings plan >>= requireRight - reportOutcomes up - `shouldBe` replicate 7 AlreadyApplied - <> [AppliedNow] - <> replicate 16 AlreadyApplied - <> replicate 4 AppliedNow - - verifiedAfterUp <- - verifyMigrationPlan defaultRunOptions settings plan >>= requireRight - case verifiedAfterUp of - VerificationReport verificationIssues _ _ _ -> - verificationIssues `shouldBe` [] - withConnection settings assertSchema - -assertBlockedCoddPreflight :: Text -> Expectation -assertBlockedCoddPreflight sourceSchema = - withKeiroPg $ \database -> do - let settings = Pg.connectionSettings database - withConnection settings $ \connection -> do - applyLegacyPayloads connection - installCoddLedger connection sourceSchema False False - preflight <- preflightFreshLedgerOverCodd settings >>= requireRight - let expectedTable = sourceSchema <> ".sql_migrations" - preflight - `shouldBe` CoddPreflightBlocked - { coddLedgerTable = expectedTable - , nativeLedgerAbsent = True - } - renderCoddPreflight preflight `shouldSatisfy` Text.isInfixOf expectedTable - -importFixture :: Text -> Expectation -importFixture sourceSchema = do - plan <- requirePlan - withKeiroPg $ \database -> do - let settings = Pg.connectionSettings database - provider = connectionProviderFromSettings settings - withConnection settings $ \connection -> do - applyLegacyPayloads connection - installCoddLedger connection sourceSchema False False - config <- - requireRight - (frameworkCoddSourceConfig provider True "verified Keiro shared-ledger cutover" Confirmed) - first <- - importCoddHistory defaultImportOptions config provider plan frameworkCoddHistoryMappings - >>= requireRight - importOutcomes first `shouldBe` replicate 23 Imported - expectedPending <- postCoddImportPendingIssues - verifiedBeforeCanaries <- verifyMigrationPlan defaultRunOptions settings plan >>= requireRight - case verifiedBeforeCanaries of - VerificationReport verificationIssues _ _ _ -> - verificationIssues `shouldBe` expectedPending - up <- runMigrationPlan defaultRunOptions settings plan >>= requireRight - reportOutcomes up - `shouldBe` replicate 7 AlreadyApplied - <> [AppliedNow] - <> replicate 16 AlreadyApplied - <> [AppliedNow, AppliedNow, AppliedNow, AppliedNow] - verifiedAfterCanaries <- verifyMigrationPlan defaultRunOptions settings plan >>= requireRight - case verifiedAfterCanaries of - VerificationReport verificationIssues _ _ _ -> verificationIssues `shouldBe` [] - rerun <- runMigrationPlan defaultRunOptions settings plan >>= requireRight - reportOutcomes rerun `shouldBe` replicate 28 AlreadyApplied - second <- - importCoddHistory defaultImportOptions config provider plan frameworkCoddHistoryMappings - >>= requireRight - importOutcomes second `shouldBe` replicate 23 AlreadyImported - withConnection settings $ \connection -> do - assertSchema connection - sourceRows <- useSession connection (Session.statement () (sourceRowCountStatement sourceSchema)) - sourceRows `shouldBe` 23 - facts <- useSession connection (Session.statement () importFactsStatement) - facts `shouldBe` (28, 23, True) - -postCoddImportPendingIssues :: IO [VerificationIssue] -postCoddImportPendingIssues = - traverse pendingMigration pendingNames - where - pendingMigration (component, name) = - PendingMigration <$> requireRight (migrationId component name) - - pendingNames = - [ ("kiroku", "0008-schema-management-comment") - , ("keiro", "0017-schema-management-comment") - , ("keiro", "0018") - , ("keiro", "0019-keiro-snapshots-state-shape-hash") - , ("keiro", "0020-keiro-workflow-children-failure-reason") - ] - -assertPoisonedLedger :: Settings.Settings -> Expectation -assertPoisonedLedger settings = - withConnection settings $ \connection -> do - facts <- - useSession - connection - (Session.statement () poisonedLedgerFactsStatement) - facts `shouldBe` (5, 5, 0) - -nativeMigrationFiles :: [FilePath] -nativeMigrationFiles = - [ "0001-keiro-bootstrap.sql" - , "0002-keiro-outbox.sql" - , "0003-keiro-inbox.sql" - , "0004-keiro-timer-recovery.sql" - , "0005-keiro-workflow-steps.sql" - , "0006-keiro-awakeables.sql" - , "0007-keiro-workflow-children.sql" - , "0008-keiro-workflow-generation.sql" - , "0009-keiro-subscription-shards.sql" - , "0010-keiro-messaging-crash-recovery.sql" - , "0011-keiro-workflows-instances.sql" - , "0012-keiro-workflow-gc-index.sql" - , "0013-keiro-workflows-wake-after.sql" - , "0014-keiro-projection-dedup.sql" - , "0015-keiro-outbox-claim-order-index.sql" - , "0016-keiro-inbox-drop-received-idx.sql" - , "0017-schema-management-comment.sql" - , "0018.sql" - , "0019-keiro-snapshots-state-shape-hash.sql" - , "0020-keiro-workflow-children-failure-reason.sql" - ] - -findMigrationsDirectory :: IO FilePath -findMigrationsDirectory = - findDirectory ["keiro-migrations/migrations", "migrations"] - -findLockfile :: IO FilePath -findLockfile = - findFile ["keiro-migrations/migrations.lock", "migrations.lock"] - -findNativeLockfile :: IO FilePath -findNativeLockfile = - findFile - [ "keiro-migrations/migrations.native.lock" - , "migrations.native.lock" - ] - -findNativeExpectedSchema :: IO FilePath -findNativeExpectedSchema = - findFile - [ "keiro-migrations/expected-schema/native/keiro-v18.txt" - , "expected-schema/native/keiro-v18.txt" - ] - -findDirectory :: [FilePath] -> IO FilePath -findDirectory candidates = do - existing <- filterM doesDirectoryExist candidates - case existing of - directory : _ -> pure directory - [] -> expectationFailure ("could not find directory: " <> show candidates) >> pure "." - -findFile :: [FilePath] -> IO FilePath -findFile candidates = do - existing <- filterM doesFileExist candidates - case existing of - path : _ -> pure path - [] -> expectationFailure ("could not find file: " <> show candidates) >> pure "." - -filterM :: (value -> IO Bool) -> [value] -> IO [value] -filterM predicate = foldr step (pure []) - where - step value remaining = do - matches <- predicate value - values <- remaining - pure (if matches then value : values else values) - -assertFileList :: String -> [FilePath] -> [FilePath] -> Expectation -assertFileList message expected actual = - unless (actual == expected) $ - expectationFailure - ( message - <> "\nmissing: " - <> show (expected \\ actual) - <> "\nunexpected: " - <> show (actual \\ expected) - <> orderDifference - ) - where - orderDifference - | sort expected == sort actual = - "\norder differs\nexpected: " - <> show expected - <> "\nactual: " - <> show actual - | otherwise = "" - -snapshotMismatch :: FilePath -> Text -> Text -> String -snapshotMismatch path expected actual = - "checked-in native schema snapshot differs at " - <> firstDifference - <> "\nRegenerate intentionally with " - <> "KEIRO_REGENERATE_EXPECTED_SCHEMA=1 cabal test keiro-migrations-test " - <> "--test-options='--match \"checked-in snapshot\"' and review " - <> path - where - expectedLines = Text.lines expected - actualLines = Text.lines actual - lineCount = max (length expectedLines) (length actualLines) - paddedExpected = take lineCount (expectedLines <> repeat "") - paddedActual = take lineCount (actualLines <> repeat "") - firstDifference = - case findIndex (uncurry (/=)) (zip paddedExpected paddedActual) of - Nothing -> "an unknown position" - Just index -> - "line " - <> show (index + 1) - <> "\nexpected: " - <> Text.unpack (paddedExpected !! index) - <> "\nactual: " - <> Text.unpack (paddedActual !! index) - -parseLockfile :: Text -> [(FilePath, Text)] -parseLockfile contents = - [ (Text.unpack filename, checksum) - | line <- Text.lines contents - , [checksum, filename] <- [Text.words line] - ] - -checksumText :: ByteString -> Text -checksumText = - Text.pack - . concatMap renderByte - . ByteString.unpack - . migrationChecksumBytes - . migrationFingerprint - where - renderByte byte = - case Numeric.showHex byte "" of - [digit] -> ['0', digit] - digits -> digits - -requirePlan :: IO MigrationPlan -requirePlan = do - kiroku <- requireRight Kiroku.kirokuMigrations - keiro <- requireRight keiroMigrations - requireRight (frameworkMigrationPlan kiroku keiro) - -planMigrationIds :: MigrationPlan -> [MigrationId] -planMigrationIds plan = - [ identifier - | ComponentDescription{migrations} <- toList components - , Migrate.Internal.MigrationDescription identifier _ _ _ _ <- toList migrations - ] - where - PlanDescription components = planDescription plan - -requireRight :: (Show error) => Either error value -> IO value -requireRight = either failure pure - -failure :: (Show value) => value -> IO result -failure value = expectationFailure (show value) >> fail (show value) - -providerFor :: Connection.Connection -> ConnectionProvider -providerFor connection = connectionProvider (\action -> Right <$> action connection) - -reportOutcomes :: MigrationReport -> [MigrationOutcome] -reportOutcomes MigrationReport{results} = outcome <$> toList results - -importOutcomes :: HistoryImportReport -> [HistoryImportOutcome] -importOutcomes HistoryImportReport{importResults} = importOutcome <$> toList importResults - -keiroPgConfig :: Pg.Config -keiroPgConfig = Pg.defaultConfig{Pg.user = "keiro"} - -withKeiroPg :: (Pg.Database -> IO ()) -> IO () -withKeiroPg action = do - started <- Pg.startCached keiroPgConfig Pg.defaultCacheConfig - case started of - Left startError -> expectationFailure (show startError) - Right database -> action database `finally` Pg.stop database - -withConnection :: Settings.Settings -> (Connection.Connection -> IO value) -> IO value -withConnection settings action = do - acquired <- Connection.acquire settings - connection <- requireRight acquired - action connection `finally` Connection.release connection - -useSession :: Connection.Connection -> Session.Session value -> IO value -useSession connection session = - Connection.use connection session >>= requireRight - -assertSchema :: Connection.Connection -> Expectation -assertSchema connection = do - healthy <- useSession connection (Session.statement () schemaFactsStatement) - healthy `shouldBe` True - -schemaFactsStatement :: Statement () Bool -schemaFactsStatement = - Statement.preparable - """ - SELECT bool_and(ok) - FROM (VALUES - (to_regnamespace('kiroku') IS NOT NULL), - (to_regclass('kiroku.events') IS NOT NULL), - (to_regnamespace('keiro') IS NOT NULL), - (to_regclass('keiro.keiro_inbox') IS NOT NULL), - (to_regclass('keiro.keiro_outbox') IS NOT NULL), - (to_regclass('keiro.keiro_timers') IS NOT NULL), - (to_regclass('keiro.keiro_workflows') IS NOT NULL), - (obj_description(to_regnamespace('kiroku'), 'pg_namespace') = 'Managed by pg-migrate component kiroku through 0008-schema-management-comment'), - (obj_description(to_regnamespace('keiro'), 'pg_namespace') = 'Managed by pg-migrate component keiro through 0017-schema-management-comment') - ) AS checks(ok) - """ - Encoders.noParams - (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.bool))) - -applyLegacyPayloads :: Connection.Connection -> IO () -applyLegacyPayloads connection = do - apply Kiroku.Codd.kirokuLegacyMigrationNames Kiroku.Codd.kirokuCoddSourcePayloads - apply keiroLegacyMigrationNames keiroCoddSourcePayloads - where - apply names payloads = - forM_ names $ \name -> - case Map.lookup name payloads of - Nothing -> failure ("missing source payload " <> name) - Just bytes -> useSession connection (Session.script (Text.Encoding.decodeUtf8 bytes)) - -installCoddLedger :: Connection.Connection -> Text -> Bool -> Bool -> IO () -installCoddLedger connection sourceSchema partial includeExtra = - useSession connection (Session.script (coddFixtureSql sourceSchema partial includeExtra)) - -coddFixtureSql :: Text -> Bool -> Bool -> Text -coddFixtureSql sourceSchema partial includeExtra = - Text.unlines - [ "CREATE SCHEMA " <> sourceSchema <> ";" - , "CREATE TABLE " <> sourceSchema <> ".sql_migrations (" - , " id serial NOT NULL, migration_timestamp timestamptz NOT NULL," - , " applied_at timestamptz, name text NOT NULL, application_duration interval," - , " num_applied_statements int, no_txn_failed_at timestamptz, txnid bigint, connid int" - , ");" - , "INSERT INTO " <> sourceSchema <> ".sql_migrations" - , " (migration_timestamp, applied_at, name, application_duration, num_applied_statements, no_txn_failed_at, txnid, connid) VALUES" - , Text.intercalate ",\n" (zipWith renderRow [1 :: Int ..] filenames) <> ";" - ] - where - selected = toList Kiroku.Codd.kirokuLegacyMigrationNames <> toList keiroLegacyMigrationNames - filenames = selected <> ["application-owned-extra.sql" | includeExtra] - renderRow index filename = - "('2026-01-01 00:00:00+00'::timestamptz + interval '" - <> Text.pack (show index) - <> " seconds', " - <> appliedAt index - <> ", '" - <> Text.pack filename - <> "', interval '1 second', 1, " - <> failureAt index - <> ", 1, 1)" - appliedAt index - | partial && index == 11 = "NULL" - | otherwise = "'2026-01-01 00:01:00+00'::timestamptz + interval '" <> Text.pack (show index) <> " seconds'" - failureAt index - | partial && index == 11 = "'2026-01-01 00:02:00+00'::timestamptz" - | otherwise = "NULL" - -schemaExistsStatement :: Statement Text Bool -schemaExistsStatement = - Statement.preparable - "SELECT to_regnamespace($1) IS NOT NULL" - (Encoders.param (Encoders.nonNullable Encoders.text)) - (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.bool))) - -sourceRowCountStatement :: Text -> Statement () Int64 -sourceRowCountStatement sourceSchema = - Statement.unpreparable - ("SELECT count(*) FROM " <> sourceSchema <> ".sql_migrations") - Encoders.noParams - (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.int8))) - -importFactsStatement :: Statement () (Int64, Int64, Bool) -importFactsStatement = - Statement.preparable - """ - SELECT - (SELECT count(*) FROM pgmigrate.migrations), - (SELECT count(*) FROM pgmigrate.history_imports), - (SELECT bool_and(source_evidence #>> '{satisfying_evidence,0,details,adapter}' = 'codd') FROM pgmigrate.history_imports) - """ - Encoders.noParams - ( Decoders.singleRow - ( (,,) - <$> column Decoders.int8 - <*> column Decoders.int8 - <*> column Decoders.bool - ) - ) - where - column = Decoders.column . Decoders.nonNullable - -poisonedLedgerFactsStatement :: Statement () (Int64, Int64, Int64) -poisonedLedgerFactsStatement = - Statement.preparable - """ - SELECT - (SELECT count(*) FROM pgmigrate.migrations), - (SELECT count(*) FROM pgmigrate.migrations WHERE component = 'kiroku'), - (SELECT count(*) FROM pgmigrate.history_imports) - """ - Encoders.noParams - ( Decoders.singleRow - ( (,,) - <$> column Decoders.int8 - <*> column Decoders.int8 - <*> column Decoders.int8 - ) - ) +import Database.PostgreSQL.Migrate.Internal + ( ComponentDescription (..), + PlanDescription (..), + componentNameText, + migrationChecksumBytes, + planDescription, + ) +import Database.PostgreSQL.Migrate.Internal qualified as Migrate.Internal +import Database.PostgreSQL.Migrate.Test (withMigratedDatabase) +import EphemeralPg qualified as Pg +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 +import Keiro.Migrations +import Keiro.Migrations qualified as Keiro +import Keiro.Migrations.History.Codd +import Keiro.Migrations.SchemaCheck +import Kiroku.Store.Migrations qualified as Kiroku +import Kiroku.Store.Migrations.History.Codd qualified as Kiroku.Codd +import Lint +import Numeric qualified +import System.Directory (doesDirectoryExist, doesFileExist, listDirectory) +import System.Environment (lookupEnv) +import System.FilePath (takeExtension, ()) +import Test.Hspec + +main :: IO () +main = hspec $ do + describe "native Keiro migration definition" $ do + it "tracks twenty native files in manifest order" $ do + directory <- findMigrationsDirectory + manifest <- Text.lines <$> Text.IO.readFile (directory "manifest") + manifest `shouldBe` Text.pack <$> nativeMigrationFiles + + it "preserves every legacy payload byte recorded by migrations.lock" $ do + directory <- findMigrationsDirectory + lockPath <- findLockfile + lockEntries <- parseLockfile <$> Text.IO.readFile lockPath + forM_ (zip (toList keiroLegacyMigrationNames) nativeMigrationFiles) $ \(legacyName, nativeName) -> do + bytes <- ByteString.readFile (directory nativeName) + lookup legacyName lockEntries `shouldBe` Just (checksumText bytes) + + it "builds component keiro with dependency kiroku and twenty migrations" $ do + plan <- requirePlan + let PlanDescription components = planDescription plan + case toList components of + [ ComponentDescription {name = kirokuName, dependencies = kirokuDependencies, migrations = kirokuEntries}, + ComponentDescription {name = keiroName, dependencies = keiroDependencies, migrations = keiroEntries} + ] -> do + componentNameText kirokuName `shouldBe` "kiroku" + kirokuDependencies `shouldBe` mempty + length kirokuEntries `shouldBe` 8 + componentNameText keiroName `shouldBe` "keiro" + dependencyName <- requireRight (componentName "kiroku") + keiroDependencies `shouldBe` Set.singleton dependencyName + length keiroEntries `shouldBe` 20 + actual -> expectationFailure ("unexpected plan description: " <> show actual) + validateHistoryMappingTargets plan frameworkCoddHistoryMappings `shouldBe` Right () + + it "rejects missing and reversed Kiroku dependencies" $ do + kiroku <- requireRight Kiroku.kirokuMigrations + keiro <- requireRight keiroMigrations + migrationPlan (keiro :| []) `shouldSatisfy` isLeft + frameworkMigrationPlan keiro kiroku `shouldSatisfy` isLeft + + describe "native checksum lockfile" $ do + it "matches the manifest, directory membership, and every payload byte" $ do + directory <- findMigrationsDirectory + lockPath <- findNativeLockfile + lockEntries <- parseLockfile <$> Text.IO.readFile lockPath + manifestNames <- + fmap Text.unpack . Text.lines + <$> Text.IO.readFile (directory "manifest") + directoryNames <- + sort + . filter ((== ".sql") . takeExtension) + <$> listDirectory directory + let lockNames = fst <$> lockEntries + assertFileList + "migrations.native.lock entries differ from migrations/manifest" + manifestNames + lockNames + assertFileList + "migrations directory entries differ from migrations/manifest" + (sort manifestNames) + directoryNames + forM_ lockEntries $ \(filename, expectedChecksum) -> do + actualChecksum <- + checksumText + <$> ByteString.readFile (directory filename) + unless (actualChecksum == expectedChecksum) $ + expectationFailure + ( "migrations.native.lock checksum mismatch for " + <> filename + <> "\nexpected: " + <> Text.unpack expectedChecksum + <> "\nactual: " + <> Text.unpack actualChecksum + ) + + describe "migration body lint" $ do + let config = LintConfig {requiredQualifier = "keiro.", exemptFiles = []} + + it "flags an unqualified DDL target" $ do + let violations = + lintViolations + config + [("9999-fixture.sql", "CREATE TABLE widgets (id int);")] + violations `shouldSatisfy` \case + [violation] -> "9999-fixture.sql" `Text.isInfixOf` violation + _ -> False + + it "flags a search_path mention" $ do + lintViolations + config + [("9999-fixture.sql", "SET search_path TO keiro;")] + `shouldSatisfy` (not . null) + + it "ignores comment-only mentions" $ do + lintViolations + config + [("9999-fixture.sql", "-- Never set search_path in a migration.\nSELECT 1;")] + `shouldBe` [] + + it "passes all 20 embedded native bodies" $ do + lintViolations config (toList embeddedMigrationEntries) `shouldBe` [] + + describe "startup handshake" $ do + it "reports the full plan on a fresh database" $ do + plan <- requirePlan + withKeiroPg $ \database -> do + handshake <- + missingMigrations + defaultRunOptions + (connectionProviderFromSettings (Pg.connectionSettings database)) + plan + >>= requireRight + Keiro.pendingMigrations handshake `shouldBe` planMigrationIds plan + length (Keiro.pendingMigrations handshake) `shouldBe` 28 + Keiro.ledgerIssues handshake `shouldBe` [] + handshakePassed handshake `shouldBe` False + + it "passes on a fully migrated database" $ do + plan <- requirePlan + result <- withMigratedDatabase plan $ \connection -> do + handshake <- + missingMigrations defaultRunOptions (providerFor connection) plan + >>= requireRight + Keiro.pendingMigrations handshake `shouldBe` [] + Keiro.ledgerIssues handshake `shouldBe` [] + handshakePassed handshake `shouldBe` True + either (expectationFailure . show) pure result + + it "reports the Keiro tail after applying only Kiroku" $ do + plan <- requirePlan + withKeiroPg $ \database -> do + kiroku <- requireRight Kiroku.kirokuMigrations + kirokuOnly <- requireRight (migrationPlan (kiroku :| [])) + let settings = Pg.connectionSettings database + provider = connectionProviderFromSettings settings + _ <- runMigrationPlan defaultRunOptions settings kirokuOnly >>= requireRight + handshake <- + missingMigrations defaultRunOptions provider plan >>= requireRight + Keiro.pendingMigrations handshake `shouldBe` drop 8 (planMigrationIds plan) + length (Keiro.pendingMigrations handshake) `shouldBe` 20 + Keiro.ledgerIssues handshake `shouldBe` [] + handshakePassed handshake `shouldBe` False + + describe "native expected schema" $ do + it "classifies missing, unexpected, and changed objects" $ do + let expected = + Text.unlines + [ "column\twidgets.id\tinteger not null", + "index\twidgets_id_idx\tCREATE INDEX widgets_id_idx ON keiro.widgets USING btree (id)" + ] + actual = + Text.unlines + [ "column\twidgets.id\tbigint not null", + "table\twidgets\tkind=r" + ] + compareSchemaSnapshot expected actual + `shouldMatchList` [ ChangedObject + { driftKey = "column\twidgets.id", + expectedDefinition = "integer not null", + actualDefinition = "bigint not null" + }, + MissingObject + "index\twidgets_id_idx\tCREATE INDEX widgets_id_idx ON keiro.widgets USING btree (id)", + UnexpectedObject "table\twidgets\tkind=r" + ] + + it "checked-in snapshot matches what the migrations build" $ do + plan <- requirePlan + snapshotPath <- findNativeExpectedSchema + regenerate <- maybe False (const True) <$> lookupEnv "KEIRO_REGENERATE_EXPECTED_SCHEMA" + result <- withMigratedDatabase plan $ \connection -> do + actual <- useSession connection (snapshotSchema "keiro") + if regenerate + then do + Text.IO.writeFile snapshotPath actual + putStrLn ("regenerated " <> snapshotPath) + else do + expected <- Text.IO.readFile snapshotPath + unless (expected == actual) $ + expectationFailure (snapshotMismatch snapshotPath expected actual) + either (expectationFailure . show) pure result + + it "detects named drift after a hand-altered database" $ do + plan <- requirePlan + withKeiroPg $ \database -> do + let settings = Pg.connectionSettings database + _ <- runMigrationPlan defaultRunOptions settings plan >>= requireRight + clean <- verifyExpectedSchema settings >>= requireRight + clean `shouldBe` [] + withConnection settings $ \connection -> + useSession + connection + ( Session.script + """ + DROP INDEX keiro.keiro_outbox_pending_idx; + ALTER TABLE keiro.keiro_outbox + ALTER COLUMN correlation_id TYPE character varying(64) + USING correlation_id::text; + """ + ) + drifts <- verifyExpectedSchema settings >>= requireRight + let rendered = renderSchemaDrift <$> drifts + rendered + `shouldSatisfy` any + (Text.isInfixOf "keiro_outbox_pending_idx") + rendered + `shouldSatisfy` any + (Text.isInfixOf "keiro_outbox.correlation_id") + + describe "fresh native databases" $ do + it "applies Kiroku then Keiro, verifies strictly, and is repeatable" $ do + plan <- requirePlan + result <- withMigratedDatabase plan $ \connection -> do + assertSchema connection + let provider = providerFor connection + rerun <- runMigrationPlanWith defaultRunOptions provider plan >>= requireRight + reportOutcomes rerun `shouldBe` replicate 28 AlreadyApplied + verified <- verifyMigrationPlanWith defaultRunOptions provider plan >>= requireRight + case verified of + VerificationReport verificationIssues applied pending unknown -> do + verificationIssues `shouldBe` [] + length applied `shouldBe` 28 + pending `shouldBe` [] + unknown `shouldBe` [] + either (expectationFailure . show) pure result + + it "serializes concurrent composed applies" $ do + plan <- requirePlan + withKeiroPg $ \database -> do + let settings = Pg.connectionSettings database + (first, second) <- + concurrently + (runMigrationPlan defaultRunOptions settings plan >>= requireRight) + (runMigrationPlan defaultRunOptions settings plan >>= requireRight) + sort [reportOutcomes first, reportOutcomes second] + `shouldBe` sort [replicate 28 AppliedNow, replicate 28 AlreadyApplied] + + describe "codd-ledger preflight" $ do + it "blocks a current codd ledger before native history exists" $ + assertBlockedCoddPreflight "codd" + + it "blocks a legacy codd_schema ledger before native history exists" $ + assertBlockedCoddPreflight "codd_schema" + + it "is clear on a fresh database" $ + withKeiroPg $ \database -> do + preflight <- + preflightFreshLedgerOverCodd (Pg.connectionSettings database) + >>= requireRight + preflight `shouldBe` CoddPreflightClear + + it "is clear after codd history has been imported" $ do + plan <- requirePlan + withKeiroPg $ \database -> do + let settings = Pg.connectionSettings database + provider = connectionProviderFromSettings settings + withConnection settings $ \connection -> do + applyLegacyPayloads connection + installCoddLedger connection "codd" False False + config <- + requireRight + (frameworkCoddSourceConfig provider True "preflight fixture" Confirmed) + _ <- + importCoddHistory + defaultImportOptions + config + provider + plan + frameworkCoddHistoryMappings + >>= requireRight + preflight <- preflightFreshLedgerOverCodd settings >>= requireRight + preflight `shouldBe` CoddPreflightClear + + describe "combined Codd history import" $ do + it "imports a shared Codd V5 ledger atomically without replaying target SQL" $ + importFixture "codd" + + it "imports the legacy codd_schema ledger shape" $ + importFixture "codd_schema" + + it "rejects one partial source row before creating the target ledger" $ do + plan <- requirePlan + withKeiroPg $ \database -> do + let settings = Pg.connectionSettings database + provider = connectionProviderFromSettings settings + withConnection settings $ \connection -> do + applyLegacyPayloads connection + installCoddLedger connection "codd" True False + config <- + requireRight + (frameworkCoddSourceConfig provider True "partial fixture must fail" Confirmed) + imported <- + importCoddHistory defaultImportOptions config provider plan frameworkCoddHistoryMappings + imported `shouldSatisfy` \case + Left CoddPartialMigration {} -> True + _ -> False + withConnection settings $ \connection -> do + targetExists <- useSession connection (Session.statement "pgmigrate" schemaExistsStatement) + targetExists `shouldBe` False + + it "rejects unselected shared-ledger rows in strict mode" $ do + plan <- requirePlan + withKeiroPg $ \database -> do + let settings = Pg.connectionSettings database + provider = connectionProviderFromSettings settings + withConnection settings $ \connection -> do + applyLegacyPayloads connection + installCoddLedger connection "codd" False True + config <- + requireRight + (frameworkCoddSourceConfig provider True "strict source fixture" Confirmed) + imported <- + importCoddHistory defaultImportOptions config provider plan frameworkCoddHistoryMappings + imported `shouldSatisfy` \case + Left CoddStrictSourceHasUnselected {} -> True + _ -> False + + describe "poisoned-ledger recovery" $ do + it "up before import poisons the ledger and the documented recovery restores the cutover" $ do + plan <- requirePlan + withKeiroPg $ \database -> do + let settings = Pg.connectionSettings database + provider = connectionProviderFromSettings settings + withConnection settings $ \connection -> do + applyLegacyPayloads connection + installCoddLedger connection "codd" False False + + incident <- runMigrationPlan defaultRunOptions settings plan + incident `shouldSatisfy` isLeft + assertPoisonedLedger settings + + config <- + requireRight + (frameworkCoddSourceConfig provider True "poisoned-ledger recovery fixture" Confirmed) + blockedImport <- + importCoddHistory + defaultImportOptions + config + provider + plan + frameworkCoddHistoryMappings + blockedImport `shouldSatisfy` \case + Left (CoddTargetImportFailed HistoryImportConflict {}) -> True + _ -> False + + assertPoisonedLedger settings + withConnection settings $ \connection -> + useSession connection (Session.script "DROP SCHEMA pgmigrate CASCADE;") + + recoveredImport <- + importCoddHistory + defaultImportOptions + config + provider + plan + frameworkCoddHistoryMappings + >>= requireRight + importOutcomes recoveredImport `shouldBe` replicate 23 Imported + + expectedPending <- postCoddImportPendingIssues + verifiedBeforeUp <- + verifyMigrationPlan defaultRunOptions settings plan >>= requireRight + case verifiedBeforeUp of + VerificationReport verificationIssues _ _ _ -> + verificationIssues `shouldBe` expectedPending + + up <- runMigrationPlan defaultRunOptions settings plan >>= requireRight + reportOutcomes up + `shouldBe` replicate 7 AlreadyApplied + <> [AppliedNow] + <> replicate 16 AlreadyApplied + <> replicate 4 AppliedNow + + verifiedAfterUp <- + verifyMigrationPlan defaultRunOptions settings plan >>= requireRight + case verifiedAfterUp of + VerificationReport verificationIssues _ _ _ -> + verificationIssues `shouldBe` [] + withConnection settings assertSchema + +assertBlockedCoddPreflight :: Text -> Expectation +assertBlockedCoddPreflight sourceSchema = + withKeiroPg $ \database -> do + let settings = Pg.connectionSettings database + withConnection settings $ \connection -> do + applyLegacyPayloads connection + installCoddLedger connection sourceSchema False False + preflight <- preflightFreshLedgerOverCodd settings >>= requireRight + let expectedTable = sourceSchema <> ".sql_migrations" + preflight + `shouldBe` CoddPreflightBlocked + { coddLedgerTable = expectedTable, + nativeLedgerAbsent = True + } + renderCoddPreflight preflight `shouldSatisfy` Text.isInfixOf expectedTable + +importFixture :: Text -> Expectation +importFixture sourceSchema = do + plan <- requirePlan + withKeiroPg $ \database -> do + let settings = Pg.connectionSettings database + provider = connectionProviderFromSettings settings + withConnection settings $ \connection -> do + applyLegacyPayloads connection + installCoddLedger connection sourceSchema False False + config <- + requireRight + (frameworkCoddSourceConfig provider True "verified Keiro shared-ledger cutover" Confirmed) + first <- + importCoddHistory defaultImportOptions config provider plan frameworkCoddHistoryMappings + >>= requireRight + importOutcomes first `shouldBe` replicate 23 Imported + expectedPending <- postCoddImportPendingIssues + verifiedBeforeCanaries <- verifyMigrationPlan defaultRunOptions settings plan >>= requireRight + case verifiedBeforeCanaries of + VerificationReport verificationIssues _ _ _ -> + verificationIssues `shouldBe` expectedPending + up <- runMigrationPlan defaultRunOptions settings plan >>= requireRight + reportOutcomes up + `shouldBe` replicate 7 AlreadyApplied + <> [AppliedNow] + <> replicate 16 AlreadyApplied + <> [AppliedNow, AppliedNow, AppliedNow, AppliedNow] + verifiedAfterCanaries <- verifyMigrationPlan defaultRunOptions settings plan >>= requireRight + case verifiedAfterCanaries of + VerificationReport verificationIssues _ _ _ -> verificationIssues `shouldBe` [] + rerun <- runMigrationPlan defaultRunOptions settings plan >>= requireRight + reportOutcomes rerun `shouldBe` replicate 28 AlreadyApplied + second <- + importCoddHistory defaultImportOptions config provider plan frameworkCoddHistoryMappings + >>= requireRight + importOutcomes second `shouldBe` replicate 23 AlreadyImported + withConnection settings $ \connection -> do + assertSchema connection + sourceRows <- useSession connection (Session.statement () (sourceRowCountStatement sourceSchema)) + sourceRows `shouldBe` 23 + facts <- useSession connection (Session.statement () importFactsStatement) + facts `shouldBe` (28, 23, True) + +postCoddImportPendingIssues :: IO [VerificationIssue] +postCoddImportPendingIssues = + traverse pendingMigration pendingNames + where + pendingMigration (component, name) = + PendingMigration <$> requireRight (migrationId component name) + + pendingNames = + [ ("kiroku", "0008-schema-management-comment"), + ("keiro", "0017-schema-management-comment"), + ("keiro", "0018"), + ("keiro", "0019-keiro-snapshots-state-shape-hash"), + ("keiro", "0020-keiro-workflow-children-failure-reason") + ] + +assertPoisonedLedger :: Settings.Settings -> Expectation +assertPoisonedLedger settings = + withConnection settings $ \connection -> do + facts <- + useSession + connection + (Session.statement () poisonedLedgerFactsStatement) + facts `shouldBe` (5, 5, 0) + +nativeMigrationFiles :: [FilePath] +nativeMigrationFiles = + [ "0001-keiro-bootstrap.sql", + "0002-keiro-outbox.sql", + "0003-keiro-inbox.sql", + "0004-keiro-timer-recovery.sql", + "0005-keiro-workflow-steps.sql", + "0006-keiro-awakeables.sql", + "0007-keiro-workflow-children.sql", + "0008-keiro-workflow-generation.sql", + "0009-keiro-subscription-shards.sql", + "0010-keiro-messaging-crash-recovery.sql", + "0011-keiro-workflows-instances.sql", + "0012-keiro-workflow-gc-index.sql", + "0013-keiro-workflows-wake-after.sql", + "0014-keiro-projection-dedup.sql", + "0015-keiro-outbox-claim-order-index.sql", + "0016-keiro-inbox-drop-received-idx.sql", + "0017-schema-management-comment.sql", + "0018.sql", + "0019-keiro-snapshots-state-shape-hash.sql", + "0020-keiro-workflow-children-failure-reason.sql" + ] + +findMigrationsDirectory :: IO FilePath +findMigrationsDirectory = + findDirectory ["keiro-migrations/migrations", "migrations"] + +findLockfile :: IO FilePath +findLockfile = + findFile ["keiro-migrations/migrations.lock", "migrations.lock"] + +findNativeLockfile :: IO FilePath +findNativeLockfile = + findFile + [ "keiro-migrations/migrations.native.lock", + "migrations.native.lock" + ] + +findNativeExpectedSchema :: IO FilePath +findNativeExpectedSchema = + findFile + [ "keiro-migrations/expected-schema/native/keiro-v18.txt", + "expected-schema/native/keiro-v18.txt" + ] + +findDirectory :: [FilePath] -> IO FilePath +findDirectory candidates = do + existing <- filterM doesDirectoryExist candidates + case existing of + directory : _ -> pure directory + [] -> expectationFailure ("could not find directory: " <> show candidates) >> pure "." + +findFile :: [FilePath] -> IO FilePath +findFile candidates = do + existing <- filterM doesFileExist candidates + case existing of + path : _ -> pure path + [] -> expectationFailure ("could not find file: " <> show candidates) >> pure "." + +filterM :: (value -> IO Bool) -> [value] -> IO [value] +filterM predicate = foldr step (pure []) + where + step value remaining = do + matches <- predicate value + values <- remaining + pure (if matches then value : values else values) + +assertFileList :: String -> [FilePath] -> [FilePath] -> Expectation +assertFileList message expected actual = + unless (actual == expected) $ + expectationFailure + ( message + <> "\nmissing: " + <> show (expected \\ actual) + <> "\nunexpected: " + <> show (actual \\ expected) + <> orderDifference + ) + where + orderDifference + | sort expected == sort actual = + "\norder differs\nexpected: " + <> show expected + <> "\nactual: " + <> show actual + | otherwise = "" + +snapshotMismatch :: FilePath -> Text -> Text -> String +snapshotMismatch path expected actual = + "checked-in native schema snapshot differs at " + <> firstDifference + <> "\nRegenerate intentionally with " + <> "KEIRO_REGENERATE_EXPECTED_SCHEMA=1 cabal test keiro-migrations-test " + <> "--test-options='--match \"checked-in snapshot\"' and review " + <> path + where + expectedLines = Text.lines expected + actualLines = Text.lines actual + lineCount = max (length expectedLines) (length actualLines) + paddedExpected = take lineCount (expectedLines <> repeat "") + paddedActual = take lineCount (actualLines <> repeat "") + firstDifference = + case findIndex (uncurry (/=)) (zip paddedExpected paddedActual) of + Nothing -> "an unknown position" + Just index -> + "line " + <> show (index + 1) + <> "\nexpected: " + <> Text.unpack (paddedExpected !! index) + <> "\nactual: " + <> Text.unpack (paddedActual !! index) + +parseLockfile :: Text -> [(FilePath, Text)] +parseLockfile contents = + [ (Text.unpack filename, checksum) + | line <- Text.lines contents, + [checksum, filename] <- [Text.words line] + ] + +checksumText :: ByteString -> Text +checksumText = + Text.pack + . concatMap renderByte + . ByteString.unpack + . migrationChecksumBytes + . migrationFingerprint + where + renderByte byte = + case Numeric.showHex byte "" of + [digit] -> ['0', digit] + digits -> digits + +requirePlan :: IO MigrationPlan +requirePlan = do + kiroku <- requireRight Kiroku.kirokuMigrations + keiro <- requireRight keiroMigrations + requireRight (frameworkMigrationPlan kiroku keiro) + +planMigrationIds :: MigrationPlan -> [MigrationId] +planMigrationIds plan = + [ identifier + | ComponentDescription {migrations} <- toList components, + Migrate.Internal.MigrationDescription identifier _ _ _ _ <- toList migrations + ] + where + PlanDescription components = planDescription plan + +requireRight :: (Show error) => Either error value -> IO value +requireRight = either failure pure + +failure :: (Show value) => value -> IO result +failure value = expectationFailure (show value) >> fail (show value) + +providerFor :: Connection.Connection -> ConnectionProvider +providerFor connection = connectionProvider (\action -> Right <$> action connection) + +reportOutcomes :: MigrationReport -> [MigrationOutcome] +reportOutcomes MigrationReport {results} = outcome <$> toList results + +importOutcomes :: HistoryImportReport -> [HistoryImportOutcome] +importOutcomes HistoryImportReport {importResults} = importOutcome <$> toList importResults + +keiroPgConfig :: Pg.Config +keiroPgConfig = Pg.defaultConfig {Pg.user = "keiro"} + +withKeiroPg :: (Pg.Database -> IO ()) -> IO () +withKeiroPg action = do + started <- Pg.startCached keiroPgConfig Pg.defaultCacheConfig + case started of + Left startError -> expectationFailure (show startError) + Right database -> action database `finally` Pg.stop database + +withConnection :: Settings.Settings -> (Connection.Connection -> IO value) -> IO value +withConnection settings action = do + acquired <- Connection.acquire settings + connection <- requireRight acquired + action connection `finally` Connection.release connection + +useSession :: Connection.Connection -> Session.Session value -> IO value +useSession connection session = + Connection.use connection session >>= requireRight + +assertSchema :: Connection.Connection -> Expectation +assertSchema connection = do + healthy <- useSession connection (Session.statement () schemaFactsStatement) + healthy `shouldBe` True + +schemaFactsStatement :: Statement () Bool +schemaFactsStatement = + Statement.preparable + """ + SELECT bool_and(ok) + FROM (VALUES + (to_regnamespace('kiroku') IS NOT NULL), + (to_regclass('kiroku.events') IS NOT NULL), + (to_regnamespace('keiro') IS NOT NULL), + (to_regclass('keiro.keiro_inbox') IS NOT NULL), + (to_regclass('keiro.keiro_outbox') IS NOT NULL), + (to_regclass('keiro.keiro_timers') IS NOT NULL), + (to_regclass('keiro.keiro_workflows') IS NOT NULL), + (obj_description(to_regnamespace('kiroku'), 'pg_namespace') = 'Managed by pg-migrate component kiroku through 0008-schema-management-comment'), + (obj_description(to_regnamespace('keiro'), 'pg_namespace') = 'Managed by pg-migrate component keiro through 0017-schema-management-comment') + ) AS checks(ok) + """ + Encoders.noParams + (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.bool))) + +applyLegacyPayloads :: Connection.Connection -> IO () +applyLegacyPayloads connection = do + apply Kiroku.Codd.kirokuLegacyMigrationNames Kiroku.Codd.kirokuCoddSourcePayloads + apply keiroLegacyMigrationNames keiroCoddSourcePayloads + where + apply names payloads = + forM_ names $ \name -> + case Map.lookup name payloads of + Nothing -> failure ("missing source payload " <> name) + Just bytes -> useSession connection (Session.script (Text.Encoding.decodeUtf8 bytes)) + +installCoddLedger :: Connection.Connection -> Text -> Bool -> Bool -> IO () +installCoddLedger connection sourceSchema partial includeExtra = + useSession connection (Session.script (coddFixtureSql sourceSchema partial includeExtra)) + +coddFixtureSql :: Text -> Bool -> Bool -> Text +coddFixtureSql sourceSchema partial includeExtra = + Text.unlines + [ "CREATE SCHEMA " <> sourceSchema <> ";", + "CREATE TABLE " <> sourceSchema <> ".sql_migrations (", + " id serial NOT NULL, migration_timestamp timestamptz NOT NULL,", + " applied_at timestamptz, name text NOT NULL, application_duration interval,", + " num_applied_statements int, no_txn_failed_at timestamptz, txnid bigint, connid int", + ");", + "INSERT INTO " <> sourceSchema <> ".sql_migrations", + " (migration_timestamp, applied_at, name, application_duration, num_applied_statements, no_txn_failed_at, txnid, connid) VALUES", + Text.intercalate ",\n" (zipWith renderRow [1 :: Int ..] filenames) <> ";" + ] + where + selected = toList Kiroku.Codd.kirokuLegacyMigrationNames <> toList keiroLegacyMigrationNames + filenames = selected <> ["application-owned-extra.sql" | includeExtra] + renderRow index filename = + "('2026-01-01 00:00:00+00'::timestamptz + interval '" + <> Text.pack (show index) + <> " seconds', " + <> appliedAt index + <> ", '" + <> Text.pack filename + <> "', interval '1 second', 1, " + <> failureAt index + <> ", 1, 1)" + appliedAt index + | partial && index == 11 = "NULL" + | otherwise = "'2026-01-01 00:01:00+00'::timestamptz + interval '" <> Text.pack (show index) <> " seconds'" + failureAt index + | partial && index == 11 = "'2026-01-01 00:02:00+00'::timestamptz" + | otherwise = "NULL" + +schemaExistsStatement :: Statement Text Bool +schemaExistsStatement = + Statement.preparable + "SELECT to_regnamespace($1) IS NOT NULL" + (Encoders.param (Encoders.nonNullable Encoders.text)) + (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.bool))) + +sourceRowCountStatement :: Text -> Statement () Int64 +sourceRowCountStatement sourceSchema = + Statement.unpreparable + ("SELECT count(*) FROM " <> sourceSchema <> ".sql_migrations") + Encoders.noParams + (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.int8))) + +importFactsStatement :: Statement () (Int64, Int64, Bool) +importFactsStatement = + Statement.preparable + """ + SELECT + (SELECT count(*) FROM pgmigrate.migrations), + (SELECT count(*) FROM pgmigrate.history_imports), + (SELECT bool_and(source_evidence #>> '{satisfying_evidence,0,details,adapter}' = 'codd') FROM pgmigrate.history_imports) + """ + Encoders.noParams + ( Decoders.singleRow + ( (,,) + <$> column Decoders.int8 + <*> column Decoders.int8 + <*> column Decoders.bool + ) + ) + where + column = Decoders.column . Decoders.nonNullable + +poisonedLedgerFactsStatement :: Statement () (Int64, Int64, Int64) +poisonedLedgerFactsStatement = + Statement.preparable + """ + SELECT + (SELECT count(*) FROM pgmigrate.migrations), + (SELECT count(*) FROM pgmigrate.migrations WHERE component = 'kiroku'), + (SELECT count(*) FROM pgmigrate.history_imports) + """ + Encoders.noParams + ( Decoders.singleRow + ( (,,) + <$> column Decoders.int8 + <*> column Decoders.int8 + <*> column Decoders.int8 + ) + ) where column = Decoders.column . Decoders.nonNullable