sydtest-sqitch-postgres-persistent (empty) → 0.1.0.0

raw patch · 28 files changed

+452/−0 lines, 28 filesdep +basedep +monad-loggerdep +path

Dependencies added: base, monad-logger, path, path-io, persistent, postgres-options, sydtest, sydtest-persistent, sydtest-persistent-postgresql, sydtest-sqitch-postgres, sydtest-sqitch-postgres-persistent, text

Files

• CHANGELOG.md +14/−0
• LICENSE.md +5/−0
• src/Test/Syd/Sqitch/Postgresql/Persistent.hs +119/−0
• sydtest-sqitch-postgres-persistent.cabal +88/−0
• test/Spec.hs +1/−0
• test/Test/Syd/Sqitch/Postgresql/Persistent/Example.hs +35/−0
• test/Test/Syd/Sqitch/Postgresql/PersistentSpec.hs +58/−0
• test_resources/toy-sqitch-drift/deploy/init.sql +10/−0
• test_resources/toy-sqitch-drift/revert/init.sql +6/−0
• test_resources/toy-sqitch-drift/sqitch.conf +2/−0
• test_resources/toy-sqitch-drift/sqitch.plan +5/−0
• test_resources/toy-sqitch-drift/verify/init.sql +6/−0
• test_resources/toy-sqitch-index-drift/deploy/init.sql +15/−0
• test_resources/toy-sqitch-index-drift/revert/init.sql +6/−0
• test_resources/toy-sqitch-index-drift/sqitch.conf +2/−0
• test_resources/toy-sqitch-index-drift/sqitch.plan +5/−0
• test_resources/toy-sqitch-index-drift/verify/init.sql +6/−0
• test_resources/toy-sqitch-ok/deploy/add-color.sql +7/−0
• test_resources/toy-sqitch-ok/deploy/add-color@v1.sql +6/−0
• test_resources/toy-sqitch-ok/deploy/init.sql +9/−0
• test_resources/toy-sqitch-ok/revert/add-color.sql +7/−0
• test_resources/toy-sqitch-ok/revert/add-color@v1.sql +6/−0
• test_resources/toy-sqitch-ok/revert/init.sql +6/−0
• test_resources/toy-sqitch-ok/sqitch.conf +2/−0
• test_resources/toy-sqitch-ok/sqitch.plan +8/−0
• test_resources/toy-sqitch-ok/verify/add-color.sql +6/−0
• test_resources/toy-sqitch-ok/verify/add-color@v1.sql +6/−0
• test_resources/toy-sqitch-ok/verify/init.sql +6/−0

@@ -0,0 +1,14 @@+# Changelog++## [0.1.0.0] - 2026-06-27++### Changed++- Both the persistent baseline and the sqitch deploy now run in a fresh,+  randomly-named non-`public` schema (following the change in+  `sydtest-sqitch-postgres` 0.1.0.0), so migrations that hardcode a+  schema name are caught by the schema-equality check too.++## [0.0.0.0] - 2026-05-17++First release.

@@ -0,0 +1,5 @@+# Sydtest License++Copyright (c) 2026 Tom Sydney Kerckhove++See the Sydtest License at https://github.com/NorfairKing/sydtest/blob/master/sydtest/LICENSE.md for the full license text.

