diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,7 +6,44 @@ ## [Unreleased] -_No unreleased changes._ +## 0.4.0.1 — 2026-07-28 + +### Other Changes + +- Adds PVP upper bounds to every dependency that previously carried a lower + bound only, so `cabal check` reports no packaging warnings. No API or + behaviour change from 0.4.0.0, which was tagged but never published. + + +## 0.4.0.0 — 2026-07-28 + +### Breaking Changes + +- `keiro-migrate up` now refuses to initialize an absent or empty native + `pgmigrate` ledger over a detected Codd ledger. Import the verified Codd + history first, or use `--allow-fresh-ledger-over-codd` only when deliberately + abandoning that history. + +### New Features + +- Adds the read-only `missingMigrations` startup handshake so every application + replica can reject pending, corrupt, or unknown migration history before + serving traffic. +- Adds a canonical PostgreSQL 18 schema snapshot and `keiro-migrate + verify-schema`, which reports missing, unexpected, or changed objects in the + live `keiro` schema. +- Adds `keiro-migrate import-codd-history`, with exact Kiroku/Keiro payload + mappings, advisory locking, confirmation, structured reports, and recovery + coverage for interrupted or poisoned imports. + +### Bug Fixes + +- Embedded migration changes now force GHC recompilation through + `pg-migrate-embed`, preventing an incremental build from retaining stale SQL + or manifest bytes. +- Default conformance again lints every embedded migration for schema + qualification and forbidden `search_path` dependence, and pins the native + payload lock against accidental edits. ## 0.3.0.0 — 2026-07-14 diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -2,38 +2,361 @@ import Data.Aeson qualified as Aeson import Data.ByteString.Lazy.Char8 qualified as LazyByteString +import Data.Foldable (toList, traverse_) +import Data.Int (Int64) import Data.Text qualified as Text import Data.Text.IO qualified as Text.IO -import Database.PostgreSQL.Migrate (defaultRunOptions) +import Database.PostgreSQL.Migrate ( + Confirmation (..), + HistoryImportError (..), + HistoryImportOutcome (..), + HistoryImportReport (..), + HistoryImportResult (..), + MigrationId, + MigrationPlan, + connectionProviderFromSettings, + defaultImportOptions, + defaultRunOptions, + ) import Database.PostgreSQL.Migrate.CLI +import Database.PostgreSQL.Migrate.History.Codd ( + CoddImportError (..), + defaultCoddLockKey, + importCoddHistory, + withCoddLockKey, + ) +import Database.PostgreSQL.Migrate.Internal ( + componentNameText, + migrationIdComponent, + migrationIdName, + migrationNameText, + ) import Hasql.Connection.Settings qualified as Settings -import Keiro.Migrations (frameworkMigrationPlan, keiroMigrations) +import Keiro.Migrations ( + CoddLedgerPreflight (..), + frameworkMigrationPlan, + keiroMigrations, + preflightFreshLedgerOverCodd, + renderCoddPreflight, + ) +import Keiro.Migrations.History.Codd ( + frameworkCoddHistoryMappings, + frameworkCoddSourceConfig, + ) +import Keiro.Migrations.SchemaCheck ( + renderSchemaDrift, + verifyExpectedSchema, + ) import Kiroku.Store.Migrations qualified as Kiroku +import Numeric qualified import Options.Applicative import System.Environment (lookupEnv) import System.Exit qualified as Exit +import System.IO (stderr) +import Text.Read qualified as Read 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) - command <- + invocation <- execParser ( info - (migrationCommandParser plan <**> helper) + (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)) - 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) + runKeiroInvocation defaultSettings plan invocation + +data KeiroInvocation = KeiroInvocation + { allowFreshLedgerOverCodd :: Bool + , keiroCommand :: KeiroCommand + } + +runKeiroInvocation :: + 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 + +isUpCommand :: KeiroCommand -> Bool +isUpCommand keiroCommand = + case keiroCommand of + Framework Up{} -> True + _ -> False + +preflightFrameworkUp :: + 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 () + +data KeiroCommand + = Framework MigrationCommand + | VerifySchema VerifySchemaOptions + | ImportCoddHistory ImportCoddOptions + +newtype VerifySchemaOptions = VerifySchemaOptions + { verifySchemaDatabaseSettings :: Maybe Settings.Settings + } + +data ImportCoddOptions = ImportCoddOptions + { 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 + +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") + ) + ) + +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" + ) + ) + +databaseSettingsReader :: ReadM Settings.Settings +databaseSettingsReader = + 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") + +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 + where + checkedInt64 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 + +runImportCoddHistory :: + 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) + +renderHistoryImportText :: HistoryImportReport -> Text.Text +renderHistoryImportText HistoryImportReport{importResults} = + Text.unlines (renderResult <$> toList importResults) + where + 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) + +renderCoddImportError :: CoddImportError -> Text.Text +renderCoddImportError 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 _ = "" + + 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." commandOutputFormat :: MigrationCommand -> OutputFormat commandOutputFormat command = diff --git a/expected-schema/native/keiro-v18.txt b/expected-schema/native/keiro-v18.txt new file mode 100644 --- /dev/null +++ b/expected-schema/native/keiro-v18.txt @@ -0,0 +1,300 @@ +column keiro_awakeables.awakeable_id uuid not null +column keiro_awakeables.completed_at timestamp with time zone +column keiro_awakeables.created_at timestamp with time zone not null default now() +column keiro_awakeables.owner_workflow_id text not null +column keiro_awakeables.owner_workflow_name text not null +column keiro_awakeables.payload jsonb +column keiro_awakeables.status text not null default 'pending'::text +column keiro_awakeables.updated_at timestamp with time zone not null default now() +column keiro_dead_letters.attempt_count integer not null +column keiro_dead_letters.correlation_id text not null +column keiro_dead_letters.created_at timestamp with time zone not null default now() +column keiro_dead_letters.dead_letter_id bigint not null default nextval('keiro.keiro_dead_letters_dead_letter_id_seq'::regclass) +column keiro_dead_letters.dispatcher_kind text not null +column keiro_dead_letters.dispatcher_name text not null +column keiro_dead_letters.emit_index integer not null +column keiro_dead_letters.error_class text not null +column keiro_dead_letters.error_detail text not null +column keiro_dead_letters.source_event_id uuid not null +column keiro_dead_letters.source_global_position bigint not null +column keiro_dead_letters.target_stream_name text not null +column keiro_inbox.attempt_count bigint not null default 0 +column keiro_inbox.attributes jsonb +column keiro_inbox.causation_id uuid +column keiro_inbox.completed_at timestamp with time zone +column keiro_inbox.content_type text not null +column keiro_inbox.correlation_id uuid +column keiro_inbox.dedupe_key text not null +column keiro_inbox.destination text +column keiro_inbox.event_type text +column keiro_inbox.failed_at timestamp with time zone +column keiro_inbox.kafka_offset bigint +column keiro_inbox.kafka_partition bigint +column keiro_inbox.kafka_topic text +column keiro_inbox.last_error text +column keiro_inbox.message_id text +column keiro_inbox.occurred_at timestamp with time zone +column keiro_inbox.payload_bytes bytea not null +column keiro_inbox.received_at timestamp with time zone not null default now() +column keiro_inbox.schema_fingerprint text +column keiro_inbox.schema_id bigint +column keiro_inbox.schema_registry text +column keiro_inbox.schema_subject text +column keiro_inbox.schema_version bigint +column keiro_inbox.schema_version_ref bigint +column keiro_inbox.source text not null +column keiro_inbox.source_event_id uuid +column keiro_inbox.source_global_position bigint +column keiro_inbox.status text not null default 'processing'::text +column keiro_inbox.traceparent text +column keiro_inbox.tracestate text +column keiro_outbox.attempt_count bigint not null default 0 +column keiro_outbox.attributes jsonb +column keiro_outbox.causation_id uuid +column keiro_outbox.content_type text not null +column keiro_outbox.correlation_id uuid +column keiro_outbox.created_at timestamp with time zone not null default now() +column keiro_outbox.destination text not null +column keiro_outbox.event_type text not null +column keiro_outbox.last_error text +column keiro_outbox.message_id text not null +column keiro_outbox.message_key text +column keiro_outbox.next_attempt_at timestamp with time zone not null default now() +column keiro_outbox.occurred_at timestamp with time zone not null +column keiro_outbox.outbox_id uuid not null +column keiro_outbox.payload_bytes bytea not null +column keiro_outbox.published_at timestamp with time zone +column keiro_outbox.schema_fingerprint text +column keiro_outbox.schema_id bigint +column keiro_outbox.schema_registry text +column keiro_outbox.schema_subject text +column keiro_outbox.schema_version bigint not null +column keiro_outbox.schema_version_ref bigint +column keiro_outbox.source text not null +column keiro_outbox.source_event_id uuid +column keiro_outbox.source_global_position bigint +column keiro_outbox.status text not null default 'pending'::text +column keiro_outbox.traceparent text +column keiro_outbox.tracestate text +column keiro_outbox.updated_at timestamp with time zone not null default now() +column keiro_projection_dedup.applied_at timestamp with time zone not null default now() +column keiro_projection_dedup.event_id uuid not null +column keiro_projection_dedup.projection_name text not null +column keiro_read_models.last_built_at timestamp with time zone +column keiro_read_models.name text not null +column keiro_read_models.shape_hash text not null +column keiro_read_models.status text not null +column keiro_read_models.updated_at timestamp with time zone not null default now() +column keiro_read_models.version bigint not null +column keiro_snapshots.created_at timestamp with time zone not null default now() +column keiro_snapshots.regfile_shape_hash text not null +column keiro_snapshots.state jsonb not null +column keiro_snapshots.state_codec_version bigint not null +column keiro_snapshots.state_shape_hash text not null default ''::text +column keiro_snapshots.stream_id bigint not null +column keiro_snapshots.stream_version bigint not null +column keiro_snapshots.updated_at timestamp with time zone not null default now() +column keiro_subscription_shards.bucket integer not null +column keiro_subscription_shards.heartbeat_at timestamp with time zone +column keiro_subscription_shards.lease_expires_at timestamp with time zone +column keiro_subscription_shards.owner_worker_id uuid +column keiro_subscription_shards.shard_count integer not null +column keiro_subscription_shards.subscription_name text not null +column keiro_subscription_shards.updated_at timestamp with time zone not null default now() +column keiro_timers.attempts bigint not null default 0 +column keiro_timers.correlation_id text not null +column keiro_timers.created_at timestamp with time zone not null default now() +column keiro_timers.fire_at timestamp with time zone not null +column keiro_timers.fired_event_id uuid +column keiro_timers.last_error text +column keiro_timers.payload jsonb not null +column keiro_timers.process_manager_name text not null +column keiro_timers.status text not null default 'scheduled'::text +column keiro_timers.timer_id uuid not null +column keiro_timers.updated_at timestamp with time zone not null default now() +column keiro_workflow_children.await_step text not null +column keiro_workflow_children.child_id text not null +column keiro_workflow_children.child_name text not null +column keiro_workflow_children.completed_at timestamp with time zone +column keiro_workflow_children.created_at timestamp with time zone not null default now() +column keiro_workflow_children.failure_reason text +column keiro_workflow_children.parent_id text not null +column keiro_workflow_children.parent_name text not null +column keiro_workflow_children.result jsonb +column keiro_workflow_children.status text not null default 'running'::text +column keiro_workflow_children.updated_at timestamp with time zone not null default now() +column keiro_workflow_steps.generation integer not null default 0 +column keiro_workflow_steps.recorded_at timestamp with time zone not null default now() +column keiro_workflow_steps.result jsonb not null +column keiro_workflow_steps.step_name text not null +column keiro_workflow_steps.workflow_id text not null +column keiro_workflow_steps.workflow_name text not null +column keiro_workflows.attempts integer not null default 0 +column keiro_workflows.completed_at timestamp with time zone +column keiro_workflows.created_at timestamp with time zone not null default now() +column keiro_workflows.generation integer not null default 0 +column keiro_workflows.last_error text +column keiro_workflows.lease_expires_at timestamp with time zone +column keiro_workflows.leased_by text +column keiro_workflows.next_attempt_at timestamp with time zone +column keiro_workflows.status text not null default 'running'::text +column keiro_workflows.updated_at timestamp with time zone not null default now() +column keiro_workflows.wake_after timestamp with time zone +column keiro_workflows.workflow_id text not null +column keiro_workflows.workflow_name text not null +constraint keiro_awakeables.keiro_awakeables_awakeable_id_not_null NOT NULL awakeable_id +constraint keiro_awakeables.keiro_awakeables_created_at_not_null NOT NULL created_at +constraint keiro_awakeables.keiro_awakeables_owner_workflow_id_not_null NOT NULL owner_workflow_id +constraint keiro_awakeables.keiro_awakeables_owner_workflow_name_not_null NOT NULL owner_workflow_name +constraint keiro_awakeables.keiro_awakeables_pkey PRIMARY KEY (awakeable_id) +constraint keiro_awakeables.keiro_awakeables_status_chk CHECK ((status = ANY (ARRAY['pending'::text, 'completed'::text, 'cancelled'::text]))) +constraint keiro_awakeables.keiro_awakeables_status_not_null NOT NULL status +constraint keiro_awakeables.keiro_awakeables_updated_at_not_null NOT NULL updated_at +constraint keiro_dead_letters.keiro_dead_letters_attempt_count_chk CHECK ((attempt_count >= 1)) +constraint keiro_dead_letters.keiro_dead_letters_attempt_count_not_null NOT NULL attempt_count +constraint keiro_dead_letters.keiro_dead_letters_correlation_id_not_null NOT NULL correlation_id +constraint keiro_dead_letters.keiro_dead_letters_created_at_not_null NOT NULL created_at +constraint keiro_dead_letters.keiro_dead_letters_dead_letter_id_not_null NOT NULL dead_letter_id +constraint keiro_dead_letters.keiro_dead_letters_dispatcher_kind_chk CHECK ((dispatcher_kind = ANY (ARRAY['process-manager'::text, 'router'::text]))) +constraint keiro_dead_letters.keiro_dead_letters_dispatcher_kind_not_null NOT NULL dispatcher_kind +constraint keiro_dead_letters.keiro_dead_letters_dispatcher_name_not_null NOT NULL dispatcher_name +constraint keiro_dead_letters.keiro_dead_letters_dispatcher_name_source_event_id_emit_ind_key UNIQUE (dispatcher_name, source_event_id, emit_index) +constraint keiro_dead_letters.keiro_dead_letters_emit_index_not_null NOT NULL emit_index +constraint keiro_dead_letters.keiro_dead_letters_error_class_not_null NOT NULL error_class +constraint keiro_dead_letters.keiro_dead_letters_error_detail_not_null NOT NULL error_detail +constraint keiro_dead_letters.keiro_dead_letters_pkey PRIMARY KEY (dead_letter_id) +constraint keiro_dead_letters.keiro_dead_letters_source_event_id_not_null NOT NULL source_event_id +constraint keiro_dead_letters.keiro_dead_letters_source_global_position_not_null NOT NULL source_global_position +constraint keiro_dead_letters.keiro_dead_letters_target_stream_name_not_null NOT NULL target_stream_name +constraint keiro_inbox.keiro_inbox_attempt_count_not_null NOT NULL attempt_count +constraint keiro_inbox.keiro_inbox_content_type_not_null NOT NULL content_type +constraint keiro_inbox.keiro_inbox_dedupe_key_not_null NOT NULL dedupe_key +constraint keiro_inbox.keiro_inbox_payload_bytes_not_null NOT NULL payload_bytes +constraint keiro_inbox.keiro_inbox_pkey PRIMARY KEY (source, dedupe_key) +constraint keiro_inbox.keiro_inbox_received_at_not_null NOT NULL received_at +constraint keiro_inbox.keiro_inbox_source_not_null NOT NULL source +constraint keiro_inbox.keiro_inbox_status_not_null NOT NULL status +constraint keiro_outbox.keiro_outbox_attempt_count_not_null NOT NULL attempt_count +constraint keiro_outbox.keiro_outbox_content_type_not_null NOT NULL content_type +constraint keiro_outbox.keiro_outbox_created_at_not_null NOT NULL created_at +constraint keiro_outbox.keiro_outbox_destination_not_null NOT NULL destination +constraint keiro_outbox.keiro_outbox_event_type_not_null NOT NULL event_type +constraint keiro_outbox.keiro_outbox_message_id_not_null NOT NULL message_id +constraint keiro_outbox.keiro_outbox_next_attempt_at_not_null NOT NULL next_attempt_at +constraint keiro_outbox.keiro_outbox_occurred_at_not_null NOT NULL occurred_at +constraint keiro_outbox.keiro_outbox_outbox_id_not_null NOT NULL outbox_id +constraint keiro_outbox.keiro_outbox_payload_bytes_not_null NOT NULL payload_bytes +constraint keiro_outbox.keiro_outbox_pkey PRIMARY KEY (outbox_id) +constraint keiro_outbox.keiro_outbox_schema_version_not_null NOT NULL schema_version +constraint keiro_outbox.keiro_outbox_source_message_id_key UNIQUE (source, message_id) +constraint keiro_outbox.keiro_outbox_source_not_null NOT NULL source +constraint keiro_outbox.keiro_outbox_status_not_null NOT NULL status +constraint keiro_outbox.keiro_outbox_updated_at_not_null NOT NULL updated_at +constraint keiro_projection_dedup.keiro_projection_dedup_applied_at_not_null NOT NULL applied_at +constraint keiro_projection_dedup.keiro_projection_dedup_event_id_not_null NOT NULL event_id +constraint keiro_projection_dedup.keiro_projection_dedup_pkey PRIMARY KEY (projection_name, event_id) +constraint keiro_projection_dedup.keiro_projection_dedup_projection_name_not_null NOT NULL projection_name +constraint keiro_read_models.keiro_read_models_name_not_null NOT NULL name +constraint keiro_read_models.keiro_read_models_pkey PRIMARY KEY (name) +constraint keiro_read_models.keiro_read_models_shape_hash_not_null NOT NULL shape_hash +constraint keiro_read_models.keiro_read_models_status_not_null NOT NULL status +constraint keiro_read_models.keiro_read_models_updated_at_not_null NOT NULL updated_at +constraint keiro_read_models.keiro_read_models_version_not_null NOT NULL version +constraint keiro_snapshots.keiro_snapshots_created_at_not_null NOT NULL created_at +constraint keiro_snapshots.keiro_snapshots_pkey PRIMARY KEY (stream_id) +constraint keiro_snapshots.keiro_snapshots_regfile_shape_hash_not_null NOT NULL regfile_shape_hash +constraint keiro_snapshots.keiro_snapshots_state_codec_version_not_null NOT NULL state_codec_version +constraint keiro_snapshots.keiro_snapshots_state_not_null NOT NULL state +constraint keiro_snapshots.keiro_snapshots_state_shape_hash_not_null NOT NULL state_shape_hash +constraint keiro_snapshots.keiro_snapshots_stream_id_not_null NOT NULL stream_id +constraint keiro_snapshots.keiro_snapshots_stream_version_not_null NOT NULL stream_version +constraint keiro_snapshots.keiro_snapshots_updated_at_not_null NOT NULL updated_at +constraint keiro_subscription_shards.keiro_subscription_shards_bucket_not_null NOT NULL bucket +constraint keiro_subscription_shards.keiro_subscription_shards_bucket_range_chk CHECK (((bucket >= 0) AND (bucket < shard_count))) +constraint keiro_subscription_shards.keiro_subscription_shards_count_chk CHECK ((shard_count >= 1)) +constraint keiro_subscription_shards.keiro_subscription_shards_pkey PRIMARY KEY (subscription_name, bucket) +constraint keiro_subscription_shards.keiro_subscription_shards_shard_count_not_null NOT NULL shard_count +constraint keiro_subscription_shards.keiro_subscription_shards_subscription_name_not_null NOT NULL subscription_name +constraint keiro_subscription_shards.keiro_subscription_shards_updated_at_not_null NOT NULL updated_at +constraint keiro_timers.keiro_timers_attempts_not_null NOT NULL attempts +constraint keiro_timers.keiro_timers_correlation_id_not_null NOT NULL correlation_id +constraint keiro_timers.keiro_timers_created_at_not_null NOT NULL created_at +constraint keiro_timers.keiro_timers_fire_at_not_null NOT NULL fire_at +constraint keiro_timers.keiro_timers_payload_not_null NOT NULL payload +constraint keiro_timers.keiro_timers_pkey PRIMARY KEY (timer_id) +constraint keiro_timers.keiro_timers_process_manager_name_not_null NOT NULL process_manager_name +constraint keiro_timers.keiro_timers_status_not_null NOT NULL status +constraint keiro_timers.keiro_timers_timer_id_not_null NOT NULL timer_id +constraint keiro_timers.keiro_timers_updated_at_not_null NOT NULL updated_at +constraint keiro_workflow_children.keiro_workflow_children_await_step_not_null NOT NULL await_step +constraint keiro_workflow_children.keiro_workflow_children_child_id_not_null NOT NULL child_id +constraint keiro_workflow_children.keiro_workflow_children_child_name_not_null NOT NULL child_name +constraint keiro_workflow_children.keiro_workflow_children_created_at_not_null NOT NULL created_at +constraint keiro_workflow_children.keiro_workflow_children_parent_id_not_null NOT NULL parent_id +constraint keiro_workflow_children.keiro_workflow_children_parent_name_not_null NOT NULL parent_name +constraint keiro_workflow_children.keiro_workflow_children_pkey PRIMARY KEY (child_id, child_name) +constraint keiro_workflow_children.keiro_workflow_children_status_chk CHECK ((status = ANY (ARRAY['running'::text, 'completed'::text, 'cancelled'::text, 'failed'::text]))) +constraint keiro_workflow_children.keiro_workflow_children_status_not_null NOT NULL status +constraint keiro_workflow_children.keiro_workflow_children_updated_at_not_null NOT NULL updated_at +constraint keiro_workflow_steps.keiro_workflow_steps_generation_not_null NOT NULL generation +constraint keiro_workflow_steps.keiro_workflow_steps_pkey PRIMARY KEY (workflow_id, workflow_name, generation, step_name) +constraint keiro_workflow_steps.keiro_workflow_steps_recorded_at_not_null NOT NULL recorded_at +constraint keiro_workflow_steps.keiro_workflow_steps_result_not_null NOT NULL result +constraint keiro_workflow_steps.keiro_workflow_steps_step_name_not_null NOT NULL step_name +constraint keiro_workflow_steps.keiro_workflow_steps_workflow_id_not_null NOT NULL workflow_id +constraint keiro_workflow_steps.keiro_workflow_steps_workflow_name_not_null NOT NULL workflow_name +constraint keiro_workflows.keiro_workflows_attempts_not_null NOT NULL attempts +constraint keiro_workflows.keiro_workflows_created_at_not_null NOT NULL created_at +constraint keiro_workflows.keiro_workflows_generation_not_null NOT NULL generation +constraint keiro_workflows.keiro_workflows_pkey PRIMARY KEY (workflow_id, workflow_name) +constraint keiro_workflows.keiro_workflows_status_chk CHECK ((status = ANY (ARRAY['running'::text, 'suspended'::text, 'completed'::text, 'cancelled'::text, 'failed'::text]))) +constraint keiro_workflows.keiro_workflows_status_not_null NOT NULL status +constraint keiro_workflows.keiro_workflows_updated_at_not_null NOT NULL updated_at +constraint keiro_workflows.keiro_workflows_workflow_id_not_null NOT NULL workflow_id +constraint keiro_workflows.keiro_workflows_workflow_name_not_null NOT NULL workflow_name +index keiro_awakeables_owner_idx CREATE INDEX keiro_awakeables_owner_idx ON keiro.keiro_awakeables USING btree (owner_workflow_name, owner_workflow_id) +index keiro_awakeables_pending_idx CREATE INDEX keiro_awakeables_pending_idx ON keiro.keiro_awakeables USING btree (status) WHERE (status = 'pending'::text) +index keiro_awakeables_pkey CREATE UNIQUE INDEX keiro_awakeables_pkey ON keiro.keiro_awakeables USING btree (awakeable_id) +index keiro_dead_letters_dispatcher_created_at_idx CREATE INDEX keiro_dead_letters_dispatcher_created_at_idx ON keiro.keiro_dead_letters USING btree (dispatcher_name, created_at DESC) +index keiro_dead_letters_dispatcher_name_source_event_id_emit_ind_key CREATE UNIQUE INDEX keiro_dead_letters_dispatcher_name_source_event_id_emit_ind_key ON keiro.keiro_dead_letters USING btree (dispatcher_name, source_event_id, emit_index) +index keiro_dead_letters_pkey CREATE UNIQUE INDEX keiro_dead_letters_pkey ON keiro.keiro_dead_letters USING btree (dead_letter_id) +index keiro_inbox_backlog_idx CREATE INDEX keiro_inbox_backlog_idx ON keiro.keiro_inbox USING btree (status) WHERE (status = ANY (ARRAY['processing'::text, 'failed'::text])) +index keiro_inbox_completed_idx CREATE INDEX keiro_inbox_completed_idx ON keiro.keiro_inbox USING btree (completed_at) WHERE (status = 'completed'::text) +index keiro_inbox_pkey CREATE UNIQUE INDEX keiro_inbox_pkey ON keiro.keiro_inbox USING btree (source, dedupe_key) +index keiro_outbox_claim_order_idx CREATE INDEX keiro_outbox_claim_order_idx ON keiro.keiro_outbox USING btree (created_at, outbox_id) WHERE (status = ANY (ARRAY['pending'::text, 'failed'::text])) +index keiro_outbox_head_of_line_idx CREATE INDEX keiro_outbox_head_of_line_idx ON keiro.keiro_outbox USING btree (source, message_key, created_at) WHERE ((status <> ALL (ARRAY['sent'::text, 'dead'::text])) AND (message_key IS NOT NULL)) +index keiro_outbox_pending_idx CREATE INDEX keiro_outbox_pending_idx ON keiro.keiro_outbox USING btree (status, next_attempt_at, created_at) +index keiro_outbox_pkey CREATE UNIQUE INDEX keiro_outbox_pkey ON keiro.keiro_outbox USING btree (outbox_id) +index keiro_outbox_sent_gc_idx CREATE INDEX keiro_outbox_sent_gc_idx ON keiro.keiro_outbox USING btree (published_at) WHERE (status = 'sent'::text) +index keiro_outbox_source_message_id_key CREATE UNIQUE INDEX keiro_outbox_source_message_id_key ON keiro.keiro_outbox USING btree (source, message_id) +index keiro_outbox_source_order_idx CREATE INDEX keiro_outbox_source_order_idx ON keiro.keiro_outbox USING btree (source, created_at, outbox_id) WHERE (status <> ALL (ARRAY['sent'::text, 'dead'::text])) +index keiro_projection_dedup_applied_at_idx CREATE INDEX keiro_projection_dedup_applied_at_idx ON keiro.keiro_projection_dedup USING btree (applied_at) +index keiro_projection_dedup_pkey CREATE UNIQUE INDEX keiro_projection_dedup_pkey ON keiro.keiro_projection_dedup USING btree (projection_name, event_id) +index keiro_read_models_pkey CREATE UNIQUE INDEX keiro_read_models_pkey ON keiro.keiro_read_models USING btree (name) +index keiro_snapshots_compat_idx CREATE INDEX keiro_snapshots_compat_idx ON keiro.keiro_snapshots USING btree (stream_id, state_codec_version, regfile_shape_hash, stream_version DESC) +index keiro_snapshots_pkey CREATE UNIQUE INDEX keiro_snapshots_pkey ON keiro.keiro_snapshots USING btree (stream_id) +index keiro_subscription_shards_lease_idx CREATE INDEX keiro_subscription_shards_lease_idx ON keiro.keiro_subscription_shards USING btree (subscription_name, lease_expires_at) +index keiro_subscription_shards_owner_idx CREATE INDEX keiro_subscription_shards_owner_idx ON keiro.keiro_subscription_shards USING btree (subscription_name, owner_worker_id) +index keiro_subscription_shards_pkey CREATE UNIQUE INDEX keiro_subscription_shards_pkey ON keiro.keiro_subscription_shards USING btree (subscription_name, bucket) +index keiro_timers_due_idx CREATE INDEX keiro_timers_due_idx ON keiro.keiro_timers USING btree (status, fire_at, process_manager_name) WHERE (status = ANY (ARRAY['scheduled'::text, 'firing'::text])) +index keiro_timers_pkey CREATE UNIQUE INDEX keiro_timers_pkey ON keiro.keiro_timers USING btree (timer_id) +index keiro_workflow_children_parent_idx CREATE INDEX keiro_workflow_children_parent_idx ON keiro.keiro_workflow_children USING btree (parent_id, parent_name) +index keiro_workflow_children_pkey CREATE UNIQUE INDEX keiro_workflow_children_pkey ON keiro.keiro_workflow_children USING btree (child_id, child_name) +index keiro_workflow_children_running_idx CREATE INDEX keiro_workflow_children_running_idx ON keiro.keiro_workflow_children USING btree (status) WHERE (status = 'running'::text) +index keiro_workflow_steps_pkey CREATE UNIQUE INDEX keiro_workflow_steps_pkey ON keiro.keiro_workflow_steps USING btree (workflow_id, workflow_name, generation, step_name) +index keiro_workflow_steps_workflow_idx CREATE INDEX keiro_workflow_steps_workflow_idx ON keiro.keiro_workflow_steps USING btree (workflow_id, workflow_name, generation) +index keiro_workflows_active_idx CREATE INDEX keiro_workflows_active_idx ON keiro.keiro_workflows USING btree (status) WHERE (status = ANY (ARRAY['running'::text, 'suspended'::text])) +index keiro_workflows_gc_idx CREATE INDEX keiro_workflows_gc_idx ON keiro.keiro_workflows USING btree (status, completed_at) +index keiro_workflows_pkey CREATE UNIQUE INDEX keiro_workflows_pkey ON keiro.keiro_workflows USING btree (workflow_id, workflow_name) +table keiro_awakeables kind=r +table keiro_dead_letters kind=r +table keiro_inbox kind=r +table keiro_outbox kind=r +table keiro_projection_dedup kind=r +table keiro_read_models kind=r +table keiro_snapshots kind=r +table keiro_subscription_shards kind=r +table keiro_timers kind=r +table keiro_workflow_children kind=r +table keiro_workflow_steps kind=r +table keiro_workflows kind=r 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.3.0.0 +version: 0.4.0.1 synopsis: Schema migrations for keiro description: Embedded PostgreSQL schema migrations and a migration runner for the Keiro @@ -18,6 +18,7 @@ README.md extra-source-files: + expected-schema/native/keiro-v18.txt expected-schema/v18/db-settings expected-schema/v18/roles/keiro expected-schema/v18/schemas/keiro/objrep @@ -289,6 +290,7 @@ migrations/*.sql migrations/manifest migrations.lock + migrations.native.lock sql-migrations/*.sql source-repository head @@ -317,6 +319,7 @@ exposed-modules: Keiro.Migrations Keiro.Migrations.History.Codd + Keiro.Migrations.SchemaCheck other-modules: Keiro.Migrations.Internal.Definition @@ -327,6 +330,7 @@ , base >=4.18 && <5 , bytestring >=0.11 && <0.13 , containers >=0.6 && <0.8 + , hasql >=1.10 && <1.11 , kiroku-store-migrations ^>=0.3.0.0 , pg-migrate ^>=1.1.0.0 , pg-migrate-embed ^>=1.1.0.0 @@ -343,7 +347,7 @@ build-depends: , codd >=0.1.8 && <0.2 , codd-extras >=0.1 && <0.2 - , directory >=1.3 + , directory >=1.3 && <1.4 , file-embed >=0.0.15 && <0.0.17 , filepath >=1.4 && <1.6 , time >=1.12 && <1.15 @@ -363,6 +367,7 @@ , optparse-applicative >=0.17 && <0.20 , pg-migrate ^>=1.1.0.0 , pg-migrate-cli ^>=1.1.0.0 + , pg-migrate-import-codd ^>=1.1.0.0 , text >=2.0 && <2.2 executable keiro-write-expected-schema @@ -384,6 +389,7 @@ import: common type: exitcode-stdio-1.0 main-is: Main.hs + other-modules: Lint hs-source-dirs: test ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: @@ -391,7 +397,7 @@ , base >=4.18 && <5 , bytestring >=0.11 && <0.13 , containers >=0.6 && <0.8 - , directory >=1.3 + , directory >=1.3 && <1.4 , ephemeral-pg >=0.2 && <0.3 , filepath >=1.4 && <1.6 , hasql >=1.10 && <1.11 @@ -425,15 +431,15 @@ , directory , ephemeral-pg >=0.2 , filepath - , generic-lens >=2.2 - , hasql >=1.10 - , hasql-pool >=1.2 + , generic-lens >=2.2 && <2.4 + , hasql >=1.10 && <1.11 + , hasql-pool >=1.2 && <1.5 , hspec >=2.10 , keiro-migrations , kiroku-store >=0.3 && <0.4 , kiroku-store-migrations ^>=0.3.0.0 - , lens >=5.2 + , lens >=5.2 && <5.4 , temporary - , text >=2.0 - , time >=1.12 - , vector >=0.13 + , text >=2.0 && <2.2 + , time >=1.12 && <1.15 + , vector >=0.13 && <0.14 diff --git a/migrations.native.lock b/migrations.native.lock new file mode 100644 --- /dev/null +++ b/migrations.native.lock @@ -0,0 +1,20 @@ +1d15faa7cfb474455c3a1193b454ce493d49589b0f9f62b0b8beff65a00f6403 0001-keiro-bootstrap.sql +4c9c645e7ac9ebc9228638a89580613bd0058444e20047486d4bd7696b9ddb0a 0002-keiro-outbox.sql +71aabbfd93e66b324691ca856ca73245d62d84d984ca162e1388726127daa5e5 0003-keiro-inbox.sql +42f1bbd4fb23b27b2be434f25b559b2e17870f1d8c6efbcf2ae6a702c6136f98 0004-keiro-timer-recovery.sql +e967d41342cddc8cfe8381e5f562603dbc9a10e61232458e24c5cb291cfe9047 0005-keiro-workflow-steps.sql +3b20ba3981ae718cfbb9ed68318131a50ca5ad715b459868b79ac1f4c138fc5c 0006-keiro-awakeables.sql +975c0e6480fa01f2af1e2c45a4396e2588af4560c9803b55e8b574ea2e69b5b2 0007-keiro-workflow-children.sql +f05e8254de4c328f9319db4db8b9a78d6fba552c245acf0e24c6c450d8d71559 0008-keiro-workflow-generation.sql +1a93b4fdad24624b168a0aeeb12c659c59764660cc11fa564e77aa4b32a54fca 0009-keiro-subscription-shards.sql +49a963745a637c8e0248b5b958a719ccc772dbd02ca77cf706fee5de8d8d1a85 0010-keiro-messaging-crash-recovery.sql +7c329c9f439d2bab927debf5dc8b96acb438b4e240ef16292723398ddf005fea 0011-keiro-workflows-instances.sql +77c394334c64ff0631eb1c831f60629123ae255f1be7fb1716748b6ff9d0b701 0012-keiro-workflow-gc-index.sql +a2ea08ce3debec078e89490403241d9fd4e5d4ff3ea64b2c01ab236fb2dda313 0013-keiro-workflows-wake-after.sql +ed5bef75d195df0335b86d36256fd4f1dab30cb1eab4e05f0a321bf8d989503a 0014-keiro-projection-dedup.sql +fd65320576b06e8d30a8308ac790be463c09906e74d81a6fd535e7745ef943c5 0015-keiro-outbox-claim-order-index.sql +50b169c9bc98e7ab6845c74b105d13990af3cdb2e587445fd869e942c28df81d 0016-keiro-inbox-drop-received-idx.sql +e2690e1e2517d28e596330d3bdfcc07f6a8d7e1b6e87b94f726630d221663900 0017-schema-management-comment.sql +be7e510421f983ac2e446ae655d000b810b19cf2667f328dd7caf41a2101d0b6 0018.sql +7a0d0280d8d54f811c33b4bec525d78fe8f172de92b62e4745dcdd217c656209 0019-keiro-snapshots-state-shape-hash.sql +c125e8c32a0848854d94bce1245f349cf7f479326a1bf540e9dba9e222b75a4f 0020-keiro-workflow-children-failure-reason.sql diff --git a/migrations/0019-keiro-snapshots-state-shape-hash.sql b/migrations/0019-keiro-snapshots-state-shape-hash.sql new file mode 100644 --- /dev/null +++ b/migrations/0019-keiro-snapshots-state-shape-hash.sql @@ -0,0 +1,9 @@ +-- keiro snapshots: fold-sensitive discriminator component (state shape hash). +-- +-- Adds the third snapshot-compatibility column. Existing rows get the empty +-- string, which never equals a real hash, so every pre-existing snapshot is +-- treated as incompatible once: the next hydration falls back to full replay +-- and re-persists a seed carrying the real hash. Snapshots are advisory, so +-- this is a one-time replay cost, not a correctness event. +ALTER TABLE keiro.keiro_snapshots + ADD COLUMN IF NOT EXISTS state_shape_hash TEXT NOT NULL DEFAULT ''; diff --git a/migrations/0020-keiro-workflow-children-failure-reason.sql b/migrations/0020-keiro-workflow-children-failure-reason.sql new file mode 100644 --- /dev/null +++ b/migrations/0020-keiro-workflow-children-failure-reason.sql @@ -0,0 +1,4 @@ +-- Preserve terminal child-workflow failures independently of a parent +-- generation's journal so awaitChild can deliver them after continue-as-new. +ALTER TABLE keiro.keiro_workflow_children + ADD COLUMN IF NOT EXISTS failure_reason TEXT NULL; diff --git a/migrations/manifest b/migrations/manifest --- a/migrations/manifest +++ b/migrations/manifest @@ -16,3 +16,5 @@ 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 diff --git a/src/Keiro/Migrations.hs b/src/Keiro/Migrations.hs --- a/src/Keiro/Migrations.hs +++ b/src/Keiro/Migrations.hs @@ -1,21 +1,187 @@ module Keiro.Migrations ( + CoddLedgerPreflight (..), + ConnectionProvider, DefinitionError, MigrationComponent, + MigrationError, + MigrationId, MigrationPlan, PlanError, + RunOptions, + StartupHandshake (..), + VerificationIssue (..), + connectionProviderFromSettings, + defaultRunOptions, + embeddedMigrationEntries, frameworkMigrationPlan, + handshakePassed, keiroMigrations, + missingMigrations, + preflightFreshLedgerOverCodd, + renderCoddPreflight, ) where +import Control.Exception (finally) +import Data.Int (Int64) import Data.List.NonEmpty (NonEmpty (..)) +import Data.Text (Text) import Database.PostgreSQL.Migrate ( + ConnectionProvider, DefinitionError, MigrationComponent, + MigrationError (..), + MigrationId, MigrationPlan, PlanError, + RunOptions, + VerificationIssue (..), + connectionProviderFromSettings, + defaultRunOptions, migrationPlan, + migrationStatusWith, ) -import Keiro.Migrations.Internal.Definition (keiroMigrations) +import Database.PostgreSQL.Migrate qualified as Migrate +import Hasql.Connection qualified as Connection +import Hasql.Connection.Settings qualified as Settings +import Hasql.Decoders qualified as Decoders +import Hasql.Encoders qualified as Encoders +import Hasql.Session (Session) +import Hasql.Session qualified as Session +import Hasql.Statement (Statement) +import Hasql.Statement qualified as Statement +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) + +-- | Refuse to initialize a fresh native ledger over a retired codd ledger. +preflightFreshLedgerOverCodd :: + 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 + +-- | 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." + 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 + +detectedCoddLedger :: Bool -> Bool -> Maybe Text +detectedCoddLedger currentCoddExists legacyCoddExists + | 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 + ) + ) + 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))) + +-- | 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) + +-- | Whether the database is safe for this binary to serve requests. +handshakePassed :: StartupHandshake -> Bool +handshakePassed 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) +missingMigrations 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. 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 @@ -1,4 +1,13 @@ {-# LANGUAGE TemplateHaskell #-} +-- GHC 9.12 has no Template Haskell directory-dependency API, so a sibling SQL +-- file that is added or removed without being listed in the manifest leaves this +-- module looking up to date and silently skips manifest membership validation. +-- The plugin forces GHC to reconsider this module on every build it runs. +-- Note this cannot help when no Haskell source changes at all: cabal then +-- reports "Up to date" and never invokes GHC. A clean build revalidates, and +-- the migrations.native.lock suite test checks directory membership at test +-- runtime regardless. +{-# OPTIONS_GHC -fplugin=Database.PostgreSQL.Migrate.Embed.RecompilePlugin #-} module Keiro.Migrations.Internal.Definition ( embeddedMigrationEntries, diff --git a/src/Keiro/Migrations/SchemaCheck.hs b/src/Keiro/Migrations/SchemaCheck.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Migrations/SchemaCheck.hs @@ -0,0 +1,225 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Keiro.Migrations.SchemaCheck ( + SchemaDrift (..), + compareSchemaSnapshot, + expectedSchemaSnapshot, + renderSchemaDrift, + snapshotSchema, + verifyExpectedSchema, +) where + +import Control.Exception (finally) +import Data.Int (Int32) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (mapMaybe) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as Text +import Database.PostgreSQL.Migrate (MigrationError (..)) +import Hasql.Connection qualified as Connection +import Hasql.Connection.Settings qualified as Settings +import Hasql.Decoders qualified as Decoders +import Hasql.Encoders qualified as Encoders +import Hasql.Session (Session) +import Hasql.Session qualified as Session +import Hasql.Statement (Statement) +import Hasql.Statement qualified as Statement +import Keiro.Migrations.Internal.EmbedFile (embedTextFile) + +-- | 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) + +-- | Compare canonical snapshots by their @kindname@ object identity. +compareSchemaSnapshot :: Text -> Text -> [SchemaDrift] +compareSchemaSnapshot expected actual = + mapMaybe driftFor allKeys + where + expectedObjects = snapshotObjects expected + actualObjects = snapshotObjects actual + allKeys = + 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 + +-- | 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 + <> ")" + +-- | Read a sorted canonical snapshot of tables, columns, constraints, and indexes. +snapshotSchema :: Text -> Session Text +snapshotSchema schema = + 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") + +-- | Compare the live @keiro@ schema with the embedded PostgreSQL 18 snapshot. +verifyExpectedSchema :: + 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) + 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)) + +snapshotObjects :: Text -> Map Text (Text, Text) +snapshotObjects = + 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 + +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) + +splitSnapshotKey :: Text -> (Text, Text) +splitSnapshotKey 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))) + +serverVersionStatement :: Statement () Int32 +serverVersionStatement = + Statement.preparable + "SELECT current_setting('server_version_num')::integer" + Encoders.noParams + (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.int4))) diff --git a/test/Lint.hs b/test/Lint.hs new file mode 100644 --- /dev/null +++ b/test/Lint.hs @@ -0,0 +1,117 @@ +module Lint ( + LintConfig (..), + lintViolations, +) where + +import Data.ByteString (ByteString) +import Data.List (sortOn) +import Data.Text (Text) +import Data.Text qualified as Text +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. +-} +data LintConfig = LintConfig + { 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) + where + lintOne (file, bytes) + | 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 + + requiredLower = Text.toCaseFold (requiredQualifier config) + + searchPathViolation file 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) + ] + +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 + where + trimmed = Text.strip statement + lower = Text.toCaseFold trimmed + wordsOriginal = Text.words trimmed + +startsWithWords :: Text -> [Text] -> Bool +startsWithWords statement wordsExpected = + wordsExpected == take (length wordsExpected) (Text.words statement) + +targetAfter :: [Text] -> [Text] -> Maybe Text +targetAfter prefix wordsOriginal = + skipIfNotExists (drop (length prefix) wordsOriginal) + +targetAfterToken :: Text -> [Text] -> Maybe Text +targetAfterToken token 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 +skipIfNotExists (first : second : 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 + +cleanTarget :: Text -> Text +cleanTarget = + Text.dropAround (`elem` ("\"(),;" :: String)) + +oneLine :: Text -> Text +oneLine = + Text.unwords . Text.words diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -4,13 +4,13 @@ import Control.Concurrent.Async (concurrently) import Control.Exception (finally) -import Control.Monad (forM_) +import Control.Monad (forM_, unless) import Data.ByteString (ByteString) import Data.ByteString qualified as ByteString import Data.Either (isLeft) import Data.Foldable (toList) import Data.Int (Int64) -import Data.List (sort) +import Data.List (findIndex, sort, (\\)) import Data.List.NonEmpty (NonEmpty (..)) import Data.Map.Strict qualified as Map import Data.Set qualified as Set @@ -27,6 +27,7 @@ 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 @@ -37,18 +38,22 @@ 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) -import System.FilePath (()) +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 eighteen native files in manifest order" $ 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 @@ -61,7 +66,7 @@ bytes <- ByteString.readFile (directory nativeName) lookup legacyName lockEntries `shouldBe` Just (checksumText bytes) - it "builds component keiro with dependency kiroku and eighteen migrations" $ do + it "builds component keiro with dependency kiroku and twenty migrations" $ do plan <- requirePlan let PlanDescription components = planDescription plan case toList components of @@ -74,7 +79,7 @@ componentNameText keiroName `shouldBe` "keiro" dependencyName <- requireRight (componentName "kiroku") keiroDependencies `shouldBe` Set.singleton dependencyName - length keiroEntries `shouldBe` 18 + length keiroEntries `shouldBe` 20 actual -> expectationFailure ("unexpected plan description: " <> show actual) validateHistoryMappingTargets plan frameworkCoddHistoryMappings `shouldBe` Right () @@ -84,6 +89,175 @@ 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 @@ -91,12 +265,12 @@ assertSchema connection let provider = providerFor connection rerun <- runMigrationPlanWith defaultRunOptions provider plan >>= requireRight - reportOutcomes rerun `shouldBe` replicate 26 AlreadyApplied + 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` 26 + length applied `shouldBe` 28 pending `shouldBe` [] unknown `shouldBe` [] either (expectationFailure . show) pure result @@ -110,8 +284,44 @@ (runMigrationPlan defaultRunOptions settings plan >>= requireRight) (runMigrationPlan defaultRunOptions settings plan >>= requireRight) sort [reportOutcomes first, reportOutcomes second] - `shouldBe` sort [replicate 26 AppliedNow, replicate 26 AlreadyApplied] + `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" @@ -156,6 +366,85 @@ 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 @@ -172,28 +461,22 @@ importCoddHistory defaultImportOptions config provider plan frameworkCoddHistoryMappings >>= requireRight importOutcomes first `shouldBe` replicate 23 Imported - kirokuCanaryId <- requireRight (migrationId "kiroku" "0008-schema-management-comment") - keiroCanaryId <- requireRight (migrationId "keiro" "0017-schema-management-comment") - keiroDeadLettersId <- requireRight (migrationId "keiro" "0018") + expectedPending <- postCoddImportPendingIssues verifiedBeforeCanaries <- verifyMigrationPlan defaultRunOptions settings plan >>= requireRight case verifiedBeforeCanaries of VerificationReport verificationIssues _ _ _ -> - verificationIssues - `shouldBe` [ PendingMigration kirokuCanaryId - , PendingMigration keiroCanaryId - , PendingMigration keiroDeadLettersId - ] + verificationIssues `shouldBe` expectedPending up <- runMigrationPlan defaultRunOptions settings plan >>= requireRight reportOutcomes up `shouldBe` replicate 7 AlreadyApplied <> [AppliedNow] <> replicate 16 AlreadyApplied - <> [AppliedNow, AppliedNow] + <> [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 26 AlreadyApplied + reportOutcomes rerun `shouldBe` replicate 28 AlreadyApplied second <- importCoddHistory defaultImportOptions config provider plan frameworkCoddHistoryMappings >>= requireRight @@ -203,8 +486,32 @@ sourceRows <- useSession connection (Session.statement () (sourceRowCountStatement sourceSchema)) sourceRows `shouldBe` 23 facts <- useSession connection (Session.statement () importFactsStatement) - facts `shouldBe` (26, 23, True) + 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" @@ -225,6 +532,8 @@ , "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 @@ -235,6 +544,20 @@ 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 @@ -257,6 +580,51 @@ 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) @@ -283,6 +651,15 @@ 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 @@ -420,6 +797,26 @@ <$> 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