diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -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. diff --git a/src/Test/Syd/Sqitch/Postgresql.hs b/src/Test/Syd/Sqitch/Postgresql.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Sqitch/Postgresql.hs @@ -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)) diff --git a/src/Test/Syd/Sqitch/Postgresql/Plan.hs b/src/Test/Syd/Sqitch/Postgresql/Plan.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Sqitch/Postgresql/Plan.hs @@ -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 @\@@ and reads +-- @deploy/name\@.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 diff --git a/src/Test/Syd/Sqitch/Postgresql/Process.hs b/src/Test/Syd/Sqitch/Postgresql/Process.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Sqitch/Postgresql/Process.hs @@ -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 --verify@ +sqitchDeployTo :: SqitchSettings -> SqitchTarget -> Text -> IO () +sqitchDeployTo settings target change = + sqitchAt settings target "deploy" ["--to", Text.unpack change, "--verify"] + +-- | @sqitch revert --target ... --to -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"] diff --git a/src/Test/Syd/Sqitch/Postgresql/Schema.hs b/src/Test/Syd/Sqitch/Postgresql/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Sqitch/Postgresql/Schema.hs @@ -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