@@ -0,0 +1,119 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++-- | One extra check on top of "Test.Syd.Sqitch.Postgresql": after every+-- sqitch migration has been deployed, the resulting schema must equal+-- the schema that @persistent@'s automatic migration would produce+-- against an empty database.+--+-- This catches drift between hand-written sqitch migrations and the+-- ORM model, in both directions.+module Test.Syd.Sqitch.Postgresql.Persistent+  ( sqitchPersistentPostgresqlSpec,+    runSqitchPersistentChecks,+    SqitchPersistentSettings (..),+  )+where++import Control.Monad.Logger (runNoLoggingT)+import qualified Database.Persist.Sql as DB+import qualified Database.PostgreSQL.Simple.Options as Postgres+import Test.Syd+import Test.Syd.Persistent (migrationRunner)+import Test.Syd.Persistent.Postgresql+  ( emptyPostgresOptionsSetupFunc,+    postgresqlPoolSetupFunc,+  )+import Test.Syd.Sqitch.Postgresql++-- | Configuration for 'sqitchPersistentPostgresqlSpec'.+data SqitchPersistentSettings = SqitchPersistentSettings+  { -- | Settings forwarded to 'sqitchPostgresqlSpec' for the+    -- per-change and whole-plan checks.+    sqitchPersistentSqitch :: SqitchSettings,+    -- | The @persistent@ migration generated by @mkMigrate@.+    sqitchPersistentAutoMigration :: DB.Migration,+    -- | Anything else the application applies after automatic+    -- migration (indices, extensions). Run after the persistent+    -- baseline migration /and/ after the sqitch deploy, so both+    -- snapshots include its effect. The two runs happen against+    -- different databases (see 'runSqitchPersistentChecks'), so this+    -- must not rely on cross-run state. Use @pure ()@ if there is+    -- nothing extra to do.+    sqitchPersistentExtraSetup :: forall m. (MonadIO m) => DB.SqlPersistT m ()+  }++-- | Top-level spec combinator. Declares all the checks from+-- 'Test.Syd.Sqitch.Postgresql.sqitchPostgresqlSpec' (per-change+-- round-trip + idempotence, whole-plan cycle) plus one additional+-- test comparing the schema after deploying every sqitch migration+-- with the schema after running the persistent automatic migration+-- (plus any 'sqitchPersistentExtraSetup').+--+-- Each check runs against a fresh empty database allocated and torn+-- down internally; nothing about the postgres machinery surfaces in+-- the caller's outer-type stack.+sqitchPersistentPostgresqlSpec ::+  SqitchPersistentSettings ->+  TestDef outers ()+sqitchPersistentPostgresqlSpec settings = do+  sqitchPostgresqlSpec (sqitchPersistentSqitch settings)+  describe "sqitch+persistent" $+    setupAround emptyPostgresOptionsSetupFunc $+      schemaEqualityIt settings++schemaEqualityIt ::+  SqitchPersistentSettings ->+  TestDef outers Postgres.Options+schemaEqualityIt settings =+  it "the sqitch deploy and the persistent automatic migration produce the same schema" $+    \opts ->+      runSqitchPersistentChecks settings opts++-- | Run the schema-equality check in 'IO'. Allocates two fresh+-- databases internally: one for the persistent baseline (phase 1),+-- one for the sqitch deploy (phase 2). The caller-supplied+-- 'Postgres.Options' describes the latter; the former is allocated+-- on-the-fly.+--+-- Exposed so callers can drive the check without going through the+-- 'TestDef' combinator (e.g. for negative tests under 'expectFailing').+runSqitchPersistentChecks ::+  SqitchPersistentSettings ->+  Postgres.Options ->+  IO ()+runSqitchPersistentChecks settings opts = do+  -- Phase 1: snapshot persistent's automatic migration (plus the caller's+  -- extra setup) in a fresh, random non-public schema, on a database+  -- allocated just for this. 'randomSchemaSetupFunc' creates the schema and+  -- supplies its name; phase 2 reuses that name (via 'schemaSetupFunc') so+  -- the two snapshots -- which embed the schema name -- compare equal, and so+  -- a migration that hardcodes a schema surfaces.+  (schema, schemaFromPersistent) <-+    unSetupFunc (emptyPostgresOptionsSetupFunc >>= postgresqlPoolSetupFunc) $+      \baselinePool ->+        unSetupFunc (randomSchemaSetupFunc baselinePool) $ \schema -> do+          snapshot <-+            runNoLoggingT $+              flip DB.runSqlPool baselinePool $ do+                useTestSchema schema+                migrationRunner (sqitchPersistentAutoMigration settings)+                sqitchPersistentExtraSetup settings+                querySchema+          pure (schema, snapshot)++  -- Phase 2: sqitch deploy into the same-named schema on the+  -- caller-supplied database.+  unSetupFunc (postgresqlPoolSetupFunc opts) $ \pool ->+    unSetupFunc (schemaSetupFunc schema pool) $ \() -> do+      let target = sqitchTargetFromOptions schema opts+      sqitchAt (sqitchPersistentSqitch settings) target "deploy" ["--verify"]++      schemaFromSqitch <- runNoLoggingT $+        flip DB.runSqlPool pool $ do+          useTestSchema schema+          sqitchPersistentExtraSetup settings+          querySchema++      compareSchemaSnapshots "sqitch migrations" schemaFromSqitch schemaFromPersistent

