haskell-beam / haskell-beam/beam

Postgres preferring DROP then ADD to RENAME for columns

Open
#285 5 comments 0 reactions 0 assignees View on GitHub
bug migration-framework
Dominant language
Haskell
Stars
635
Forks
193
PR merge metrics
No merged PRs in 30d

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):

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,

4. 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:

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

Contributor guide

No contributing guide indexed for this repository

Assessment

This issue has not been assessed yet.

Get new issues in your inbox

A short digest of beginner-friendly GitHub issues.