Illustrating beam migration problem about outdated relations

V0001 V0001CreateUserAndPostTables.hs

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE ImpredicativeTypes #-}

module Schema.Migrations.V0001CreateUserAndPostTables where

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

import Database.Beam
import Database.Beam.Backend.SQL.Types (SqlSerial)
import Database.Beam.Migrate
import Database.Beam.Postgres

data UserT f = User
  { _userId :: Columnar f (SqlSerial Int)
  , _userName :: Columnar f Text
  } deriving (Generic, Beamable)

instance Table UserT where
  data PrimaryKey UserT f = UserId (Columnar f (SqlSerial Int))
                        deriving (Generic, Beamable)
  primaryKey = UserId . _userId

data PostT f = Post
  { _postId :: Columnar f (SqlSerial Int)
  , _postContent :: Columnar f Text
  , _postAuthor :: PrimaryKey UserT f
  } deriving (Generic, Beamable)

instance Table PostT where
  data PrimaryKey PostT f = PostId (Columnar f (SqlSerial Int))
                        deriving (Generic, Beamable)
  primaryKey = PostId . _postId

--
-- === DATABASE DEFINITON ===
--
data DemoblogDb f = DemoblogDb
  { _user :: f (TableEntity UserT)
  , _post :: f (TableEntity PostT)
  } deriving (Generic)

instance Database Postgres DemoblogDb

migration ::
     ()
  -> Migration PgCommandSyntax (CheckedDatabaseSettings Postgres DemoblogDb)
migration () =
  DemoblogDb <$>
  createTable
    "user"
    (User (field "user_id" serial) (field "name" (varchar (Just 255)) notNull)) <*>
  createTable
    "post"
    (Post
       (field "post_id" serial)
       (field "content" text notNull)
       (UserId (field "user_id" smallint)))

V0002AddCreatedAtColumnForUser

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE ImpredicativeTypes #-}

module Schema.Migrations.V0002AddCreatedAtColumnForUser
  ( module Schema.Migrations.V0001CreateUserAndPostTables
  , module Schema.Migrations.V0002AddCreatedAtColumnForUser
  ) where

import qualified Schema.Migrations.V0001CreateUserAndPostTables as V0001 hiding
  ( PrimaryKey(UserId)
  )
import Schema.Migrations.V0001CreateUserAndPostTables hiding
  ( DemoblogDb(..)
  , PrimaryKey(UserId)
  , User
  , UserId
  , UserT(..)
  , migration
  )

import Control.Arrow
import Data.Text (Text)
import Data.Time (LocalTime)

import Database.Beam
import qualified Database.Beam.Backend.SQL.BeamExtensions as BeamExtensions
import Database.Beam.Backend.SQL.Types (SqlSerial)
import Database.Beam.Migrate
import Database.Beam.Postgres

data UserT f = User
  { _userId :: Columnar f (SqlSerial Int)
  , _userName :: Columnar f Text
  , _userCreatedAt :: Columnar f LocalTime
  } deriving (Generic, Beamable)

instance Table UserT where
  data PrimaryKey UserT f = UserId (Columnar f (SqlSerial Int))
                        deriving (Generic, Beamable)
  primaryKey = UserId . _userId

--
-- === DATABASE DEFINITON ===
--
data DemoblogDb f = DemoblogDb
  { _user :: f (TableEntity UserT)
  , _post :: f (TableEntity PostT)
  } deriving (Generic)

instance Database Postgres DemoblogDb

migration ::
     CheckedDatabaseSettings Postgres V0001.DemoblogDb
  -> Migration PgCommandSyntax (CheckedDatabaseSettings Postgres DemoblogDb)
migration oldDb = DemoblogDb <$> alterUserTable <*> preserve (V0001._post oldDb)
  where
    alterUserTable = alterTable (V0001._user oldDb) tableMigration
    tableMigration oldTable =
      User (V0001._userId oldTable) (V0001._userName oldTable) <$>
      addColumn (field "created_at" timestamptz (defaultTo_ now_) notNull)

db :: DatabaseSettings Postgres DemoblogDb
db = unCheckDatabase (evaluateDatabase migrations)
  where
    migrations ::
         MigrationSteps PgCommandSyntax () (CheckedDatabaseSettings Postgres DemoblogDb)
    migrations =
      migrationStep "Add user and post tables" V0001.migration >>>
      migrationStep "Add field created_at to user table" migration

createPost content userId =
  BeamExtensions.runInsertReturningList (_post db) $
  insertExpressions
    [Post default_ (val_ content) (UserId $ fromIntegral userId)]
-- Couldn't match type ‘UserT’
--                 with ‘V0001.UserT’
-- NB: ‘V0001.UserT’ is defined at
--       V0001CreateUserAndPostTables.hs:(18,1)-(21,32)
--     ‘UserT’ is defined at
--       V0002AddCreatedAtColumnForUser.hs:(35,1)-(39,32)
-- Expected type: PrimaryKey
--                   V0001.UserT
--                   (QExpr Database.Beam.Postgres.Syntax.PgExpressionSyntax s')
--   Actual type: PrimaryKey
--                   UserT (QExpr Database.Beam.Postgres.Syntax.PgExpressionSyntax s')