@@ -0,0 +1,88 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.38.3.+--+-- see: https://github.com/sol/hpack++name:           sydtest-sqitch-postgres-persistent+version:        0.1.0.0+synopsis:       A sqitch-on-PostgreSQL + persistent companion library for sydtest+category:       Testing+homepage:       https://github.com/NorfairKing/sydtest#readme+bug-reports:    https://github.com/NorfairKing/sydtest/issues+author:         Tom Sydney Kerckhove+maintainer:     syd@cs-syd.eu+copyright:      Copyright (c) 2026 Tom Sydney Kerckhove+license:        OtherLicense+license-file:   LICENSE.md+build-type:     Simple+extra-source-files:+    LICENSE.md+    CHANGELOG.md+    test_resources/toy-sqitch-drift/deploy/init.sql+    test_resources/toy-sqitch-drift/revert/init.sql+    test_resources/toy-sqitch-drift/sqitch.conf+    test_resources/toy-sqitch-drift/sqitch.plan+    test_resources/toy-sqitch-drift/verify/init.sql+    test_resources/toy-sqitch-index-drift/deploy/init.sql+    test_resources/toy-sqitch-index-drift/revert/init.sql+    test_resources/toy-sqitch-index-drift/sqitch.conf+    test_resources/toy-sqitch-index-drift/sqitch.plan+    test_resources/toy-sqitch-index-drift/verify/init.sql+    test_resources/toy-sqitch-ok/deploy/add-color.sql+    test_resources/toy-sqitch-ok/deploy/add-color@v1.sql+    test_resources/toy-sqitch-ok/deploy/init.sql+    test_resources/toy-sqitch-ok/revert/add-color.sql+    test_resources/toy-sqitch-ok/revert/add-color@v1.sql+    test_resources/toy-sqitch-ok/revert/init.sql+    test_resources/toy-sqitch-ok/sqitch.conf+    test_resources/toy-sqitch-ok/sqitch.plan+    test_resources/toy-sqitch-ok/verify/add-color.sql+    test_resources/toy-sqitch-ok/verify/add-color@v1.sql+    test_resources/toy-sqitch-ok/verify/init.sql++source-repository head+  type: git+  location: https://github.com/NorfairKing/sydtest++library+  exposed-modules:+      Test.Syd.Sqitch.Postgresql.Persistent+  other-modules:+      Paths_sydtest_sqitch_postgres_persistent+  hs-source-dirs:+      src+  build-depends:+      base >=4.7 && <5+    , monad-logger+    , persistent+    , postgres-options+    , sydtest+    , sydtest-persistent+    , sydtest-persistent-postgresql+    , sydtest-sqitch-postgres+  default-language: Haskell2010++test-suite sydtest-sqitch-postgres-persistent-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Test.Syd.Sqitch.Postgresql.Persistent.Example+      Test.Syd.Sqitch.Postgresql.PersistentSpec+      Paths_sydtest_sqitch_postgres_persistent+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall+  build-tool-depends:+      sydtest-discover:sydtest-discover+  build-depends:+      base >=4.7 && <5+    , path+    , path-io+    , persistent+    , sydtest+    , sydtest-persistent-postgresql+    , sydtest-sqitch-postgres+    , sydtest-sqitch-postgres-persistent+    , text+  default-language: Haskell2010

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF sydtest-discover #-}

