packages feed

sydtest-sqitch-postgres (empty) → 0.1.0.0

raw patch · 50 files changed

+1526/−0 lines, 50 filesdep +basedep +bytestringdep +containers

Dependencies added: base, bytestring, containers, monad-logger, network-uri, path, path-io, persistent, postgres-options, random, sydtest, sydtest-persistent-postgresql, sydtest-sqitch-postgres, text, typed-process, unliftio

Files

+ CHANGELOG.md view
@@ -0,0 +1,27 @@+# Changelog++## [0.1.0.0] - 2026-06-27++### Changed++- Migrations are now deployed into a fresh, randomly-named non-`public`+  schema instead of `public`, created and dropped (`CASCADE`) via a+  `SetupFunc` so tests leave nothing behind. This surfaces migrations+  that hardcode a schema name (e.g. a deploy guard or verify with+  `table_schema = 'public'`), which previously passed unnoticed because+  the tests ran in `public`. Schema snapshots now follow+  `current_schema()`.+- **Breaking:** `sqitchTargetFromOptions` now takes the target schema as+  its first argument; it is carried on `SqitchTarget` and applied to+  sqitch's connections via `PGOPTIONS`.++### Added++- `randomSchemaSetupFunc`, `randomSchemaName`, `schemaSetupFunc`, and+  `useTestSchema` for managing the per-test schema. `randomSchemaSetupFunc`+  generates a fresh schema name and supplies it; `schemaSetupFunc` takes a+  given name (used when the same schema must be shared across databases).++## [0.0.0.0] - 2026-05-17++First release.
+ LICENSE.md view
@@ -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.
+ src/Test/Syd/Sqitch/Postgresql.hs view
@@ -0,0 +1,206 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Sanity-check tests for a sqitch project against a temporary+-- PostgreSQL database.+--+-- Three checks are layered on every sqitch project:+--+--   1. /Per-change round-trip/: for each change in the plan, deploy+--      through it, revert one step, redeploy. The schema after the+--      redeploy must match the schema before the revert.+--+--      Skipped in two situations:+--+--        * /Rework heads/ -- the second occurrence of a change name in+--          the plan, whose deploy target ends in @\@HEAD@. Sqitch's+--          revert of just the rework runs the rework's revert script,+--          which by sqitch convention undoes the /whole/ change rather+--          than only the rework, so the intermediate state isn't+--          post(predecessor) and this check would fail spuriously.+--        * /Grandfathered/ steps -- those at or before+--          'sqitchSettingsGrandfatherTag'. These shipped before this+--          test existed and may have minor revert/deploy inconsistencies+--          (e.g. index names that differ between deploy and+--          revert-then-redeploy) that don't matter on the production+--          databases that already ran them.+--+--      The whole-plan cycle test (3) still exercises both of these+--      classes of step end-to-end, and the schema-equality check in+--      @sydtest-sqitch-postgres-persistent@ asserts the final schema+--      matches the persistent model.+--+--   2. /Per-change idempotence/: for each change, re-execute the+--      deploy script's raw SQL against a database where the change has+--      already been applied. The schema must be unchanged. Skipped for+--      grandfathered steps, for the same reason: the failure mode this+--      check guards against (registry drift on retry) cannot bite+--      databases that already successfully ran these scripts.+--+--   3. /Whole-plan deploy/revert/redeploy cycle/: deploy the entire+--      plan, snapshot the schema, revert everything, redeploy the+--      entire plan, snapshot again. The two snapshots must be equal.+--      This exercises both rework heads and grandfathered steps that+--      (1) skips, and also exercises sqitch's own registry across a+--      full cycle.+--+-- Each check runs against a fresh empty database (its own server,+-- user, and DB), allocated and torn down by the spec combinator. The+-- caller never sees the postgres machinery in its outer-type stack.+--+-- Migrations are deployed into a fresh, randomly-named /non-public/+-- schema (created and torn down by 'randomSchemaSetupFunc', put on the+-- search path by 'useTestSchema') rather than @public@. Deploying into a+-- non-default schema makes a migration that hardcodes a schema name (a+-- guard or verify with @table_schema = \'public\'@, say) fail here,+-- instead of passing unnoticed because the test happened to run in+-- @public@.+module Test.Syd.Sqitch.Postgresql+  ( sqitchPostgresqlSpec,+    runSqitchPerChangeChecks,+    runSqitchWholePlanCycle,+    module Test.Syd.Sqitch.Postgresql.Plan,+    module Test.Syd.Sqitch.Postgresql.Process,+    module Test.Syd.Sqitch.Postgresql.Schema,+  )+where++import Control.Monad (forM_, unless)+import Control.Monad.Logger (runNoLoggingT)+import qualified Data.ByteString as SB+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified Database.Persist.Sql as DB+import qualified Database.PostgreSQL.Simple.Options as Postgres+import Path+import Test.Syd+import Test.Syd.Persistent.Postgresql+  ( emptyPostgresOptionsSetupFunc,+    postgresqlPoolSetupFunc,+  )+import Test.Syd.Sqitch.Postgresql.Plan+import Test.Syd.Sqitch.Postgresql.Process+import Test.Syd.Sqitch.Postgresql.Schema++-- | Top-level spec combinator: declares the per-change and whole-plan+-- cycle checks. Allocates fresh empty postgres databases internally+-- for each check, so the caller's outer-type stack is unchanged.+--+-- Sequence with other 'TestDef' values via 'do' or '>>':+--+-- > spec :: Spec+-- > spec = do+-- >   sqitchPostgresqlSpec mySettings+-- >   describe "my other tests" $ ...+sqitchPostgresqlSpec ::+  SqitchSettings ->+  TestDef outers ()+sqitchPostgresqlSpec settings =+  describe "sqitch sanity checks" $+    setupAround emptyPostgresOptionsSetupFunc $ do+      perChangeIt settings+      wholePlanCycleIt settings++perChangeIt :: SqitchSettings -> TestDef outers Postgres.Options+perChangeIt settings =+  it "round-trips and (unless grandfathered) is idempotent for every change in sqitch.plan" $+    \(opts :: Postgres.Options) ->+      runSqitchPerChangeChecks settings opts++wholePlanCycleIt :: SqitchSettings -> TestDef outers Postgres.Options+wholePlanCycleIt settings =+  it "the whole plan deploys, reverts, and redeploys to the same schema" $+    \(opts :: Postgres.Options) ->+      runSqitchWholePlanCycle settings opts++-- | Run the per-change round-trip and idempotence checks against a+-- fresh empty database described by the given options. Exposed in 'IO'+-- so callers can wrap it in 'expectFailing' for negative tests.+runSqitchPerChangeChecks :: SqitchSettings -> Postgres.Options -> IO ()+runSqitchPerChangeChecks settings opts =+  unSetupFunc (postgresqlPoolSetupFunc opts) $ \pool ->+    -- Deploy into a fresh non-public schema, created and torn down here,+    -- so any migration that hardcodes a schema surfaces.+    unSetupFunc (randomSchemaSetupFunc pool) $ \schema -> do+      let target = sqitchTargetFromOptions schema opts++      planRel <- parseRelFile "sqitch.plan"+      steps <-+        readSqitchPlan+          (sqitchSettingsGrandfatherTag settings)+          (sqitchSettingsProjectDir settings </> planRel)++      iterateSteps settings schema target pool steps++-- | Deploy the entire plan, snapshot the schema, revert everything,+-- redeploy the entire plan, snapshot again, assert the two snapshots+-- are equal. Runs against a fresh empty database.+runSqitchWholePlanCycle :: SqitchSettings -> Postgres.Options -> IO ()+runSqitchWholePlanCycle settings opts =+  unSetupFunc (postgresqlPoolSetupFunc opts) $ \pool ->+    unSetupFunc (randomSchemaSetupFunc pool) $ \schema -> do+      let target = sqitchTargetFromOptions schema opts++      sqitchAt settings target "deploy" ["--verify"]+      schemaFirst <- runNoLoggingT $ DB.runSqlPool (useTestSchema schema >> querySchema) pool++      sqitchRevertAll settings target+      sqitchAt settings target "deploy" ["--verify"]+      schemaSecond <- runNoLoggingT $ DB.runSqlPool (useTestSchema schema >> querySchema) pool++      context "whole-plan deploy/revert/redeploy cycle" $+        compareSchemaSnapshots "first deploy" schemaSecond schemaFirst++-- | Walk the plan one step at a time.+--+-- @prevTargets@ pairs each step with the step before it (or 'Nothing'+-- for the first step), so the per-step revert knows where to land. We+-- do not start each step from a clean DB because that would defeat the+-- test's ability to catch FK/dependency interactions between migrations.+iterateSteps ::+  SqitchSettings ->+  Text ->+  SqitchTarget ->+  DB.ConnectionPool ->+  [PlanStep] ->+  IO ()+iterateSteps settings schema target pool steps =+  forM_ (zip steps prevTargets) $ \(step, mPrev) ->+    context (Text.unpack (stepLabel step)) $ do+      sqitchDeployTo settings target (stepDeployTarget step)+      schemaPostStep <-+        runNoLoggingT $ DB.runSqlPool (useTestSchema schema >> querySchema) pool++      -- Round-trip: see module-level docs for the skip conditions.+      unless (stepIsReworkHead step || stepIsGrandfathered step) $ do+        case mPrev of+          Nothing -> sqitchRevertTo settings target "@ROOT"+          Just prev -> sqitchRevertTo settings target (stepDeployTarget prev)+        sqitchDeployTo settings target (stepDeployTarget step)+        schemaAfterRoundtrip <-+          runNoLoggingT $ DB.runSqlPool (useTestSchema schema >> querySchema) pool+        context "round-trip (revert one step then redeploy)" $+          compareSchemaSnapshots "after redeploy" schemaAfterRoundtrip schemaPostStep++      -- Idempotence: re-run the deploy script's raw SQL bypassing+      -- sqitch (which would short-circuit on "already deployed").+      unless (stepIsGrandfathered step) $ do+        script <- readDeployScript settings (stepScriptName step)+        runNoLoggingT $+          flip DB.runSqlPool pool $+            useTestSchema schema >> DB.rawExecute script []+        schemaAfterRerun <-+          runNoLoggingT $ DB.runSqlPool (useTestSchema schema >> querySchema) pool+        context "idempotence (re-run the deploy script)" $+          compareSchemaSnapshots "after rerun" schemaAfterRerun schemaPostStep+  where+    prevTargets = Nothing : map Just steps++readDeployScript :: SqitchSettings -> Text -> IO Text+readDeployScript settings scriptName = do+  deployDir <- parseRelDir "deploy"+  fileRel <- parseRelFile (Text.unpack scriptName <> ".sql")+  Text.decodeUtf8Lenient+    <$> SB.readFile+      (fromAbsFile (sqitchSettingsProjectDir settings </> deployDir </> fileRel))
+ src/Test/Syd/Sqitch/Postgresql/Plan.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Parsing a @sqitch.plan@ file into a sequence of deploy steps.+module Test.Syd.Sqitch.Postgresql.Plan+  ( PlanStep (..),+    readSqitchPlan,+  )+where++import qualified Data.ByteString as SB+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import Path++-- | One step in a sqitch plan: enough information to drive @sqitch deploy@,+-- find the deploy script on disk, identify the step in test output, and+-- decide whether the idempotence check applies.+data PlanStep = PlanStep+  { -- | Human label used as test 'context'.+    stepLabel :: Text,+    -- | Argument to @sqitch deploy --to@ to bring the database to the+    -- post-step state.+    stepDeployTarget :: Text,+    -- | Filename (without directory) in @deploy/@, e.g. @init.sql@ or+    -- @add-foo\@v2026-01-01.sql@.+    stepScriptName :: Text,+    -- | If 'True', skip the per-change round-trip /and/ idempotence+    -- checks for this step. Set when the step is at or before the+    -- grandfather tag (see 'readSqitchPlan').+    --+    -- These checks are end-state invariants that grandfathered scripts+    -- aren't expected to satisfy in isolation -- they shipped before the+    -- checks existed, and the failure modes they guard against (revert+    -- drift, registry retry) can't manifest on databases that already+    -- ran them. The whole-plan cycle and schema-equality checks still+    -- apply to grandfathered steps end-to-end.+    stepIsGrandfathered :: Bool,+    -- | If 'True', this step is the post-tag head of a reworked change+    -- (its deploy target is @name\@HEAD@). The round-trip check is+    -- skipped on such steps because sqitch's revert of just the rework+    -- runs the rework's revert script, which by sqitch convention+    -- undoes the whole change rather than only the rework. A partial+    -- revert/redeploy therefore does not land at post(rework) and would+    -- fail the round-trip check spuriously. Whole-plan deploy/revert+    -- cycles still exercise this code path.+    stepIsReworkHead :: Bool+  }+  deriving (Show, Eq)++-- | Parse a @sqitch.plan@ file into one 'PlanStep' per change.+--+-- The optional grandfather tag marks a cut-over point: every change in+-- plan order at or before the tag is marked 'stepIsGrandfathered = True';+-- every change after it is 'False'. Pass 'Nothing' to mean \"no+-- grandfathering -- every change must be idempotent\".+--+-- If the tag is 'Just' but does not appear in the plan, 'fail' (a typo+-- in the tag should not silently pass as \"nothing is grandfathered\").+--+-- Reworked changes (a line of the form @name [name\@tag]@) become two+-- steps: the predecessor step deploys through @\@<tag>@ and reads+-- @deploy/name\@<tag>.sql@; the head step deploys via @name\@HEAD@ and+-- reads @deploy/name.sql@.+readSqitchPlan ::+  -- | Grandfather tag (without the leading @\@@), or 'Nothing'.+  Maybe Text ->+  Path Abs File ->+  IO [PlanStep]+readSqitchPlan mGrandfatherTag path = do+  contents <- Text.decodeUtf8Lenient <$> SB.readFile (fromAbsFile path)+  let allLines = Text.lines contents+      -- When there is no grandfather tag, no change is grandfathered;+      -- this is modelled by starting "past the tag" immediately.+      pastTagInitial = case mGrandfatherTag of+        Nothing -> True+        Just _ -> False+      steps = go pastTagInitial Map.empty allLines+      tagSeen = case mGrandfatherTag of+        Nothing -> True+        Just t -> any (tagLineMatches t) allLines+  if not tagSeen+    then+      fail $+        "sydtest-sqitch: grandfather tag '"+          <> Text.unpack (fromMaybe "" mGrandfatherTag)+          <> "' was not found in "+          <> fromAbsFile path+    else pure steps+  where+    -- A line is a tag declaration line if (after stripping) it starts with+    -- '@'. Its name is the run of non-space characters after the '@'.+    tagLineMatches :: Text -> Text -> Bool+    tagLineMatches t line =+      let stripped = Text.strip line+       in case Text.uncons stripped of+            Just ('@', rest) ->+              Text.takeWhile (\c -> c /= ' ' && c /= '\t') rest == t+            _ -> False++    -- pastTag is False until we cross the grandfather tag (or always True+    -- if there is no tag). Steps deployed while pastTag is False are+    -- grandfathered.+    go _ _ [] = []+    go pastTag seen (line : rest) =+      let stripped = Text.strip line+       in case Text.uncons stripped of+            Nothing -> go pastTag seen rest+            Just ('%', _) -> go pastTag seen rest+            Just ('@', tagRest) ->+              let tagName = Text.takeWhile (\c -> c /= ' ' && c /= '\t') tagRest+                  pastTag' = pastTag || Just tagName == mGrandfatherTag+               in go pastTag' seen rest+            _ -> case Text.words stripped of+              (name : _) ->+                let grandfathered = not pastTag+                    isHead = Map.member name seen+                    step = case findNextTagBeforeName name rest of+                      Just tagName ->+                        PlanStep+                          { stepLabel = name <> "@" <> tagName,+                            stepDeployTarget = "@" <> tagName,+                            stepScriptName = name <> "@" <> tagName,+                            stepIsGrandfathered = grandfathered,+                            stepIsReworkHead = False+                          }+                      Nothing ->+                        PlanStep+                          { stepLabel = name,+                            stepDeployTarget =+                              if isHead then name <> "@HEAD" else name,+                            stepScriptName = name,+                            stepIsGrandfathered = grandfathered,+                            stepIsReworkHead = isHead+                          }+                 in step : go pastTag (Map.insertWith (+) name (1 :: Int) seen) rest+              [] -> go pastTag seen rest++    -- For a change line @name@ at position p, look forward for the next+    -- tag line that comes before any subsequent line that also begins+    -- with @name@. If found, this is a reworked change and we want the+    -- predecessor (deploy through the tag) target.+    findNextTagBeforeName :: Text -> [Text] -> Maybe Text+    findNextTagBeforeName = scan Nothing+      where+        scan _ _ [] = Nothing+        scan tag nm (l : ls) =+          let stripped = Text.strip l+           in case Text.uncons stripped of+                Nothing -> scan tag nm ls+                Just ('%', _) -> scan tag nm ls+                Just ('@', tagRest) ->+                  let tagName = Text.takeWhile (\c -> c /= ' ' && c /= '\t') tagRest+                   in scan (Just tagName) nm ls+                _ -> case Text.words stripped of+                  (n : _) | n == nm -> tag+                  _ -> scan tag nm ls
+ src/Test/Syd/Sqitch/Postgresql/Process.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Shelling out to @sqitch@ for tests.+module Test.Syd.Sqitch.Postgresql.Process+  ( SqitchSettings (..),+    SqitchTarget,+    sqitchTargetFromOptions,+    sqitchAt,+    sqitchDeployTo,+    sqitchRevertTo,+    sqitchRevertAll,+  )+where++import Data.List (isPrefixOf)+import Data.Maybe (fromMaybe)+import Data.Monoid (getLast)+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Word (Word16)+import qualified Database.PostgreSQL.Simple.Options as Postgres+import Network.URI (escapeURIString, isUnreserved)+import Path+import System.Environment (getEnvironment)+import System.Process.Typed++-- | Static configuration for a sqitch-based test suite.+data SqitchSettings = SqitchSettings+  { -- | Directory containing @sqitch.plan@, @deploy/@, @revert/@, @verify/@.+    sqitchSettingsProjectDir :: Path Abs Dir,+    -- | Absolute path to the sqitch executable. In a Nix-built test binary+    -- this is typically a @\/nix\/store@ path to @sqitch-pg@.+    sqitchSettingsBin :: Path Abs File,+    -- | Sqitch tag name (without the leading @\@@) marking the cut-over+    -- point for idempotence. Every change in plan order at or before the+    -- tag is exempt from the idempotence check (because it shipped to+    -- production before that check existed); every change after the tag+    -- must be idempotent. 'Nothing' means every change must be idempotent.+    sqitchSettingsGrandfatherTag :: Maybe Text+  }++-- | A @sqitch --target@ value: a libpq-style URI pointing at a+-- database, together with the schema sqitch should deploy into. The+-- schema is carried here (rather than baked into the URI) so 'sqitchAt'+-- can put it on @search_path@ via @PGOPTIONS@ for every subcommand.+data SqitchTarget = SqitchTarget+  { sqitchTargetUri :: String,+    sqitchTargetSchema :: Text+  }++-- | Build a sqitch target from libpq connection 'Postgres.Options' and+-- the schema to deploy into. Handles the unix-socket host case (host+-- starts with @/@) by URL-encoding the host segment so sqitch's URI+-- parser keeps the socket path intact.+sqitchTargetFromOptions :: Text -> Postgres.Options -> SqitchTarget+sqitchTargetFromOptions schema options =+  let rawHost :: String+      rawHost = fromMaybe "localhost" (getLast (Postgres.host options))+      port :: Word16+      port = maybe 5432 fromIntegral (getLast (Postgres.port options))+      user :: String+      user = fromMaybe "" (getLast (Postgres.user options))+      password :: String+      password = fromMaybe "" (getLast (Postgres.password options))+      dbname :: String+      dbname = fromMaybe "" (getLast (Postgres.dbname options))+      encodedHost+        | "/" `isPrefixOf` rawHost = escapeURIString isUnreserved rawHost+        | otherwise = rawHost+      enc = escapeURIString isUnreserved+   in SqitchTarget+        { sqitchTargetUri =+            concat+              [ "db:pg://",+                enc user,+                ":",+                enc password,+                "@",+                encodedHost,+                ":",+                show port,+                "/",+                enc dbname+              ],+          sqitchTargetSchema = schema+        }++-- | Run a sqitch subcommand against a target. Forces @TZ=UTC@: sqitch+-- records registry timestamps via Perl @DateTime@, whose local-tz probe+-- can fail nondeterministically and cause it to roll back a successful+-- deploy.+sqitchAt ::+  SqitchSettings ->+  SqitchTarget ->+  -- | Subcommand, e.g. @\"deploy\"@.+  String ->+  -- | Extra arguments.+  [String] ->+  IO ()+sqitchAt settings target cmd extraArgs = do+  env <- getEnvironment+  -- Scope every sqitch connection to the target's schema via search_path,+  -- so its unqualified DDL lands there and current_schema() resolves to+  -- it. public stays on the path for shared functions.+  let overrides =+        [ ("TZ", "UTC"),+          ("PGOPTIONS", "-c search_path=" <> Text.unpack (sqitchTargetSchema target) <> ",public")+        ]+      kept (k, _) = k `notElem` map fst overrides+  runProcess_ $+    setEnv (overrides <> filter kept env) $+      setWorkingDir (fromAbsDir (sqitchSettingsProjectDir settings)) $+        proc (fromAbsFile (sqitchSettingsBin settings)) $+          [cmd, "--target", sqitchTargetUri target] <> extraArgs++-- | @sqitch deploy --target ... --to <change> --verify@+sqitchDeployTo :: SqitchSettings -> SqitchTarget -> Text -> IO ()+sqitchDeployTo settings target change =+  sqitchAt settings target "deploy" ["--to", Text.unpack change, "--verify"]++-- | @sqitch revert --target ... --to <change> -y@+sqitchRevertTo :: SqitchSettings -> SqitchTarget -> Text -> IO ()+sqitchRevertTo settings target change =+  sqitchAt settings target "revert" ["--to", Text.unpack change, "-y"]++-- | @sqitch revert --target ... -y@+sqitchRevertAll :: SqitchSettings -> SqitchTarget -> IO ()+sqitchRevertAll settings target =+  sqitchAt settings target "revert" ["-y"]
+ src/Test/Syd/Sqitch/Postgresql/Schema.hs view
@@ -0,0 +1,228 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+-- The undefined-trick in 'compareSchemaSnapshots' deliberately binds no+-- variables; that's the point -- it forces GHC to error when a field is+-- added to SchemaSnapshot.+{-# OPTIONS_GHC -Wno-unused-pattern-binds #-}++-- | Helpers for snapshotting a PostgreSQL schema and comparing two+-- snapshots.+module Test.Syd.Sqitch.Postgresql.Schema+  ( -- * Test schema+    randomSchemaName,+    randomSchemaSetupFunc,+    schemaSetupFunc,+    useTestSchema,++    -- * Snapshots+    SchemaSnapshot (..),+    querySchema,+    queryColumns,+    queryIndices,+    compareSchemaSnapshots,++    -- * Low-level helpers+    normaliseSchema,+    removeComments,+    align,+    compareSchemas,+  )+where++import Control.Monad (forM_)+import Control.Monad.Logger (runNoLoggingT)+import qualified Data.Map.Merge.Strict as Merge+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Word (Word64)+import Database.Persist.Sql (ConnectionPool, Single (..), SqlPersistT, rawExecute, rawSql, runSqlPool)+import Numeric (showHex)+import System.Random (randomRIO)+import Test.Syd++-- | A fresh, random, non-@public@ schema name like @sqitch_test_1a2b3c@.+--+-- The harness deploys migrations into a schema with this name rather+-- than @public@. Deploying into a non-default schema surfaces any+-- migration that hardcodes a schema name (a deploy guard or verify+-- with @table_schema = \'public\'@, say) that silently misbehaves+-- there (a skipped @ALTER@, a verify that finds nothing) while passing+-- unnoticed when everything is in @public@. Randomising the name also+-- keeps a migration from accidentally depending on a fixed one. The+-- portable form is @current_schema()@, which the snapshots below use.+randomSchemaName :: IO Text+randomSchemaName = do+  n <- randomRIO (0, maxBound) :: IO Word64+  pure (Text.pack ("sqitch_test_" <> showHex n ""))++-- | Create the given schema on the pool's database and drop it+-- (@CASCADE@) on teardown, so a test leaves no schema behind. Pair with+-- 'randomSchemaName' for a fresh name per use. The created schema is+-- empty; put it on the search path with 'useTestSchema' before running+-- DDL against it.+--+-- Teardown also drops sqitch's own registry schema (the default+-- @sqitch@), which a @sqitch deploy@ into this database creates outside+-- the test schema, so the database really is left as it was found. (The+-- drop is a harmless no-op when nothing put a registry there.)+schemaSetupFunc :: Text -> ConnectionPool -> SetupFunc ()+schemaSetupFunc schema pool =+  bracketSetupFunc+    (exec ("CREATE SCHEMA \"" <> schema <> "\""))+    ( \() -> do+        exec ("DROP SCHEMA IF EXISTS \"" <> schema <> "\" CASCADE")+        exec "DROP SCHEMA IF EXISTS \"sqitch\" CASCADE"+    )+  where+    exec :: Text -> IO ()+    exec sql = runNoLoggingT (runSqlPool (rawExecute sql []) pool)++-- | Like 'schemaSetupFunc' but generates the schema name itself (via+-- 'randomSchemaName') and supplies it to the inner action, so callers do+-- not have to thread the name. Creates a fresh random non-@public@ schema+-- and drops it (@CASCADE@) on teardown. Use 'schemaSetupFunc' directly+-- only when the same schema name must be shared across two databases.+randomSchemaSetupFunc :: ConnectionPool -> SetupFunc Text+randomSchemaSetupFunc pool = do+  schema <- liftIO randomSchemaName+  schemaSetupFunc schema pool+  pure schema++-- | Put the (already-created, see 'schemaSetupFunc') schema at the head+-- of the session's search path, so unqualified DDL lands in it and+-- @current_schema()@ resolves to it. @public@ stays on the path so+-- shared functions remain reachable. Run it at the start of any pooled+-- action that creates or inspects schema objects. The name comes from+-- 'randomSchemaName' and so is safe to splice.+useTestSchema :: (MonadIO m) => Text -> SqlPersistT m ()+useTestSchema schema =+  rawExecute ("SET search_path TO \"" <> schema <> "\", public") []++-- | Everything that defines the shape of the @current_schema()@ for the+-- purposes of equality testing.+--+-- Add new fields here as new categories of schema object grow into+-- scope (constraints, sequences, triggers, views, …). The+-- undefined-trick inside 'compareSchemaSnapshots' will then prompt you+-- to extend the comparison.+data SchemaSnapshot = SchemaSnapshot+  { -- | Columns of every table in the current schema, keyed by+    -- @(table_name, column_name)@. See 'queryColumns'.+    schemaSnapshotColumns :: Map (Text, Text) Text,+    -- | Indices of every table in the current schema, keyed by+    -- @(table_name, index_name)@. See 'queryIndices'.+    schemaSnapshotIndices :: Map (Text, Text) Text+  }+  deriving (Show, Eq)++-- | Snapshot everything in 'SchemaSnapshot' in one query batch.+querySchema :: (MonadIO m) => SqlPersistT m SchemaSnapshot+querySchema = SchemaSnapshot <$> queryColumns <*> queryIndices++-- | Snapshot the columns of every table in the current schema, keyed+-- by @(table_name, column_name)@. The value is a normalised string+-- containing the schema name, table name, column name, and data type.+queryColumns :: (MonadIO m) => SqlPersistT m (Map (Text, Text) Text)+queryColumns =+  Map.fromList+    . map+      ( \(Single schemaName, Single tableName, Single columnName, Single dataType) ->+          ( (tableName, columnName),+            normaliseSchema $+              schemaName <> "." <> tableName <> "." <> columnName <> " " <> dataType+          )+      )+    <$> rawSql+      "SELECT table_schema, table_name, column_name, data_type FROM information_schema.columns WHERE table_schema = current_schema() ORDER BY table_name, ordinal_position"+      []++-- | Snapshot the indices of every table in the current schema, keyed+-- by @(table_name, index_name)@. The value is the normalised+-- @CREATE INDEX@ statement reported by @pg_indexes.indexdef@ -- which+-- captures columns, ordering, uniqueness, and any partial-index+-- predicate.+queryIndices :: (MonadIO m) => SqlPersistT m (Map (Text, Text) Text)+queryIndices =+  Map.fromList+    . map+      ( \(Single tableName, Single indexName, Single indexDef) ->+          ((tableName, indexName), normaliseSchema indexDef)+      )+    <$> rawSql+      "SELECT tablename, indexname, indexdef FROM pg_indexes WHERE schemaname = current_schema() ORDER BY tablename, indexname"+      []++-- | Compare two 'SchemaSnapshot's field by field, calling+-- 'expectationFailure' on any divergence. The label names the first+-- side so failures read naturally (\"Missing in <label>: ...\" /+-- \"Extra in <label>: ...\").+--+-- The 'undefined' pattern is a deliberate compile-time prompt: when a+-- new field is added to 'SchemaSnapshot', this pattern stops matching+-- and GHC complains, forcing you to extend the comparison.+compareSchemaSnapshots :: String -> SchemaSnapshot -> SchemaSnapshot -> IO ()+compareSchemaSnapshots label actual expected =+  let SchemaSnapshot _ _ = undefined :: SchemaSnapshot+   in do+        context "columns" $+          compareSchemas label $+            align (schemaSnapshotColumns actual) (schemaSnapshotColumns expected)+        context "indices" $+          compareSchemas label $+            align (schemaSnapshotIndices actual) (schemaSnapshotIndices expected)++-- | Strip SQL comments and collapse whitespace so two semantically+-- equal snippets compare equal as 'Text'.+normaliseSchema :: Text -> Text+normaliseSchema =+  Text.strip+    . Text.unwords+    . Text.words+    . Text.replace "\n" " "+    . Text.replace "\r" " "+    . Text.replace "\t" " "+    . removeComments++-- | Drop everything from @--@ to end-of-line, then drop blank lines.+removeComments :: Text -> Text+removeComments =+  Text.unlines+    . filter (not . Text.null)+    . map (fst . Text.breakOn "--")+    . Text.lines++-- | Outer-join two maps, recording for each key which side it came from.+align :: (Ord k) => Map k a -> Map k b -> Map k (Maybe a, Maybe b)+align =+  Merge.merge+    (Merge.mapMissing (\_ a -> (Just a, Nothing)))+    (Merge.mapMissing (\_ b -> (Nothing, Just b)))+    (Merge.zipWithMatched (\_ a b -> (Just a, Just b)))++-- | Walk an aligned schema map and 'expectationFailure' on any+-- divergence. Used internally by 'compareSchemaSnapshots'; exposed for+-- callers that want to compare ad-hoc maps.+compareSchemas ::+  String ->+  Map (Text, Text) (Maybe Text, Maybe Text) ->+  IO ()+compareSchemas label1 aligned =+  forM_ (Map.toList aligned) $ \((typ, name), (v1, v2)) ->+    context (unwords ["In", Text.unpack typ, Text.unpack name]) $+      case (v1, v2) of+        (Just s1, Just s2) -> s1 `shouldBe` s2+        (Nothing, Just sql) ->+          expectationFailure $+            unlines+              [ unwords ["Missing in", label1 <> ":", Text.unpack typ, Text.unpack name],+                Text.unpack sql+              ]+        (Just sql, Nothing) ->+          expectationFailure $+            unlines+              [ unwords ["Extra in", label1 <> ":", Text.unpack typ, Text.unpack name],+                Text.unpack sql+              ]+        (Nothing, Nothing) -> expectationFailure "Impossible: both sides absent"
+ sydtest-sqitch-postgres.cabal view
@@ -0,0 +1,115 @@+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+version:        0.1.0.0+synopsis:       A sqitch-on-PostgreSQL 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-broken-revert/deploy/add-color.sql+    test_resources/toy-sqitch-broken-revert/deploy/init.sql+    test_resources/toy-sqitch-broken-revert/revert/add-color.sql+    test_resources/toy-sqitch-broken-revert/revert/init.sql+    test_resources/toy-sqitch-broken-revert/sqitch.conf+    test_resources/toy-sqitch-broken-revert/sqitch.plan+    test_resources/toy-sqitch-broken-revert/verify/add-color.sql+    test_resources/toy-sqitch-broken-revert/verify/init.sql+    test_resources/toy-sqitch-grandfathered/deploy/add-color.sql+    test_resources/toy-sqitch-grandfathered/deploy/add-shape.sql+    test_resources/toy-sqitch-grandfathered/deploy/init.sql+    test_resources/toy-sqitch-grandfathered/revert/add-color.sql+    test_resources/toy-sqitch-grandfathered/revert/add-shape.sql+    test_resources/toy-sqitch-grandfathered/revert/init.sql+    test_resources/toy-sqitch-grandfathered/sqitch.conf+    test_resources/toy-sqitch-grandfathered/sqitch.plan+    test_resources/toy-sqitch-grandfathered/verify/add-color.sql+    test_resources/toy-sqitch-grandfathered/verify/add-shape.sql+    test_resources/toy-sqitch-grandfathered/verify/init.sql+    test_resources/toy-sqitch-hardcoded-public/deploy/init.sql+    test_resources/toy-sqitch-hardcoded-public/revert/init.sql+    test_resources/toy-sqitch-hardcoded-public/sqitch.conf+    test_resources/toy-sqitch-hardcoded-public/sqitch.plan+    test_resources/toy-sqitch-hardcoded-public/verify/init.sql+    test_resources/toy-sqitch-non-idempotent/deploy/init.sql+    test_resources/toy-sqitch-non-idempotent/revert/init.sql+    test_resources/toy-sqitch-non-idempotent/sqitch.conf+    test_resources/toy-sqitch-non-idempotent/sqitch.plan+    test_resources/toy-sqitch-non-idempotent/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+      Test.Syd.Sqitch.Postgresql.Plan+      Test.Syd.Sqitch.Postgresql.Process+      Test.Syd.Sqitch.Postgresql.Schema+  other-modules:+      Paths_sydtest_sqitch_postgres+  hs-source-dirs:+      src+  build-depends:+      base >=4.7 && <5+    , bytestring+    , containers+    , monad-logger+    , network-uri+    , path+    , persistent+    , postgres-options+    , random+    , sydtest+    , sydtest-persistent-postgresql+    , text+    , typed-process+  default-language: Haskell2010++test-suite sydtest-sqitch-postgres-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Test.Syd.Sqitch.Postgresql.PlanSpec+      Test.Syd.Sqitch.PostgresqlSpec+      Paths_sydtest_sqitch_postgres+  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+    , bytestring+    , path+    , path-io+    , sydtest+    , sydtest-persistent-postgresql+    , sydtest-sqitch-postgres+    , text+    , unliftio+  default-language: Haskell2010
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF sydtest-discover #-}
+ test/Test/Syd/Sqitch/Postgresql/PlanSpec.hs view
@@ -0,0 +1,307 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Test.Syd.Sqitch.Postgresql.PlanSpec (spec) where++import Control.Exception (SomeException, try)+import qualified Data.ByteString as SB+import Data.List (isInfixOf)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as TE+import Path+import Path.IO+import Test.Syd+import Test.Syd.Sqitch.Postgresql.Plan+import qualified UnliftIO.Temporary as Tmp++-- | Helper: write a plan to a temp file and parse it.+parsePlan :: Maybe Text -> Text -> IO [PlanStep]+parsePlan mTag body =+  Tmp.withSystemTempDirectory "sydtest-sqitch-plan" $ \dirStr -> do+    dir <- resolveDir' dirStr+    name <- parseRelFile "sqitch.plan"+    let path = dir </> name+    SB.writeFile (fromAbsFile path) (TE.encodeUtf8 body)+    readSqitchPlan mTag path++spec :: Spec+spec = describe "readSqitchPlan" $ do+  it "parses an empty plan to no steps" $ do+    steps <- parsePlan Nothing "%syntax-version=1.0.0\n%project=p\n\n"+    steps `shouldBe` []++  it "parses a single change" $ do+    steps <-+      parsePlan+        Nothing+        "%syntax-version=1.0.0\n%project=p\ninit 2026-01-01T00:00:00Z syd <syd@example.com> # x\n"+    steps+      `shouldBe` [ PlanStep+                     { stepLabel = "init",+                       stepDeployTarget = "init",+                       stepScriptName = "init",+                       stepIsGrandfathered = False,+                       stepIsReworkHead = False+                     }+                 ]++  it "splits a reworked change into two steps and marks the head" $ do+    steps <-+      parsePlan+        Nothing+        ( Text.unlines+            [ "%syntax-version=1.0.0",+              "%project=p",+              "init 2026-01-01T00:00:00Z syd <syd@example.com> # x",+              "add-foo 2026-01-02T00:00:00Z syd <syd@example.com> # y",+              "@v1 2026-01-03T00:00:00Z syd <syd@example.com> # tag",+              "add-foo [add-foo@v1] 2026-01-04T00:00:00Z syd <syd@example.com> # rework"+            ]+        )+    steps+      `shouldBe` [ PlanStep+                     { stepLabel = "init",+                       stepDeployTarget = "init",+                       stepScriptName = "init",+                       stepIsGrandfathered = False,+                       stepIsReworkHead = False+                     },+                   PlanStep+                     { stepLabel = "add-foo@v1",+                       stepDeployTarget = "@v1",+                       stepScriptName = "add-foo@v1",+                       stepIsGrandfathered = False,+                       stepIsReworkHead = False+                     },+                   PlanStep+                     { stepLabel = "add-foo",+                       stepDeployTarget = "add-foo@HEAD",+                       stepScriptName = "add-foo",+                       stepIsGrandfathered = False,+                       stepIsReworkHead = True+                     }+                 ]++  it "marks no step as grandfathered when no tag is given" $ do+    steps <-+      parsePlan+        Nothing+        ( Text.unlines+            [ "%project=p",+              "a 2026-01-01T00:00:00Z syd <syd@example.com> # x",+              "@v 2026-01-02T00:00:00Z syd <syd@example.com> # tag",+              "b 2026-01-03T00:00:00Z syd <syd@example.com> # x"+            ]+        )+    steps+      `shouldBe` [ PlanStep+                     { stepLabel = "a",+                       stepDeployTarget = "a",+                       stepScriptName = "a",+                       stepIsGrandfathered = False,+                       stepIsReworkHead = False+                     },+                   PlanStep+                     { stepLabel = "b",+                       stepDeployTarget = "b",+                       stepScriptName = "b",+                       stepIsGrandfathered = False,+                       stepIsReworkHead = False+                     }+                 ]++  it "marks steps at or before the tag as grandfathered, others not" $ do+    steps <-+      parsePlan+        (Just "legacy")+        ( Text.unlines+            [ "%project=p",+              "a 2026-01-01T00:00:00Z syd <syd@example.com> # x",+              "b 2026-01-02T00:00:00Z syd <syd@example.com> # x",+              "@legacy 2026-01-03T00:00:00Z syd <syd@example.com> # tag",+              "c 2026-01-04T00:00:00Z syd <syd@example.com> # x",+              "d 2026-01-05T00:00:00Z syd <syd@example.com> # x"+            ]+        )+    steps+      `shouldBe` [ PlanStep+                     { stepLabel = "a",+                       stepDeployTarget = "a",+                       stepScriptName = "a",+                       stepIsGrandfathered = True,+                       stepIsReworkHead = False+                     },+                   PlanStep+                     { stepLabel = "b",+                       stepDeployTarget = "b",+                       stepScriptName = "b",+                       stepIsGrandfathered = True,+                       stepIsReworkHead = False+                     },+                   PlanStep+                     { stepLabel = "c",+                       stepDeployTarget = "c",+                       stepScriptName = "c",+                       stepIsGrandfathered = False,+                       stepIsReworkHead = False+                     },+                   PlanStep+                     { stepLabel = "d",+                       stepDeployTarget = "d",+                       stepScriptName = "d",+                       stepIsGrandfathered = False,+                       stepIsReworkHead = False+                     }+                 ]++  it "marks every step as grandfathered when the tag is the last line" $ do+    steps <-+      parsePlan+        (Just "legacy")+        ( Text.unlines+            [ "%project=p",+              "a 2026-01-01T00:00:00Z syd <syd@example.com> # x",+              "b 2026-01-02T00:00:00Z syd <syd@example.com> # x",+              "@legacy 2026-01-03T00:00:00Z syd <syd@example.com> # tag"+            ]+        )+    map stepIsGrandfathered steps `shouldBe` [True, True]++  it "marks no step as grandfathered when the tag is the very first thing in the plan" $ do+    steps <-+      parsePlan+        (Just "legacy")+        ( Text.unlines+            [ "%project=p",+              "@legacy 2026-01-01T00:00:00Z syd <syd@example.com> # tag",+              "a 2026-01-02T00:00:00Z syd <syd@example.com> # x",+              "b 2026-01-03T00:00:00Z syd <syd@example.com> # x"+            ]+        )+    map stepIsGrandfathered steps `shouldBe` [False, False]++  it "grandfathers the rework predecessor but not the head when the tag IS the rework tag" $ do+    -- The classic scenario: a change was reworked, and the tag the+    -- rework predates is also the cut-over for idempotence. The+    -- predecessor (deployed pre-tag) is grandfathered; the rework+    -- head (deployed post-tag) is not.+    steps <-+      parsePlan+        (Just "v1")+        ( Text.unlines+            [ "%project=p",+              "init 2026-01-01T00:00:00Z syd <syd@example.com> # x",+              "@v1 2026-01-02T00:00:00Z syd <syd@example.com> # tag",+              "init [init@v1] 2026-01-03T00:00:00Z syd <syd@example.com> # rework"+            ]+        )+    steps+      `shouldBe` [ PlanStep+                     { stepLabel = "init@v1",+                       stepDeployTarget = "@v1",+                       stepScriptName = "init@v1",+                       stepIsGrandfathered = True,+                       stepIsReworkHead = False+                     },+                   PlanStep+                     { stepLabel = "init",+                       stepDeployTarget = "init@HEAD",+                       stepScriptName = "init",+                       stepIsGrandfathered = False,+                       stepIsReworkHead = True+                     }+                 ]++  it "handles a change reworked twice (three occurrences, two tags)" $ do+    -- The first two occurrences are tagged predecessors; only the+    -- third (and last) is the rework head with target @HEAD.+    steps <-+      parsePlan+        Nothing+        ( Text.unlines+            [ "%project=p",+              "foo 2026-01-01T00:00:00Z syd <syd@example.com> # original",+              "@v1 2026-01-02T00:00:00Z syd <syd@example.com> # tag1",+              "foo [foo@v1] 2026-01-03T00:00:00Z syd <syd@example.com> # rework 1",+              "@v2 2026-01-04T00:00:00Z syd <syd@example.com> # tag2",+              "foo [foo@v2] 2026-01-05T00:00:00Z syd <syd@example.com> # rework 2"+            ]+        )+    steps+      `shouldBe` [ PlanStep+                     { stepLabel = "foo@v1",+                       stepDeployTarget = "@v1",+                       stepScriptName = "foo@v1",+                       stepIsGrandfathered = False,+                       stepIsReworkHead = False+                     },+                   PlanStep+                     { stepLabel = "foo@v2",+                       stepDeployTarget = "@v2",+                       stepScriptName = "foo@v2",+                       stepIsGrandfathered = False,+                       stepIsReworkHead = False+                     },+                   PlanStep+                     { stepLabel = "foo",+                       stepDeployTarget = "foo@HEAD",+                       stepScriptName = "foo",+                       stepIsGrandfathered = False,+                       stepIsReworkHead = True+                     }+                 ]++  it "ignores blank lines and lines with only whitespace" $ do+    steps <-+      parsePlan+        Nothing+        ( Text.unlines+            [ "%project=p",+              "",+              "  ",+              "\t",+              "a 2026-01-01T00:00:00Z syd <syd@example.com> # x",+              "",+              "b 2026-01-02T00:00:00Z syd <syd@example.com> # x"+            ]+        )+    map stepLabel steps `shouldBe` ["a", "b"]++  it "fails when the grandfather tag is not present in the plan" $ do+    res <-+      try $+        parsePlan+          (Just "nope")+          "%project=p\ninit 2026-01-01T00:00:00Z syd <syd@example.com> # x\n"+    case res of+      Left (e :: SomeException) ->+        ("nope" `isInfixOf` show e) `shouldBe` True+      Right _ -> expectationFailure "expected readSqitchPlan to fail"++  it "parses the toy-sqitch-ok fixture file from disk" $ do+    p <- resolveFile' "test_resources/toy-sqitch-ok/sqitch.plan"+    steps <- readSqitchPlan Nothing p+    steps+      `shouldBe` [ PlanStep+                     { stepLabel = "init",+                       stepDeployTarget = "init",+                       stepScriptName = "init",+                       stepIsGrandfathered = False,+                       stepIsReworkHead = False+                     },+                   PlanStep+                     { stepLabel = "add-color@v1",+                       stepDeployTarget = "@v1",+                       stepScriptName = "add-color@v1",+                       stepIsGrandfathered = False,+                       stepIsReworkHead = False+                     },+                   PlanStep+                     { stepLabel = "add-color",+                       stepDeployTarget = "add-color@HEAD",+                       stepScriptName = "add-color",+                       stepIsGrandfathered = False,+                       stepIsReworkHead = True+                     }+                 ]
+ test/Test/Syd/Sqitch/PostgresqlSpec.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Test.Syd.Sqitch.PostgresqlSpec (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++-- | Locate the sqitch executable on @PATH@ at test-suite start.+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 SqitchSettings+settingsFor relDir mTag = do+  projectDir <- makeAbsolute relDir+  binPath <- locateSqitch+  pure+    SqitchSettings+      { sqitchSettingsProjectDir = projectDir,+        sqitchSettingsBin = binPath,+        sqitchSettingsGrandfatherTag = mTag+      }++spec :: Spec+spec = sequential $ do+  describe "sqitchPostgresqlSpec" $ do+    describe "toy-sqitch-ok" $ do+      settings <- runIO $ settingsFor [reldir|test_resources/toy-sqitch-ok|] Nothing+      sqitchPostgresqlSpec settings++    describe "toy-sqitch-grandfathered with grandfather tag" $ do+      settings <-+        runIO $ settingsFor [reldir|test_resources/toy-sqitch-grandfathered|] (Just "legacy")+      sqitchPostgresqlSpec settings++  describe "negative cases" $+    expectFailing $ do+      describe "toy-sqitch-non-idempotent" $+        setupAround emptyPostgresOptionsSetupFunc $+          it "fails because the change is non-idempotent" $ \opts -> do+            settings <- settingsFor [reldir|test_resources/toy-sqitch-non-idempotent|] Nothing+            runSqitchPerChangeChecks settings opts++      describe "toy-sqitch-broken-revert" $+        setupAround emptyPostgresOptionsSetupFunc $+          it "fails because the revert is not the inverse of the deploy" $ \opts -> do+            settings <- settingsFor [reldir|test_resources/toy-sqitch-broken-revert|] Nothing+            runSqitchPerChangeChecks settings opts++      describe "toy-sqitch-grandfathered without grandfather tag" $+        setupAround emptyPostgresOptionsSetupFunc $+          it "fails because the pre-tag legacy change is no longer exempt" $ \opts -> do+            settings <- settingsFor [reldir|test_resources/toy-sqitch-grandfathered|] Nothing+            runSqitchPerChangeChecks settings opts++      describe "toy-sqitch-hardcoded-public" $+        setupAround emptyPostgresOptionsSetupFunc $+          it "fails because a verify hardcodes the public schema (caught by deploying into a non-public schema)" $ \opts -> do+            settings <- settingsFor [reldir|test_resources/toy-sqitch-hardcoded-public|] Nothing+            runSqitchPerChangeChecks settings opts
+ test_resources/toy-sqitch-broken-revert/deploy/add-color.sql view
@@ -0,0 +1,7 @@+-- Deploy toy-broken-revert:add-color to pg+BEGIN;++ALTER TABLE widget ADD COLUMN IF NOT EXISTS color VARCHAR(7);+ALTER TABLE widget ADD COLUMN IF NOT EXISTS shape TEXT;++COMMIT;
+ test_resources/toy-sqitch-broken-revert/deploy/init.sql view
@@ -0,0 +1,9 @@+-- Deploy toy-broken-revert:init to pg+BEGIN;++CREATE TABLE IF NOT EXISTS widget (+    id   SERIAL PRIMARY KEY,+    name TEXT NOT NULL+);++COMMIT;
+ test_resources/toy-sqitch-broken-revert/revert/add-color.sql view
@@ -0,0 +1,12 @@+-- Revert toy-broken-revert:add-color from pg+-- BUG: as well as dropping its own added columns, this also drops the+-- `name` column added in the prior `init` migration. The redeploy+-- cannot recover that, so the round-trip schema will differ from the+-- pre-revert snapshot.+BEGIN;++ALTER TABLE widget DROP COLUMN IF EXISTS color;+ALTER TABLE widget DROP COLUMN IF EXISTS shape;+ALTER TABLE widget DROP COLUMN IF EXISTS name;++COMMIT;
+ test_resources/toy-sqitch-broken-revert/revert/init.sql view
@@ -0,0 +1,6 @@+-- Revert toy-broken-revert:init from pg+BEGIN;++DROP TABLE IF EXISTS widget;++COMMIT;
+ test_resources/toy-sqitch-broken-revert/sqitch.conf view
@@ -0,0 +1,2 @@+[core]+	engine = pg
+ test_resources/toy-sqitch-broken-revert/sqitch.plan view
@@ -0,0 +1,6 @@+%syntax-version=1.0.0+%project=toy-broken-revert+%uri=sydtest-sqitch/toy-broken-revert++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; revert is wrong
+ test_resources/toy-sqitch-broken-revert/verify/add-color.sql view
@@ -0,0 +1,6 @@+-- Verify toy-broken-revert:add-color on pg+BEGIN;++SELECT color, shape FROM widget WHERE FALSE;++ROLLBACK;
+ test_resources/toy-sqitch-broken-revert/verify/init.sql view
@@ -0,0 +1,6 @@+-- Verify toy-broken-revert:init on pg+BEGIN;++SELECT id, name FROM widget WHERE FALSE;++ROLLBACK;
+ test_resources/toy-sqitch-grandfathered/deploy/add-color.sql view
@@ -0,0 +1,6 @@+-- Deploy toy-grandfathered:add-color to pg+BEGIN;++ALTER TABLE widget ADD COLUMN IF NOT EXISTS color VARCHAR(7);++COMMIT;
+ test_resources/toy-sqitch-grandfathered/deploy/add-shape.sql view
@@ -0,0 +1,6 @@+-- Deploy toy-grandfathered:add-shape to pg+BEGIN;++ALTER TABLE widget ADD COLUMN IF NOT EXISTS shape TEXT;++COMMIT;
+ test_resources/toy-sqitch-grandfathered/deploy/init.sql view
@@ -0,0 +1,9 @@+-- Deploy toy-grandfathered:init to pg+BEGIN;++CREATE TABLE widget (+    id   SERIAL PRIMARY KEY,+    name TEXT NOT NULL+);++COMMIT;
+ test_resources/toy-sqitch-grandfathered/revert/add-color.sql view
@@ -0,0 +1,6 @@+-- Revert toy-grandfathered:add-color from pg+BEGIN;++ALTER TABLE widget DROP COLUMN IF EXISTS color;++COMMIT;
+ test_resources/toy-sqitch-grandfathered/revert/add-shape.sql view
@@ -0,0 +1,28 @@+-- Revert toy-grandfathered:add-shape from pg+--+-- Intentionally uses the "swap-via-_new" pattern. PostgreSQL keeps the+-- primary-key index's name from the table that owned it before the+-- rename, so after this revert the pkey is named 'widget_new_pkey'+-- rather than 'widget_pkey'. When the per-change round-trip then+-- redeploys add-shape (which only adds a column), the pkey name stays+-- 'widget_new_pkey' -- different from the original post(add-shape)+-- snapshot taken on a database where init.sql had created the table+-- directly with pkey 'widget_pkey'.+--+-- This is the kind of legacy quirk the grandfather flag covers: the+-- end-to-end deploy works, but the per-change round-trip would catch+-- the asymmetry. Modern migrations must avoid this; legacy ones don't+-- have to be retrofitted.+BEGIN;++CREATE TABLE widget_new (+    id   SERIAL PRIMARY KEY,+    name TEXT NOT NULL+);++INSERT INTO widget_new (id, name) SELECT id, name FROM widget;++DROP TABLE widget;+ALTER TABLE widget_new RENAME TO widget;++COMMIT;
+ test_resources/toy-sqitch-grandfathered/revert/init.sql view
@@ -0,0 +1,6 @@+-- Revert toy-grandfathered:init from pg+BEGIN;++DROP TABLE IF EXISTS widget;++COMMIT;
+ test_resources/toy-sqitch-grandfathered/sqitch.conf view
@@ -0,0 +1,2 @@+[core]+	engine = pg
+ test_resources/toy-sqitch-grandfathered/sqitch.plan view
@@ -0,0 +1,8 @@+%syntax-version=1.0.0+%project=toy-grandfathered+%uri=sydtest-sqitch/toy-grandfathered++init 2026-01-01T00:00:00Z syd <syd@example.com> # Non-idempotent: CREATE TABLE without IF NOT EXISTS+add-shape 2026-01-02T00:00:00Z syd <syd@example.com> # Round-trip-broken: revert uses _new rename pattern+@legacy 2026-01-03T00:00:00Z syd <syd@example.com> # Cut-over: everything after must pass both checks+add-color 2026-01-04T00:00:00Z syd <syd@example.com> # Idempotent and round-trip-safe
+ test_resources/toy-sqitch-grandfathered/verify/add-color.sql view
@@ -0,0 +1,6 @@+-- Verify toy-grandfathered:add-color on pg+BEGIN;++SELECT color FROM widget WHERE FALSE;++ROLLBACK;
+ test_resources/toy-sqitch-grandfathered/verify/add-shape.sql view
@@ -0,0 +1,6 @@+-- Verify toy-grandfathered:add-shape on pg+BEGIN;++SELECT shape FROM widget WHERE FALSE;++ROLLBACK;
+ test_resources/toy-sqitch-grandfathered/verify/init.sql view
@@ -0,0 +1,6 @@+-- Verify toy-grandfathered:init on pg+BEGIN;++SELECT id, name FROM widget WHERE FALSE;++ROLLBACK;
+ test_resources/toy-sqitch-hardcoded-public/deploy/init.sql view
@@ -0,0 +1,9 @@+-- Deploy toy-hardcoded-public:init to pg+BEGIN;++CREATE TABLE IF NOT EXISTS widget (+    id   SERIAL PRIMARY KEY,+    name TEXT NOT NULL+);++COMMIT;
+ test_resources/toy-sqitch-hardcoded-public/revert/init.sql view
@@ -0,0 +1,6 @@+-- Revert toy-hardcoded-public:init from pg+BEGIN;++DROP TABLE IF EXISTS widget;++COMMIT;
+ test_resources/toy-sqitch-hardcoded-public/sqitch.conf view
@@ -0,0 +1,2 @@+[core]+	engine = pg
+ test_resources/toy-sqitch-hardcoded-public/sqitch.plan view
@@ -0,0 +1,5 @@+%syntax-version=1.0.0+%project=toy-hardcoded-public+%uri=sydtest-sqitch/toy-hardcoded-public++init 2026-01-01T00:00:00Z syd <syd@example.com> # Create widget table
+ test_resources/toy-sqitch-hardcoded-public/verify/init.sql view
@@ -0,0 +1,18 @@+-- Verify toy-hardcoded-public:init on pg+BEGIN;++-- Intentional anti-pattern: this verify hardcodes the schema. When the+-- harness deploys into a non-public schema, `widget` is not in `public`,+-- so this RAISEs and the deploy --verify fails. The portable form is+-- `table_schema = current_schema()`.+DO $$+BEGIN+    IF NOT EXISTS (+        SELECT 1 FROM information_schema.columns+        WHERE table_schema = 'public' AND table_name = 'widget' AND column_name = 'name'+    ) THEN+        RAISE EXCEPTION 'widget.name is not in the public schema';+    END IF;+END $$;++ROLLBACK;
+ test_resources/toy-sqitch-non-idempotent/deploy/init.sql view
@@ -0,0 +1,9 @@+-- Deploy toy-non-idempotent:init to pg+BEGIN;++CREATE TABLE widget (+    id   SERIAL PRIMARY KEY,+    name TEXT NOT NULL+);++COMMIT;
+ test_resources/toy-sqitch-non-idempotent/revert/init.sql view
@@ -0,0 +1,6 @@+-- Revert toy-non-idempotent:init from pg+BEGIN;++DROP TABLE widget;++COMMIT;
+ test_resources/toy-sqitch-non-idempotent/sqitch.conf view
@@ -0,0 +1,2 @@+[core]+	engine = pg
+ test_resources/toy-sqitch-non-idempotent/sqitch.plan view
@@ -0,0 +1,5 @@+%syntax-version=1.0.0+%project=toy-non-idempotent+%uri=sydtest-sqitch/toy-non-idempotent++init 2026-01-01T00:00:00Z syd <syd@example.com> # Create widget table (non-idempotent)
+ test_resources/toy-sqitch-non-idempotent/verify/init.sql view
@@ -0,0 +1,6 @@+-- Verify toy-non-idempotent:init on pg+BEGIN;++SELECT id, name FROM widget WHERE FALSE;++ROLLBACK;
+ test_resources/toy-sqitch-ok/deploy/add-color.sql view
@@ -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;
+ test_resources/toy-sqitch-ok/deploy/add-color@v1.sql view
@@ -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;
+ test_resources/toy-sqitch-ok/deploy/init.sql view
@@ -0,0 +1,9 @@+-- Deploy toy-ok:init to pg+BEGIN;++CREATE TABLE IF NOT EXISTS widget (+    id   SERIAL PRIMARY KEY,+    name TEXT NOT NULL+);++COMMIT;
+ test_resources/toy-sqitch-ok/revert/add-color.sql view
@@ -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;
+ test_resources/toy-sqitch-ok/revert/add-color@v1.sql view
@@ -0,0 +1,6 @@+-- Revert toy-ok:add-color@v1 from pg+BEGIN;++ALTER TABLE widget DROP COLUMN IF EXISTS color;++COMMIT;
+ test_resources/toy-sqitch-ok/revert/init.sql view
@@ -0,0 +1,6 @@+-- Revert toy-ok:init from pg+BEGIN;++DROP TABLE IF EXISTS widget;++COMMIT;
+ test_resources/toy-sqitch-ok/sqitch.conf view
@@ -0,0 +1,2 @@+[core]+	engine = pg
+ test_resources/toy-sqitch-ok/sqitch.plan view
@@ -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
+ test_resources/toy-sqitch-ok/verify/add-color.sql view
@@ -0,0 +1,6 @@+-- Verify toy-ok:add-color on pg+BEGIN;++SELECT color FROM widget WHERE FALSE;++ROLLBACK;
+ test_resources/toy-sqitch-ok/verify/add-color@v1.sql view
@@ -0,0 +1,6 @@+-- Verify toy-ok:add-color@v1 on pg+BEGIN;++SELECT color FROM widget WHERE FALSE;++ROLLBACK;
+ test_resources/toy-sqitch-ok/verify/init.sql view
@@ -0,0 +1,6 @@+-- Verify toy-ok:init on pg+BEGIN;++SELECT id, name FROM widget WHERE FALSE;++ROLLBACK;