module Squeal.PostgreSQL.Migration
(
Migration (..)
, migrateUp
, migrateDown
, AlignedList (..)
, single
, MigrationsTable
, createMigrations
, insertMigration
, deleteMigration
, selectMigration
) where
import Control.Category
import Control.Monad
import Control.Monad.Base
import Control.Monad.Trans.Control
import Data.Monoid
import Generics.SOP (K(..))
import Data.Function ((&))
import Data.Text (Text)
import Prelude hiding (id, (.))
import Squeal.PostgreSQL
data Migration io schema0 schema1 = Migration
{ name :: Text
, up :: PQ schema0 schema1 io ()
, down :: PQ schema1 schema0 io ()
}
data AlignedList p x0 x1 where
Done :: AlignedList p x x
(:>>) :: p x0 x1 -> AlignedList p x1 x2 -> AlignedList p x0 x2
infixr 7 :>>
instance Category (AlignedList p) where
id = Done
(.) list = \case
Done -> list
step :>> steps -> step :>> (steps >>> list)
single :: p x0 x1 -> AlignedList p x0 x1
single step = step :>> Done
migrateUp
:: MonadBaseControl IO io
=> AlignedList (Migration io) schema0 schema1
-> PQ
("schema_migrations" ::: MigrationsTable ': schema0)
("schema_migrations" ::: MigrationsTable ': schema1)
io ()
migrateUp migration =
define createMigrations
& pqBind okResult
& pqThen (transactionallySchema_ (upMigrations migration))
where
upMigrations
:: MonadBaseControl IO io
=> AlignedList (Migration io) schema0 schema1
-> PQ
("schema_migrations" ::: MigrationsTable ': schema0)
("schema_migrations" ::: MigrationsTable ': schema1)
io ()
upMigrations = \case
Done -> return ()
step :>> steps -> upMigration step & pqThen (upMigrations steps)
upMigration
:: MonadBase IO io
=> Migration io schema0 schema1 -> PQ
("schema_migrations" ::: MigrationsTable ': schema0)
("schema_migrations" ::: MigrationsTable ': schema1)
io ()
upMigration step =
queryExecuted step
& pqBind (\ executed ->
if executed == 1
then PQ (\ _ -> return (K ()))
else
pqEmbed (up step)
& pqThen (manipulateParams insertMigration (Only (name step)))
& pqBind okResult)
queryExecuted
:: MonadBase IO io
=> Migration io schema0 schema1 -> PQ
("schema_migrations" ::: MigrationsTable ': schema0)
("schema_migrations" ::: MigrationsTable ': schema0)
io Row
queryExecuted step = do
result <- runQueryParams selectMigration (Only (name step))
okResult result
ntuples result
migrateDown
:: MonadBaseControl IO io
=> AlignedList (Migration io) schema0 schema1
-> PQ
("schema_migrations" ::: MigrationsTable ': schema1)
("schema_migrations" ::: MigrationsTable ': schema0)
io ()
migrateDown migrations =
define createMigrations
& pqBind okResult
& pqThen (transactionallySchema_ (downMigrations migrations))
where
downMigrations
:: MonadBaseControl IO io
=> AlignedList (Migration io) schema0 schema1 -> PQ
("schema_migrations" ::: MigrationsTable ': schema1)
("schema_migrations" ::: MigrationsTable ': schema0)
io ()
downMigrations = \case
Done -> return ()
step :>> steps -> downMigrations steps & pqThen (downMigration step)
downMigration
:: MonadBase IO io
=> Migration io schema0 schema1 -> PQ
("schema_migrations" ::: MigrationsTable ': schema1)
("schema_migrations" ::: MigrationsTable ': schema0)
io ()
downMigration step =
queryExecuted step
& pqBind (\ executed ->
if executed == 0
then PQ (\ _ -> return (K ()))
else
pqEmbed (down step)
& pqThen (manipulateParams deleteMigration (Only (name step)))
& pqBind okResult)
queryExecuted
:: MonadBase IO io
=> Migration io schema0 schema1 -> PQ
("schema_migrations" ::: MigrationsTable ': schema1)
("schema_migrations" ::: MigrationsTable ': schema1)
io Row
queryExecuted step = do
result <- runQueryParams selectMigration (Only (name step))
okResult result
ntuples result
okResult :: MonadBase IO io => K Result results -> PQ schema schema io ()
okResult result = do
status <- resultStatus result
when (not (status `elem` [CommandOk, TuplesOk])) $ do
errorMessageMaybe <- resultErrorMessage result
case errorMessageMaybe of
Nothing -> error "migrateDown: unknown error"
Just msg -> error ("migrationDown: " <> show msg)
type MigrationsTable =
'[ "migrations_unique_name" ::: 'Unique '["name"]] :=>
'[ "name" ::: 'NoDef :=> 'NotNull 'PGtext
, "executed_at" ::: 'Def :=> 'NotNull 'PGtimestamptz
]
createMigrations
:: Has "schema_migrations" schema MigrationsTable
=> Definition schema schema
createMigrations =
createTableIfNotExists #schema_migrations
( (text & notNull) `As` #name :*
(timestampWithTimeZone & notNull & default_ currentTimestamp)
`As` #executed_at :* Nil )
( unique (Column #name :* Nil) `As` #migrations_unique_name :* Nil )
insertMigration
:: Has "schema_migrations" schema MigrationsTable
=> Manipulation schema '[ 'NotNull 'PGtext] '[]
insertMigration = insertRow_ #schema_migrations
( Set (param @1) `As` #name :*
Default `As` #executed_at :* Nil )
deleteMigration
:: Has "schema_migrations" schema MigrationsTable
=> Manipulation schema '[ 'NotNull 'PGtext ] '[]
deleteMigration = deleteFrom_ #schema_migrations (#name .== param @1)
selectMigration
:: Has "schema_migrations" schema MigrationsTable
=> Query schema '[ 'NotNull 'PGtext ]
'[ "executed_at" ::: 'NotNull 'PGtimestamptz ]
selectMigration = select
(#executed_at `As` #executed_at :* Nil)
( from (table (#schema_migrations `As` #m))
& where_ (#name .== param @1))