module Database.Peregrin
( migrate
, MigrationError(..)
, QP(..)
) where
import Control.Applicative ((<$>))
import Control.Exception (Exception, throwIO)
import Control.Monad (forM_, when, void)
import Data.ByteString (ByteString)
import Data.Text (Text)
import Data.Int (Int32, Int64)
import Data.Maybe (listToMaybe, fromMaybe)
import Database.Peregrin.Metadata
import Database.PostgreSQL.Simple (Connection, Only(..), formatQuery)
import qualified Database.PostgreSQL.Simple as P
import Database.PostgreSQL.Simple.ToRow (ToRow(..))
import Database.PostgreSQL.Simple.Types (Query(..))
import Database.PostgreSQL.Simple.FromRow (FromRow(..), field)
import Database.PostgreSQL.Simple.Transaction (withTransactionLevel, IsolationLevel(..))
data Migration = Migration Text ByteString
instance FromRow Migration where
fromRow = Migration <$> field <*> field
data MigrationError =
MigrationModifiedError Text
deriving (Show, Eq)
instance Exception MigrationError
data MigrationContext = MigrationContext { mcMetaMigrationTable :: QIdentifier
, mcMigrationTable :: QIdentifier
}
data QP = forall p . ToRow p => QP p
instance ToRow QP where
toRow (QP qp) = toRow qp
migrate :: ToRow p => Connection -> Schema -> [(Text, Query, p)] -> IO ()
migrate connection schema =
migrate' tables connection schema
where
tables = MigrationContext { mcMetaMigrationTable = QIdentifier schema "__peregrin_migration_meta__"
, mcMigrationTable = QIdentifier schema "__peregrin_migration__"
}
migrate' :: ToRow p => MigrationContext -> Connection -> Schema -> [(Text, Query, p)] -> IO ()
migrate' tables c schema migrations = do
void $ transact $ execute sqlCreateSchema (Only schema)
void $ transact $ execute sqlCreateMetaTbl (Only metaTable)
withLock $
metaMigrate 1 [ (sqlInsertMetaVersion0, (Only metaTable))
, (sqlCreateMigrationTbl, (Only migrationTable))
]
forM_ migrations $ \(mid, q, p) ->
withLock $ do
sql <- formatQuery c q p
existingMigration :: (Maybe Migration) <-
listToMaybe <$> query sqlFindMigration ( migrationTable
, mid
)
case existingMigration of
Just (Migration _ sql') | sql == sql' ->
return ()
Just _ ->
throwIO $ MigrationModifiedError mid
Nothing -> do
void $ execute sqlInsertMigration ( migrationTable
, mid
, sql
)
void $ execute_ $ Query sql
where
migrationTable = mcMigrationTable tables
metaTable = mcMetaMigrationTable tables
metaMigrate :: ToRow a => Int32 -> [(Query, a)] -> IO ()
metaMigrate metaVersion sqls = do
Only currentMetaVersion <- fromMaybe (Only 0) <$>
fmap listToMaybe (query sqlGetMetaVersion $ Only metaTable)
when (currentMetaVersion + 1 == metaVersion) $ do
forM_ sqls $ \(q, ps) -> execute q ps
rowCount <- execute sqlUpdateMetaVersion ( metaTable
, metaVersion
, currentMetaVersion
)
when (rowCount /= 1) $ error $ "Unexpected row count " ++ show rowCount ++ " from update on \"migration_meta\" table!"
transact = withTransactionLevel ReadCommitted c
execute :: ToRow a => Query -> a -> IO Int64
execute = P.execute c
execute_ :: Query -> IO Int64
execute_ = P.execute_ c
query :: (ToRow a, FromRow r) => Query -> a -> IO [r]
query = P.query c
withLock txn =
transact $ do
void $ execute sqlLockMetaTbl [metaTable]
txn
sqlCreateSchema =
"CREATE SCHEMA IF NOT EXISTS ?"
sqlCreateMetaTbl =
"CREATE TABLE IF NOT EXISTS ? (\
\ \"meta_version\" INTEGER PRIMARY KEY\
\)"
sqlGetMetaVersion =
"SELECT \"meta_version\" FROM ?"
sqlUpdateMetaVersion =
"UPDATE ? \
\ SET \"meta_version\" = ? \
\ WHERE \"meta_version\" = ?"
sqlLockMetaTbl =
"LOCK TABLE ? IN ACCESS EXCLUSIVE MODE"
sqlInsertMetaVersion0 =
"INSERT INTO ? (\"meta_version\") VALUES (0)"
sqlCreateMigrationTbl =
"CREATE TABLE ? ( \
\ \"id\" TEXT PRIMARY KEY,\
\ \"sql\" TEXT NOT NULL\
\)"
sqlFindMigration =
"SELECT \"id\", \"sql\"\
\ FROM ? \
\ WHERE \"id\" = ?"
sqlInsertMigration =
"INSERT INTO ? \
\ (\"id\", \"sql\") \
\ VALUES (?, ?)"