{-# LANGUAGE
DataKinds
, DeriveGeneric
, FlexibleContexts
, FlexibleInstances
, FunctionalDependencies
, GADTs
, LambdaCase
, MultiParamTypeClasses
, OverloadedLabels
, OverloadedStrings
, PolyKinds
, QuantifiedConstraints
, RankNTypes
, TypeApplications
, TypeOperators
#-}
module Squeal.PostgreSQL.Session.Migration
(
Migration (..)
, Migratory (..)
, migrate
, migrateUp
, migrateDown
, MigrationsTable
, mainMigrate
, mainMigrateIso
, IsoQ (..)
) where
import Control.Category
import Control.Category.Free
import Control.Monad
import Data.ByteString (ByteString)
import Data.Foldable (traverse_)
import Data.Function ((&))
import Data.List ((\\))
import Data.Quiver
import Data.Quiver.Functor
import Data.Text (Text)
import Data.Time (UTCTime)
import Prelude hiding ((.), id)
import System.Environment
import UnliftIO (MonadIO (..))
import qualified Data.Text.IO as Text (putStrLn)
import qualified Generics.SOP as SOP
import qualified GHC.Generics as GHC
import Squeal.PostgreSQL.Definition
import Squeal.PostgreSQL.Definition.Constraint
import Squeal.PostgreSQL.Definition.Table
import Squeal.PostgreSQL.Expression.Comparison
import Squeal.PostgreSQL.Expression.Default
import Squeal.PostgreSQL.Expression.Parameter
import Squeal.PostgreSQL.Expression.Time
import Squeal.PostgreSQL.Expression.Type
import Squeal.PostgreSQL.Manipulation
import Squeal.PostgreSQL.Manipulation.Delete
import Squeal.PostgreSQL.Manipulation.Insert
import Squeal.PostgreSQL.Session
import Squeal.PostgreSQL.Session.Decode
import Squeal.PostgreSQL.Session.Encode
import Squeal.PostgreSQL.Session.Indexed
import Squeal.PostgreSQL.Session.Monad
import Squeal.PostgreSQL.Session.Result
import Squeal.PostgreSQL.Session.Statement
import Squeal.PostgreSQL.Session.Transaction
import Squeal.PostgreSQL.Query.From
import Squeal.PostgreSQL.Query.Select
import Squeal.PostgreSQL.Query.Table
import Squeal.PostgreSQL.Type.Alias
import Squeal.PostgreSQL.Type.List
import Squeal.PostgreSQL.Type.Schema
data Migration def db0 db1 = Migration
{ name :: Text
, migration :: def db0 db1
} deriving (GHC.Generic)
instance QFunctor Migration where
qmap f (Migration n i) = Migration n (f i)
class (Category def, Category run) => Migratory def run | def -> run where
runMigrations :: Path (Migration def) db0 db1 -> run db0 db1
instance Migratory (Indexed PQ IO ()) (Indexed PQ IO ()) where
runMigrations path = Indexed . unsafePQ . transactionally_ $ do
define createMigrations
qtoMonoid upMigration path
where
upMigration step = do
executed <- do
result <- executeParams selectMigration (name step)
ntuples (result :: Result UTCTime)
unless (executed == 1) $ do
_ <- unsafePQ . runIndexed $ migration step
executeParams_ insertMigration (name step)
instance Migratory Definition (Indexed PQ IO ()) where
runMigrations = runMigrations . qmap (qmap ixDefine)
instance Migratory (OpQ (Indexed PQ IO ())) (OpQ (Indexed PQ IO ())) where
runMigrations path = OpQ . Indexed . unsafePQ . transactionally_ $ do
define createMigrations
qtoMonoid @FoldPath downMigration (reversePath path)
where
downMigration (OpQ step) = do
executed <- do
result <- executeParams selectMigration (name step)
ntuples (result :: Result UTCTime)
unless (executed == 0) $ do
_ <- unsafePQ . runIndexed . getOpQ $ migration step
executeParams_ deleteMigration (name step)
instance Migratory (OpQ Definition) (OpQ (Indexed PQ IO ())) where
runMigrations = runMigrations . qmap (qmap (qmap ixDefine))
instance Migratory
(IsoQ (Indexed PQ IO ()))
(IsoQ (Indexed PQ IO ())) where
runMigrations path = IsoQ
(runMigrations (qmap (qmap up) path))
(getOpQ (runMigrations (qmap (qmap (OpQ . down)) path)))
instance Migratory (IsoQ Definition) (IsoQ (Indexed PQ IO ())) where
runMigrations = runMigrations . qmap (qmap (qmap ixDefine))
unsafePQ :: (Functor m) => PQ db0 db1 m x -> PQ db0' db1' m x
unsafePQ (PQ pq) = PQ $ fmap (SOP.K . SOP.unK) . pq . SOP.K . SOP.unK
migrate
:: Migratory def (Indexed PQ IO ())
=> Path (Migration def) db0 db1
-> PQ db0 db1 IO ()
migrate = runIndexed . runMigrations
migrateUp
:: Migratory def (IsoQ (Indexed PQ IO ()))
=> Path (Migration def) db0 db1
-> PQ db0 db1 IO ()
migrateUp = runIndexed . up . runMigrations
migrateDown
:: Migratory def (IsoQ (Indexed PQ IO ()))
=> Path (Migration def) db0 db1
-> PQ db1 db0 IO ()
migrateDown = runIndexed . down . runMigrations
ixDefine :: Definition db0 db1 -> Indexed PQ IO () db0 db1
ixDefine = indexedDefine
type MigrationsTable =
'[ "migrations_unique_name" ::: 'Unique '["name"]] :=>
'[ "name" ::: 'NoDef :=> 'NotNull 'PGtext
, "executed_at" ::: 'Def :=> 'NotNull 'PGtimestamptz
]
data MigrationRow =
MigrationRow { migrationName :: Text
, migrationTime :: UTCTime }
deriving (GHC.Generic, Show)
instance SOP.Generic MigrationRow
instance SOP.HasDatatypeInfo MigrationRow
type MigrationsSchema = '["schema_migrations" ::: 'Table MigrationsTable]
type MigrationsSchemas = Public MigrationsSchema
createMigrations :: Definition MigrationsSchemas MigrationsSchemas
createMigrations =
createTableIfNotExists #schema_migrations
( (text & notNullable) `as` #name :*
(timestampWithTimeZone & notNullable & default_ currentTimestamp)
`as` #executed_at )
( unique #name `as` #migrations_unique_name )
insertMigration :: Statement MigrationsSchemas Text ()
insertMigration = Manipulation aParam genericRow $
insertInto_ #schema_migrations $
Values_ (Set (param @1) `as` #name :* Default `as` #executed_at)
deleteMigration :: Statement MigrationsSchemas Text ()
deleteMigration = Manipulation aParam genericRow $
deleteFrom_ #schema_migrations (#name .== param @1)
selectMigration :: Statement MigrationsSchemas Text UTCTime
selectMigration = Query aParam #executed_at $
select_ #executed_at
$ from (table (#schema_migrations))
& where_ (#name .== param @1)
selectMigrations :: Statement MigrationsSchemas () MigrationRow
selectMigrations = query $
select_ (#name `as` #migrationName :* #executed_at `as` #migrationTime)
(from (table #schema_migrations))
mainMigrate
:: Migratory p (Indexed PQ IO ())
=> ByteString
-> Path (Migration p) db0 db1
-> IO ()
mainMigrate connectTo migrations = do
command <- getArgs
performCommand command
where
performCommand :: [String] -> IO ()
performCommand = \case
["status"] -> withConnection connectTo $
suppressNotices >> migrateStatus
["migrate"] -> withConnection connectTo $
suppressNotices
& pqThen (runIndexed (runMigrations migrations))
& pqThen migrateStatus
args -> displayUsage args
migrateStatus :: PQ schema schema IO ()
migrateStatus = unsafePQ $ do
runNames <- getRunMigrationNames
let names = qtoList name migrations
unrunNames = names \\ runNames
liftIO $ displayRunned runNames >> displayUnrunned unrunNames
suppressNotices :: PQ schema schema IO ()
suppressNotices = manipulate_ $
UnsafeManipulation "SET client_min_messages TO WARNING;"
displayUsage :: [String] -> IO ()
displayUsage args = do
putStrLn $ "Invalid command: \"" <> unwords args <> "\". Use:"
putStrLn "migrate to run all available migrations"
putStrLn "rollback to rollback all available migrations"
mainMigrateIso
:: Migratory (IsoQ def) (IsoQ (Indexed PQ IO ()))
=> ByteString
-> Path (Migration (IsoQ def)) db0 db1
-> IO ()
mainMigrateIso connectTo migrations = performCommand =<< getArgs
where
performCommand :: [String] -> IO ()
performCommand = \case
["status"] -> withConnection connectTo $
suppressNotices >> migrateStatus
["migrate"] -> withConnection connectTo $
suppressNotices
& pqThen (migrateUp migrations)
& pqThen migrateStatus
["rollback"] -> withConnection connectTo $
suppressNotices
& pqThen (migrateDown migrations)
& pqThen migrateStatus
args -> displayUsage args
migrateStatus :: PQ schema schema IO ()
migrateStatus = unsafePQ $ do
runNames <- getRunMigrationNames
let names = qtoList name migrations
unrunNames = names \\ runNames
liftIO $ displayRunned runNames >> displayUnrunned unrunNames
suppressNotices :: PQ schema schema IO ()
suppressNotices = manipulate_ $
UnsafeManipulation "SET client_min_messages TO WARNING;"
displayUsage :: [String] -> IO ()
displayUsage args = do
putStrLn $ "Invalid command: \"" <> unwords args <> "\". Use:"
putStrLn "migrate to run all available migrations"
putStrLn "rollback to rollback all available migrations"
putStrLn "status to display migrations run and migrations left to run"
getRunMigrationNames :: PQ db0 db0 IO [Text]
getRunMigrationNames =
fmap migrationName <$>
(unsafePQ (define createMigrations
& pqThen (execute selectMigrations)) >>= getRows)
displayListOfNames :: [Text] -> IO ()
displayListOfNames [] = Text.putStrLn " None"
displayListOfNames xs =
let singleName n = Text.putStrLn $ " - " <> n
in traverse_ singleName xs
displayUnrunned :: [Text] -> IO ()
displayUnrunned unrunned =
Text.putStrLn "Migrations left to run:"
>> displayListOfNames unrunned
displayRunned :: [Text] -> IO ()
displayRunned runned =
Text.putStrLn "Migrations already run:"
>> displayListOfNames runned