Skip to content

Postgres preferring DROP then ADD to RENAME for columns #285

Open
@dbaynard

Description

@dbaynard

This is a problem as a rename preserves data; dropping then adding does not. I'm using

  • beam-core-0.7.2.2
  • beam-migrate-0.3.2.1
  • beam-postgres-0.3.2.2

These versions have code paths implementing 'ALTER TABLE … RENAME COLUMN … TO …;' (renameColumnTo).

A sample file is below (it uses lens; feel free to switch to microlens*).

To reproduce (done in the file below):

  1. Create a new (beam) database.
  2. Create a version for which only the name of one column is different
  3. Construct a migration.

Then,

  1. Run the script. There are 3 sections; hit enter between each to start the next.
    1. Create the original table
    2. Print the (simple) migration commands that would be issued
    3. Print the (bringUpToDate) commands (note: this creates migration tables)

The output for me was as follows. Note the lack of "RENAME".

CREATE TABLE "test_table" ("serial" SERIAL NOT NULL, "original" BOOLEAN NOT NULL, PRIMARY KEY("serial"))
Already up to date
Ready?
y
ALTER TABLE "test_table" DROP COLUMN "original"
ALTER TABLE "test_table" ADD COLUMN "updated" BOOLEAN
ALTER TABLE "test_table" ALTER COLUMN "updated" SET NOT NULL
Ready?
y
CREATE TABLE "beam_version" ("version" INT NOT NULL, PRIMARY KEY("version"))
CREATE TABLE "beam_migration" ("id" INT NOT NULL, "commitId" VARCHAR NOT NULL, "date" TIMESTAMP NOT NULL, PRIMARY KEY("id"))
INSERT INTO "beam_version"("version") VALUES (1)
SELECT "t0"."id" AS "res0", "t0"."commitId" AS "res1", "t0"."date" AS "res2" FROM "beam_migration" AS "t0"
*** Exception: user error (Cannot check db)

The script:

