Postgres migrations aren't idempotent

We've been trying to get migrations working with our beam based project and ran into a problem where initialising an empty database using a CheckedDatabaseSettings based migration and then immediately running the migration a second time causes Beam to try to delete and re-add all the columns:

We have (roughly) the following schema (I've edited it by hand from our app so
it may not compile directly - the output from the migration below was produced
by our actual app)

### V0001.hs

```haskell
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}

module Database.Schema.V0001 where

import Data.ByteString (ByteString)
import Data.Text (Text)
import Data.Time (LocalTime)
import Data.UUID (UUID)

import Database.Beam as B
import Database.Beam.Migrate.SQL (DataType)
import Database.Beam.Migrate.SQL.Tables
import Database.Beam.Migrate.Types
import Database.Beam.Postgres
import Database.Beam.Postgres.Syntax (PgDataTypeSyntax)

import Data.Aeson
import Data.Swagger

defaultFieldMaxLength :: Word
defaultFieldMaxLength = 120

type PrimaryKeyType = UUID

pkSerialType :: DataType PgDataTypeSyntax UUID
pkSerialType = uuid

data TheDB f = TheDB
{ _users :: f (TableEntity UserT)
, _businesses :: f (TableEntity BusinessT)
, _keys :: f (TableEntity KeyT)
}
deriving Generic
instance Database anybackend TheDB

migration :: () -> Migration PgCommandSyntax (CheckedDatabaseSettings Postgres TheDB)
migration () = TheDB
<$> createTable "users"
( UserT
(field "user_id" pkSerialType)
(BizId (field "user_biz_id" pkSerialType))
(field "first_name" (varchar (Just defaultFieldMaxLength)) notNull)
(field "last_name" (varchar (Just defaultFieldMaxLength)) notNull)
(field "phone_number" (varchar (Just defaultFieldMaxLength)) notNull)
(field "password_hash" binaryLargeObject notNull)
(field "email_address" (varchar (Just defaultFieldMaxLength)) unique notNull)
)
<*> createTable "businesses"
( BusinessT
(field "business_id" pkSerialType)
(field "biz_name" (varchar (Just defaultFieldMaxLength)) notNull)
(field "biz_function" (varchar (Just defaultFieldMaxLength)) notNull)
(field "biz_site_name" (varchar (Just defaultFieldMaxLength)) notNull)
(field "biz_address" (varchar (Just defaultFieldMaxLength)) notNull)
)
<*> createTable "keys"
( KeyT
(field "key_id" pkSerialType)
(UserId (field "key_user_id" pkSerialType))
(field "key_info" text)
(field "creation_time" timestamptz)
(field "revocation_time" (maybeType timestamptz))
(field "expiration_time" (maybeType timestamptz))
)

type User = UserT Identity
deriving instance Show User

data UserT f = UserT
{ user_id :: C f PrimaryKeyType
, user_biz_id :: PrimaryKey BusinessT f
, first_name :: C f Text
, last_name :: C f Text
, phone_number :: C f Text
, password_hash :: C f ByteString
, email_address :: C f Text
} deriving Generic

type UserID = PrimaryKey UserT Identity
deriving instance Show (PrimaryKey UserT Identity)

instance Beamable UserT
instance Beamable (PrimaryKey UserT)

instance Table UserT where
data PrimaryKey UserT f = UserId (C f PrimaryKeyType)
deriving Generic
primaryKey = UserId . user_id
deriving instance Eq (PrimaryKey UserT Identity)

type Business = BusinessT Identity
deriving instance Show Business

data BusinessT f = BusinessT
{ business_id :: C f PrimaryKeyType
, biz_name :: C f Text
, biz_function :: C f Text
, biz_site_name :: C f Text
, biz_address :: C f Text
} deriving Generic

type BizId = PrimaryKey BusinessT Identity
deriving instance Show (PrimaryKey BusinessT Identity)

instance Beamable BusinessT
instance Beamable (PrimaryKey BusinessT)

instance Table BusinessT where
data PrimaryKey BusinessT f = BizId (C f PrimaryKeyType)
deriving Generic
primaryKey = BizId . business_id
deriving instance Eq (PrimaryKey BusinessT Identity)

type Key = KeyT Identity
deriving instance Show Key

data KeyT f = KeyT
{ key_id :: C f PrimaryKeyType
, key_user_id :: PrimaryKey UserT f
, key_info :: C f Text
, creation_time :: C f LocalTime
, revocation_time :: C f (Maybe LocalTime)
, expiration_time :: C f (Maybe LocalTime)
} deriving Generic

type KeyId = PrimaryKey KeyT Identity
deriving instance Show (PrimaryKey KeyT Identity)

instance Beamable KeyT
instance Beamable (PrimaryKey KeyT)

instance Table KeyT where
data PrimaryKey KeyT f = KeyId (C f PrimaryKeyType)
deriving Generic
primaryKey = KeyId . key_id
deriving instance Eq (PrimaryKey KeyT Identity)
```