@@ -0,0 +1,35 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++-- | A persistent model whose schema matches @test_resources/toy-sqitch-ok@.+module Test.Syd.Sqitch.Postgresql.Persistent.Example+  ( migrateWidget,+  )+where++import Data.Text (Text)+import Database.Persist.Sql+import Database.Persist.TH++share+  [mkPersist sqlSettings, mkMigrate "migrateWidget"]+  [persistLowerCase|+Widget sql=widget+    name  Text       sqltype=text+    color Text Maybe sqltype=text+    deriving Show Eq+|]

@@ -0,0 +1,58 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Test.Syd.Sqitch.Postgresql.PersistentSpec (spec) where++import Data.Text (Text)+import Path+import Path.IO+import Test.Syd+import Test.Syd.Persistent.Postgresql (emptyPostgresOptionsSetupFunc)+import Test.Syd.Sqitch.Postgresql+import Test.Syd.Sqitch.Postgresql.Persistent+import Test.Syd.Sqitch.Postgresql.Persistent.Example (migrateWidget)++locateSqitch :: IO (Path Abs File)+locateSqitch = do+  m <- findExecutable [relfile|sqitch|]+  case m of+    Nothing -> fail "sqitch not found on PATH"+    Just p -> pure p++settingsFor :: Path Rel Dir -> Maybe Text -> IO SqitchPersistentSettings+settingsFor relDir mTag = do+  projectDir <- makeAbsolute relDir+  binPath <- locateSqitch+  pure+    SqitchPersistentSettings+      { sqitchPersistentSqitch =+          SqitchSettings+            { sqitchSettingsProjectDir = projectDir,+              sqitchSettingsBin = binPath,+              sqitchSettingsGrandfatherTag = mTag+            },+        sqitchPersistentAutoMigration = migrateWidget,+        sqitchPersistentExtraSetup = pure ()+      }++spec :: Spec+spec = sequential $ do+  describe "sqitchPersistentPostgresqlSpec" $ do+    describe "toy-sqitch-ok" $ do+      settings <- runIO $ settingsFor [reldir|test_resources/toy-sqitch-ok|] Nothing+      sqitchPersistentPostgresqlSpec settings++  describe "runSqitchPersistentChecks (negative cases)" $+    expectFailing $ do+      describe "toy-sqitch-drift" $+        setupAround emptyPostgresOptionsSetupFunc $+          it "fails when the sqitch schema is missing a column the persistent model has" $ \opts -> do+            settings <- settingsFor [reldir|test_resources/toy-sqitch-drift|] Nothing+            runSqitchPersistentChecks settings opts++      describe "toy-sqitch-index-drift" $+        setupAround emptyPostgresOptionsSetupFunc $+          it "fails when the columns match but the sqitch side has an extra index the persistent model does not" $ \opts -> do+            settings <- settingsFor [reldir|test_resources/toy-sqitch-index-drift|] Nothing+            runSqitchPersistentChecks settings opts

@@ -0,0 +1,10 @@+-- Deploy toy-drift:init to pg+-- Intentionally missing the `color` column that the persistent model has.+BEGIN;++CREATE TABLE IF NOT EXISTS widget (+    id   BIGSERIAL PRIMARY KEY,+    name TEXT NOT NULL+);++COMMIT;

@@ -0,0 +1,6 @@+-- Revert toy-drift:init from pg+BEGIN;++DROP TABLE IF EXISTS widget;++COMMIT;

@@ -0,0 +1,2 @@+[core]+	engine = pg

@@ -0,0 +1,5 @@+%syntax-version=1.0.0+%project=toy-drift+%uri=sydtest-sqitch/toy-drift++init 2026-01-01T00:00:00Z syd <syd@example.com> # Create widget table without color

