keiro-migrations 0.20.0.0 → 0.21.0.0
raw patch · 4 files changed
+236/−11 lines, 4 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Keiro.Migrations.SchemaCheck: compareSchemaSnapshotWithManaged :: Set Text -> Text -> Text -> [SchemaDrift]
+ Keiro.Migrations.SchemaCheck: managedObjectSnapshotKeys :: Session (Set Text)
Files
- CHANGELOG.md +13/−0
- keiro-migrations.cabal +1/−1
- src/Keiro/Migrations/SchemaCheck.hs +81/−10
- test/Main.hs +141/−0
CHANGELOG.md view
@@ -6,6 +6,19 @@ ## [Unreleased] +## 0.21.0.0 — 2026-10-14++### Bug Fixes++- `verify-schema` and `Keiro.Migrations.SchemaCheck.verifyExpectedSchema` no longer+ report a view that Keiro's runtime created and recorded in+ `keiro.keiro_managed_read_objects`, such as the+ `keiro.external_read_<function>_binding` view behind an all-rows external-read+ contract, as unexpected drift. Only rows with `managed_by = 'keiro'` count; a role+ without table `SELECT` or schema `USAGE` keeps the previous behaviour. New exports+ `managedObjectSnapshotKeys` and `compareSchemaSnapshotWithManaged`;+ `compareSchemaSnapshot` is unchanged.+ ## 0.20.0.0 — 2026-10-12 ### Breaking Changes
keiro-migrations.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: keiro-migrations-version: 0.20.0.0+version: 0.21.0.0 synopsis: Schema migrations for keiro description: Embedded PostgreSQL schema migrations and a migration runner for the Keiro
src/Keiro/Migrations/SchemaCheck.hs view
@@ -3,6 +3,8 @@ module Keiro.Migrations.SchemaCheck ( SchemaDrift (..), compareSchemaSnapshot,+ compareSchemaSnapshotWithManaged,+ managedObjectSnapshotKeys, expectedSchemaSnapshot, renderSchemaDrift, snapshotSchema,@@ -15,6 +17,7 @@ import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Maybe (mapMaybe)+import Data.Set (Set) import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as Text@@ -40,9 +43,12 @@ } deriving stock (Eq, Show) --- | Compare canonical snapshots by their @kind<TAB>name@ object identity.-compareSchemaSnapshot :: Text -> Text -> [SchemaDrift]-compareSchemaSnapshot expected actual =+-- | Compare canonical snapshots by their @kind<TAB>name@ object identity. A live+-- object whose key is in the managed set is Keiro's own runtime object and is+-- never reported as unexpected; it is still compared when the expected snapshot+-- also lists it.+compareSchemaSnapshotWithManaged :: Set Text -> Text -> Text -> [SchemaDrift]+compareSchemaSnapshotWithManaged managed expected actual = mapMaybe driftFor allKeys where expectedObjects = snapshotObjects expected@@ -55,8 +61,9 @@ case (Map.lookup key expectedObjects, Map.lookup key actualObjects) of (Just (expectedLine, _), Nothing) -> Just (MissingObject expectedLine)- (Nothing, Just (actualLine, _)) ->- Just (UnexpectedObject actualLine)+ (Nothing, Just (actualLine, _))+ | Set.member key managed -> Nothing+ | otherwise -> Just (UnexpectedObject actualLine) (Just (_, expectedValue), Just (_, actualValue)) | expectedValue /= actualValue -> Just@@ -67,6 +74,10 @@ } _ -> Nothing +-- | Compare snapshots without allowing any runtime-managed additions.+compareSchemaSnapshot :: Text -> Text -> [SchemaDrift]+compareSchemaSnapshot = compareSchemaSnapshotWithManaged Set.empty+ -- | Render a drift as one operator-facing line with the affected object name. renderSchemaDrift :: SchemaDrift -> Text renderSchemaDrift drift =@@ -113,7 +124,11 @@ $(embedTextFile "expected-schema/native/keiro-v18.txt") -- | Compare the live @keiro@ and @keiro_read@ schemas with the embedded--- PostgreSQL 18 snapshot.+-- PostgreSQL 18 snapshot. Runtime binding views recorded as Keiro-managed are+-- allowed additions when the role has registry table SELECT and schema USAGE;+-- otherwise verification keeps its catalog-only comparison. Missing or changed+-- migration objects remain drift. Registry identity does not validate a+-- runtime-only view's definition or definition_hash. verifyExpectedSchema :: Settings.Settings -> IO (Either MigrationError [SchemaDrift])@@ -129,10 +144,10 @@ pure $ case result of Left sessionError -> Left (DatabaseSessionFailed sessionError) Right (Left migrationError) -> Left migrationError- Right (Right actual) ->- Right (compareSchemaSnapshot expectedSchemaSnapshot actual)+ Right (Right (managed, actual)) ->+ Right (compareSchemaSnapshotWithManaged managed expectedSchemaSnapshot actual) where- liveSnapshotSession :: Session (Either MigrationError Text)+ liveSnapshotSession :: Session (Either MigrationError (Set Text, Text)) liveSnapshotSession = do serverVersionNumber <- Session.statement () serverVersionStatement let majorVersion = fromIntegral serverVersionNumber `div` 10000@@ -140,8 +155,64 @@ then do privateSchema <- snapshotSchema "keiro" publicSchema <- snapshotSchema "keiro_read"- pure (Right (privateSchema <> publicSchema))+ managed <- managedObjectSnapshotKeys+ pure (Right (managed, privateSchema <> publicSchema)) else pure (Left (UnsupportedPostgresVersion majorVersion))++-- | Snapshot keys of the objects Keiro's runtime created and recorded in+-- @keiro.keiro_managed_read_objects@ with @managed_by = 'keiro'@. Every state+-- counts: retirement marks a managed object retired without dropping it. Rows+-- whose kind has no snapshot line (functions and types) map to nothing. When+-- the registry table does not exist, or the connected role lacks table @SELECT@+-- or schema @USAGE@, the set is empty and verification reports every live object+-- as before.+managedObjectSnapshotKeys :: Session (Set Text)+managedObjectSnapshotKeys = do+ readable <- Session.statement () registryReadableStatement+ if readable+ then Set.fromList . mapMaybe snapshotKey <$> Session.statement () managedObjectsStatement+ else pure Set.empty+ where+ snapshotKey (schema, name, kind)+ | kind == "binding-view" = Just ("view\t" <> schema <> "." <> name)+ | otherwise = Nothing++-- | True only when @keiro.keiro_managed_read_objects@ is a table the connected+-- role may read. Resolving the relation through @pg_class@ avoids the error+-- that the text form of @has_table_privilege@ raises for a missing relation.+registryReadableStatement :: Statement () Bool+registryReadableStatement =+ Statement.preparable+ """+ SELECT coalesce(+ ( SELECT pg_catalog.has_table_privilege(c.oid, 'SELECT')+ AND pg_catalog.has_schema_privilege(n.oid, 'USAGE')+ FROM pg_catalog.pg_class c+ JOIN pg_catalog.pg_namespace n ON n.oid = c.relnamespace+ WHERE n.nspname = 'keiro'+ AND c.relname = 'keiro_managed_read_objects'+ AND c.relkind = 'r' ),+ false)+ """+ Encoders.noParams+ (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.bool)))++managedObjectsStatement :: Statement () [(Text, Text, Text)]+managedObjectsStatement =+ Statement.preparable+ """+ SELECT object_schema, object_name, object_kind+ FROM keiro.keiro_managed_read_objects+ WHERE managed_by = 'keiro'+ """+ Encoders.noParams+ ( Decoders.rowList+ ( (,,)+ <$> Decoders.column (Decoders.nonNullable Decoders.text)+ <*> Decoders.column (Decoders.nonNullable Decoders.text)+ <*> Decoders.column (Decoders.nonNullable Decoders.text)+ )+ ) snapshotObjects :: Text -> Map Text (Text, Text) snapshotObjects =
test/Main.hs view
@@ -288,6 +288,134 @@ `shouldSatisfy` any (Text.isInfixOf "keiro_read.projection_group_status_v1") + it "treats a managed live object as expected and still reports its unregistered neighbours" $ do+ let expected = Text.unlines ["table\twidgets\tkind=r"]+ actual =+ Text.unlines+ [ "table\twidgets\tkind=r",+ "view\tkeiro.external_read_demo_v1_binding\tcolumns=1:id bigint",+ "view\tkeiro.external_read_rogue_v1_binding\tcolumns=1:id bigint"+ ]+ managed = Set.singleton "view\tkeiro.external_read_demo_v1_binding"+ migrationView = "view\tkeiro_read.status_v1\tcolumns=1:id bigint"+ changedView = "view\tkeiro_read.status_v1\tcolumns=1:id text"+ migrationManaged = Set.singleton "view\tkeiro_read.status_v1"+ compareSchemaSnapshotWithManaged managed expected actual+ `shouldBe` [UnexpectedObject "view\tkeiro.external_read_rogue_v1_binding\tcolumns=1:id bigint"]+ compareSchemaSnapshot expected actual `shouldSatisfy` ((== 2) . length)+ compareSchemaSnapshotWithManaged migrationManaged migrationView changedView+ `shouldBe` [ChangedObject "view\tkeiro_read.status_v1" "columns=1:id bigint" "columns=1:id text"]+ compareSchemaSnapshotWithManaged migrationManaged migrationView ""+ `shouldBe` [MissingObject migrationView]+ forM_ [(expected, actual), (migrationView, changedView), (migrationView, "")] $ \(expectedSnapshot, actualSnapshot) ->+ compareSchemaSnapshotWithManaged Set.empty expectedSnapshot actualSnapshot+ `shouldBe` compareSchemaSnapshot expectedSnapshot actualSnapshot++ it "ignores registered binding views and still reports unregistered and consumer-managed views" $ do+ plan <- requirePlan+ withKeiroPg $ \database -> do+ let settings = Pg.connectionSettings database+ neighbours =+ [ "schema drift: unexpected view keiro.external_read_foreign_v1_binding (actual: columns=1:id bigint)",+ "schema drift: unexpected view keiro.external_read_rogue_v1_binding (actual: columns=1:id bigint)"+ ]+ check = do+ drifts <- verifyExpectedSchema settings >>= requireRight+ map renderSchemaDrift drifts `shouldBe` neighbours+ _ <- runMigrationPlan defaultRunOptions settings plan >>= requireRight+ verifyExpectedSchema settings >>= requireRight >>= (`shouldBe` [])+ withConnection settings $ \connection -> do+ useSession connection (Session.script managedBindingFixtureSql)+ useSession connection $+ Session.script+ """+ CREATE VIEW keiro.external_read_rogue_v1_binding AS SELECT 1::bigint AS id;+ CREATE VIEW keiro.external_read_foreign_v1_binding AS SELECT 1::bigint AS id;+ INSERT INTO keiro.keiro_managed_read_objects+ (object_schema, object_name, object_kind, object_signature,+ managed_by, definition_hash, surface_generation, state)+ VALUES ('keiro', 'external_read_foreign_v1_binding', 'binding-view', '',+ 'consumer', 'test-definition', 1, 'active');+ """+ check+ useSession connection $+ Session.script+ "UPDATE keiro.keiro_managed_read_objects SET state = 'pending-retirement', updated_at = now() WHERE object_name = 'external_read_demo_v1_binding'"+ check+ useSession connection $+ Session.script+ "UPDATE keiro.keiro_managed_read_objects SET state = 'retired', retired_at = now(), updated_at = now() WHERE object_name = 'external_read_demo_v1_binding'"+ check++ it "returns no managed keys for a role that cannot read the registry" $ do+ plan <- requirePlan+ withKeiroPg $ \database -> do+ let settings = Pg.connectionSettings database+ demoKeys = Set.singleton "view\tkeiro.external_read_demo_v1_binding"+ demoDrift = [UnexpectedObject "view\tkeiro.external_read_demo_v1_binding\tcolumns=1:id bigint,2:total bigint"]+ checkRole expectedKeys expectedDrifts =+ withConnection settings $ \connection -> do+ (keys, drifts) <-+ useSession+ connection+ ( do+ Session.script "SET ROLE keiro_verify_probe"+ managed <- managedObjectSnapshotKeys+ actual <- (<>) <$> snapshotSchema "keiro" <*> snapshotSchema "keiro_read"+ pure (managed, compareSchemaSnapshotWithManaged managed expectedSchemaSnapshot actual)+ )+ `finally` useSession connection (Session.script "RESET ROLE")+ keys `shouldBe` expectedKeys+ drifts `shouldBe` expectedDrifts+ _ <- runMigrationPlan defaultRunOptions settings plan >>= requireRight+ withConnection settings $ \connection -> do+ useSession connection (Session.script managedBindingFixtureSql)+ useSession connection $+ Session.script+ """+ DO $probe$+ BEGIN+ IF NOT EXISTS (SELECT 1 FROM pg_catalog.pg_roles WHERE rolname = 'keiro_verify_probe') THEN+ CREATE ROLE keiro_verify_probe NOLOGIN;+ END IF;+ END+ $probe$;+ GRANT keiro_verify_probe TO CURRENT_USER;+ GRANT USAGE ON SCHEMA keiro TO keiro_verify_probe;+ """+ useSession connection managedObjectSnapshotKeys `shouldReturn` demoKeys+ checkRole Set.empty demoDrift+ useSession connection $+ Session.script+ """+ REVOKE USAGE ON SCHEMA keiro FROM keiro_verify_probe;+ GRANT SELECT ON keiro.keiro_managed_read_objects TO keiro_verify_probe;+ """+ checkRole Set.empty demoDrift+ useSession connection (Session.script "GRANT USAGE ON SCHEMA keiro TO keiro_verify_probe")+ checkRole demoKeys []++ it "falls back to ordinary drift when the registry is absent" $ do+ plan <- requirePlan+ withKeiroPg $ \database -> do+ let settings = Pg.connectionSettings database+ missingRegistry = MissingObject "table\tkeiro_managed_read_objects\tkind=r"+ unexpectedBinding = UnexpectedObject "view\tkeiro.external_read_demo_v1_binding\tcolumns=1:id bigint,2:total bigint"+ withConnection settings $ \connection ->+ useSession connection managedObjectSnapshotKeys `shouldReturn` Set.empty+ emptyDrifts <- verifyExpectedSchema settings >>= requireRight+ emptyDrifts `shouldSatisfy` elem missingRegistry+ _ <- runMigrationPlan defaultRunOptions settings plan >>= requireRight+ actual <- withConnection settings $ \connection -> do+ useSession connection (Session.script managedBindingFixtureSql)+ useSession connection (Session.script "DROP TABLE keiro.keiro_managed_read_objects")+ useSession connection managedObjectSnapshotKeys `shouldReturn` Set.empty+ useSession connection ((<>) <$> snapshotSchema "keiro" <*> snapshotSchema "keiro_read")+ drifts <- verifyExpectedSchema settings >>= requireRight+ drifts `shouldBe` compareSchemaSnapshot expectedSchemaSnapshot actual+ drifts `shouldSatisfy` elem missingRegistry+ drifts `shouldSatisfy` elem unexpectedBinding+ describe "fresh native databases" $ do it "applies Kiroku then Keiro, verifies strictly, and is repeatable" $ do plan <- requirePlan@@ -1531,3 +1659,16 @@ ) where column = Decoders.column . Decoders.nonNullable++managedBindingFixtureSql :: Text+managedBindingFixtureSql =+ """+ CREATE VIEW keiro.external_read_demo_v1_binding+ WITH (security_barrier = true, security_invoker = false)+ AS SELECT 1::bigint AS id, 10::bigint AS total;+ INSERT INTO keiro.keiro_managed_read_objects+ (object_schema, object_name, object_kind, object_signature,+ managed_by, definition_hash, surface_generation, state)+ VALUES ('keiro', 'external_read_demo_v1_binding', 'binding-view', '',+ 'keiro', 'test-definition', 1, 'active');+ """