And the following migration:

### Schema.hs

```haskell
module Database.Schema
( module Current
, migration
, db
, checkedDB ) where

-- import Control.Arrow ((>>>))

import Database.Beam (DatabaseSettings)
import Database.Beam.Migrate.Types hiding (migrateScript)
import Database.Beam.Postgres (PgCommandSyntax, Postgres)

import Database.Schema.V0001 as Current hiding (migration)

import qualified Database.Schema.V0001 as V0001 (migration)
-- import qualified Database.Schema.V0002 as V0002 (db, migration)

migration :: MigrationSteps PgCommandSyntax () (CheckedDatabaseSettings Postgres Current.TheDB)
migration = migrationStep "Initial commit" V0001.migration
-- >>> migrationStep """todo comment""" V0002.migration

db :: DatabaseSettings Postgres Current.TheDB
db = unCheckDatabase checkedDB

checkedDB :: CheckedDatabaseSettings Postgres Current.TheDB
checkedDB = evaluateDatabase migration
```

And the following code to run the migration:

### Interactive.hs

```haskell
{-# LANGUAGE TypeApplications #-}

module Interactive
(runMigrationInteractive) where

import Common.Types
import Database.Schema

import qualified Data.ByteString.Lazy.Char8 as BSL

import Control.Monad.IO.Class (liftIO)

import Control.Lens (view, _1)

import Database.Beam.Migrate.Simple (runSimpleMigration,
simpleMigration)
import Database.Beam.Postgres (Pg, PgCommandSyntax, Postgres)
import Database.Beam.Postgres.Migrate (migrationBackend)
import Database.Beam.Postgres.Syntax (fromPgCommand,
pgRenderSyntaxScript)

runMigrationInteractive ::
(HasConnPool context
, AsSqlError err)
=> context -> IO (Either err ())
runMigrationInteractive context = runAppM context $ runDb $ do
conn <- view _1
liftIO $ do
mcommands <- simpleMigration migrationBackend conn checkedDB
case mcommands of
Nothing -> fail "Something went wrong constructing migration"
Just [] -> putStrLn "Already up to date"
Just commands -> do
mapM_ (BSL.putStrLn . pgRenderSyntaxScript . fromPgCommand) commands
putStrLn "type YES to confirm applying this migration:"
confirm <- getLine
case confirm of
"YES" -> runSimpleMigration
@PgCommandSyntax
@Postgres @_ @Pg
conn commands
_ -> putStrLn "Nothing done."

```

When executing the migration as follows, I get this output (cleaned for readability):

