sydtest-sqitch-postgres-persistent-0.1.0.0: src/Test/Syd/Sqitch/Postgresql/Persistent.hs

{-# 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