Open
Description
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):
- Create a new (beam) database.
- Create a version for which only the name of one column is different
- Construct a migration.
Then,
- Run the script. There are 3 sections; hit enter between each to start the next.
- Create the original table
- Print the (simple) migration commands that would be issued
- 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