```shell
$ createdb beamBug
$ stack exec theApp -- --conn 'postgresql:///beamBug' initdb
CREATE TABLE "users"
( "user_id" UUID
, "user_biz_id" UUID
, "first_name" VARCHAR(120) NOT NULL
, "last_name" VARCHAR(120) NOT NULL
, "phone_number" VARCHAR(120) NOT NULL
, "password_hash" BYTEA NOT NULL
, "email_address" VARCHAR(120) UNIQUE NOT NULL
, PRIMARY KEY("user_id"))
CREATE TABLE "businesses"
( "business_id" UUID
, "biz_name" VARCHAR(120) NOT NULL
, "biz_function" VARCHAR(120) NOT NULL
, "biz_site_name" VARCHAR(120) NOT NULL
, "biz_address" VARCHAR(120) NOT NULL
, PRIMARY KEY("business_id"))
CREATE TABLE "keys"
( "key_id" UUID
, "key_user_id" UUID
, "key_info" TEXT
, "creation_time" TIMESTAMP WITH TIME ZONE
, "revocation_time" TIMESTAMP WITH TIME ZONE
, "expiration_time" TIMESTAMP WITH TIME ZONE
, PRIMARY KEY("key_id"))
type YES to confirm applying this migration:
YES
Right ()
```

Running it a second time I get:

```shell
stack exec theApp -- -c 'postgresql:///beamBug' initdb
ALTER TABLE "users" ALTER COLUMN "email_address" SET NOT NULL
ALTER TABLE "keys" ALTER COLUMN "key_id" DROP NOT NULL
ALTER TABLE "users" ALTER COLUMN "user_id" DROP NOT NULL
ALTER TABLE "businesses" ALTER COLUMN "business_id" DROP NOT NULL
ALTER TABLE "users" DROP COLUMN "phone_number"
ALTER TABLE "users" ADD COLUMN "phone_number" VARCHAR(120)
ALTER TABLE "users" ALTER COLUMN "phone_number" SET NOT NULL
ALTER TABLE "users" DROP COLUMN "first_name"
ALTER TABLE "users" ADD COLUMN "first_name" VARCHAR(120)
ALTER TABLE "users" ALTER COLUMN "first_name" SET NOT NULL
ALTER TABLE "businesses" DROP COLUMN "biz_site_name"
ALTER TABLE "businesses" ADD COLUMN "biz_site_name" VARCHAR(120)
ALTER TABLE "businesses" ALTER COLUMN "biz_site_name" SET NOT NULL
ALTER TABLE "businesses" DROP COLUMN "biz_function"
ALTER TABLE "businesses" ADD COLUMN "biz_function" VARCHAR(120)
ALTER TABLE "businesses" ALTER COLUMN "biz_function" SET NOT NULL
ALTER TABLE "businesses" DROP COLUMN "biz_name"
ALTER TABLE "businesses" ADD COLUMN "biz_name" VARCHAR(120)
ALTER TABLE "businesses" ALTER COLUMN "biz_name" SET NOT NULL
ALTER TABLE "businesses" DROP COLUMN "biz_address"
ALTER TABLE "businesses" ADD COLUMN "biz_address" VARCHAR(120)
ALTER TABLE "businesses" ALTER COLUMN "biz_address" SET NOT NULL
ALTER TABLE "users" DROP COLUMN "last_name"
ALTER TABLE "users" ADD COLUMN "last_name" VARCHAR(120)
ALTER TABLE "users" ALTER COLUMN "last_name" SET NOT NULL
ALTER TABLE "users" DROP COLUMN "email_address"
ALTER TABLE "users" ADD COLUMN "email_address" VARCHAR(120)
ALTER TABLE "users" ALTER COLUMN "email_address" SET NOT NULL
ALTER TABLE "users" ALTER COLUMN "email_address" SET NOT NULL
type YES to confirm applying this migration:
YES
Left (SqlError {sqlState = "42P16", sqlExecStatus = FatalError
, sqlErrorMsg = "column \"key_id\" is in a primary key"
, sqlErrorDetail = "", sqlErrorHint = ""})
```
The error from the database seems reasonable to me, what's worrying is that beam isn't recognising that the database should already be exactly the same as what exists. Any help you can offer would be great, we'd like to avoid having to write migrations by hand but it's looking like our best options at the moment.