{-# LANGUAGE
    PackageImports
  , DeriveGeneric
  , DerivingStrategies
  , FlexibleContexts
  , FlexibleInstances
  , ImpredicativeTypes
  , LambdaCase
  , MultiParamTypeClasses
  , NamedFieldPuns
  , NoMonomorphismRestriction
  , OverloadedStrings
  , RecordWildCards
  , ScopedTypeVariables
  , StandaloneDeriving
  , TypeApplications
  , TypeFamilies
  , TypeOperators
  #-}

module Main
  ( main
  ) where

import           "base"          Control.Arrow ((>>>))
import           "lens"          Control.Lens
import qualified "bytestring"    Data.ByteString.Lazy.Char8 as B8L
import           "base"          Data.Maybe
import           "base"          Data.Proxy
import           "beam-core"     Database.Beam
import           "beam-core"     Database.Beam.Backend.SQL
import           "beam-migrate"  Database.Beam.Migrate
import           "beam-migrate"  Database.Beam.Migrate.Simple
import           "beam-postgres" Database.Beam.Postgres
import           "beam-postgres" Database.Beam.Postgres.Migrate
import           "beam-postgres" Database.Beam.Postgres.Syntax

--------------------------------------------------
-- * main
--------------------------------------------------

main :: IO ()
main = do
  main1
  putStrLn "Ready?"
  _ <- getLine
  main2
  putStrLn "Ready?"
  _ <- getLine
  main3

main1 :: IO ()
main1 = do
  conn <- connectPostgreSQL "host=localhost dbname=postgres"
  runAutoMigration conn step1
  printMigration conn step1

main2 :: IO ()
main2 = do
  conn <- connectPostgreSQL "host=localhost dbname=postgres"
  runAutoMigration conn step1
  printMigration conn migrationSteps

main3 :: IO ()
main3 = do
  conn <- connectPostgreSQL "host=localhost dbname=postgres"
  runAutoMigration conn step1
  printUpdMigration conn migrationSteps

type MgSteps a = MigrationSteps PgCommandSyntax a (CheckedDatabaseSettings Postgres Db)
type MgStep1 = MgSteps ()
type MgStep2 = MgSteps (CheckedDatabaseSettings Postgres Db)

runAutoMigration :: Connection -> MgSteps () -> IO ()
runAutoMigration conn msteps = do
  withDatabaseDebug putStrLn conn . autoMigrate @_ @Db migrationBackend . evaluateDatabase $ msteps

printMigration :: Connection -> MgSteps () -> IO ()
printMigration conn msteps = do
  mcmds <- simpleMigration migrationBackend conn . evaluateDatabase $ msteps
  mcmds `onJust` fail "Cannot construct migration" $ \case
    [] -> putStrLn "Already up to date"
    cmds -> do
      mapM_ (B8L.putStrLn . pgRenderSyntaxScript . fromPgCommand) cmds

printUpdMigration :: Connection -> MgSteps () -> IO ()
printUpdMigration conn msteps = do
  mchecked <- runBeamPostgresDebug putStrLn conn . bringUpToDate migrationBackend $ msteps
  mcmds <- mchecked `onJust` fail "Cannot check db" $ simpleMigration migrationBackend conn
  mcmds `onJust` fail "Cannot construct migration" $ \case
    [] -> putStrLn "Already up to date"
    cmds -> do
      mapM_ (B8L.putStrLn . pgRenderSyntaxScript . fromPgCommand) cmds

checkedDB :: CheckedDatabaseSettings Postgres Db
checkedDB = evaluateDatabase migrationSteps

updateSchema :: Pg (Maybe (CheckedDatabaseSettings Postgres Db))
updateSchema = bringUpToDate migrationBackend migrationSteps

step1 :: MigrationSteps PgCommandSyntax () (CheckedDatabaseSettings Postgres Db)
step1 =
  migrationStep "Original migration" origMigration

migrationSteps :: MigrationSteps PgCommandSyntax () (CheckedDatabaseSettings Postgres Db)
migrationSteps =
  step1 >>>
  migrationStep "Rename original column to updated " updMigration

onJust :: Maybe a -> b -> (a -> b) -> b
onJust ma b = maybe b `flip` ma
{-# INLINE onJust #-}
infix 1 `onJust`

--------------------------------------------------
-- * Original definition
--------------------------------------------------

data Db f = Db
  { _dbTable :: f (TableEntity TabT)
  }
  deriving stock (Generic)

instance Database be Db

Db
  (TableLens dbTable)
  = dbLenses

type Tab = TabT Identity
type TabId = PrimaryKey TabT Identity

data TabT f = Tab
  { _tabSerial :: C f (SqlSerial Int)
  , _tabTab    :: C f Bool
  }
  deriving stock (Generic)

deriving stock instance Show Tab
deriving stock instance Eq Tab

instance Table TabT where
  data PrimaryKey TabT f = TabId (C f (SqlSerial Int)) deriving stock Generic
  primaryKey = TabId <$> _tabSerial
instance Beamable TabT
instance Beamable (PrimaryKey TabT)

Tab
  (LensFor tabSerial)
  (LensFor tabTab)
  = tableLenses

--------------------------------------------------
-- * Migrations
--------------------------------------------------

origMigration
  :: ()
  -> Migration PgCommandSyntax (CheckedDatabaseSettings Postgres Db)
origMigration () = do
    _dbTable <- createTable "test_table" Tab{..}
    pure Db{..}
  where
    _tabSerial = field "serial" defaultDataType notNull
    _tabTab    = field "original" defaultDataType notNull

defaultDataType :: forall dt syntax . HasDefaultSqlDataType syntax dt => DataType syntax dt
defaultDataType = DataType $ defaultSqlDataType (Proxy @dt) False

updMigration
  :: CheckedDatabaseSettings Postgres Db
  -> Migration PgCommandSyntax (CheckedDatabaseSettings Postgres Db)
updMigration orig = do
  _dbTable <- alterTable (orig ^. dbTable) $ \old -> do
    let _tabSerial = old ^. tabSerial
    _tabTab <- renameColumnTo "updated" (old ^. tabTab)
    pure Tab{..}
  p

Metadata

Metadata

Assignees

No one assigned

    Labels

    Type

    No type

    Projects

    No projects

    Milestone

    No milestone

    Relationships

    None yet

    Development

    No branches or pull requests

    Issue actions