@@ -0,0 +1,6 @@+-- Verify toy-drift:init on pg+BEGIN;++SELECT id, name FROM widget WHERE FALSE;++ROLLBACK;

@@ -0,0 +1,15 @@+-- Deploy toy-index-drift:init to pg+-- Table columns match the persistent Widget model; the extra index on+-- `name` exists only on the sqitch side. Used to assert that the+-- schema-equality check compares indices, not just columns.+BEGIN;++CREATE TABLE IF NOT EXISTS widget (+    id    BIGSERIAL PRIMARY KEY,+    name  TEXT NOT NULL,+    color TEXT+);++CREATE INDEX IF NOT EXISTS widget_name_idx ON widget (name);++COMMIT;

@@ -0,0 +1,6 @@+-- Revert toy-index-drift:init from pg+BEGIN;++DROP TABLE IF EXISTS widget;++COMMIT;

@@ -0,0 +1,2 @@+[core]+	engine = pg

@@ -0,0 +1,5 @@+%syntax-version=1.0.0+%project=toy-index-drift+%uri=sydtest-sqitch/toy-index-drift++init 2026-01-01T00:00:00Z syd <syd@example.com> # Create widget table with an index the persistent model does not have

@@ -0,0 +1,6 @@+-- Verify toy-index-drift:init on pg+BEGIN;++SELECT id, name, color FROM widget WHERE FALSE;++ROLLBACK;

@@ -0,0 +1,7 @@+-- Deploy toy-ok:add-color to pg+BEGIN;++ALTER TABLE widget DROP COLUMN IF EXISTS color;+ALTER TABLE widget ADD COLUMN IF NOT EXISTS color TEXT;++COMMIT;

@@ -0,0 +1,6 @@+-- Deploy toy-ok:add-color@v1 to pg+BEGIN;++ALTER TABLE widget ADD COLUMN IF NOT EXISTS color VARCHAR(7);++COMMIT;

@@ -0,0 +1,9 @@+-- Deploy toy-ok:init to pg+BEGIN;++CREATE TABLE IF NOT EXISTS widget (+    id   BIGSERIAL PRIMARY KEY,+    name TEXT NOT NULL+);++COMMIT;

@@ -0,0 +1,7 @@+-- Revert toy-ok:add-color from pg+BEGIN;++ALTER TABLE widget DROP COLUMN IF EXISTS color;+ALTER TABLE widget ADD COLUMN IF NOT EXISTS color VARCHAR(7);++COMMIT;

@@ -0,0 +1,6 @@+-- Revert toy-ok:add-color@v1 from pg+BEGIN;++ALTER TABLE widget DROP COLUMN IF EXISTS color;++COMMIT;

@@ -0,0 +1,6 @@+-- Revert toy-ok:init from pg+BEGIN;++DROP TABLE IF EXISTS widget;++COMMIT;

@@ -0,0 +1,2 @@+[core]+	engine = pg

@@ -0,0 +1,8 @@+%syntax-version=1.0.0+%project=toy-ok+%uri=sydtest-sqitch/toy-ok++init 2026-01-01T00:00:00Z syd <syd@example.com> # Create widget table+add-color 2026-01-02T00:00:00Z syd <syd@example.com> # Add color column to widget+@v1 2026-01-03T00:00:00Z syd <syd@example.com> # Tag before reworking add-color+add-color [add-color@v1] 2026-01-04T00:00:00Z syd <syd@example.com> # Rework add-color to use TEXT

@@ -0,0 +1,6 @@+-- Verify toy-ok:add-color on pg+BEGIN;++SELECT color FROM widget WHERE FALSE;++ROLLBACK;

@@ -0,0 +1,6 @@+-- Verify toy-ok:add-color@v1 on pg+BEGIN;++SELECT color FROM widget WHERE FALSE;++ROLLBACK;

@@ -0,0 +1,6 @@+-- Verify toy-ok:init on pg+BEGIN;++SELECT id, name FROM widget WHERE FALSE;++ROLLBACK;