{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
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 :: RowParser Migration
fromRow = Text -> ByteString -> Migration
Migration (Text -> ByteString -> Migration)
-> RowParser Text -> RowParser (ByteString -> Migration)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RowParser Text
forall a. FromField a => RowParser a
field RowParser (ByteString -> Migration)
-> RowParser ByteString -> RowParser Migration
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RowParser ByteString
forall a. FromField a => RowParser a
field
data MigrationError =
MigrationModifiedError Text
deriving (Int -> MigrationError -> ShowS
[MigrationError] -> ShowS
MigrationError -> String
(Int -> MigrationError -> ShowS)
-> (MigrationError -> String)
-> ([MigrationError] -> ShowS)
-> Show MigrationError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MigrationError] -> ShowS
$cshowList :: [MigrationError] -> ShowS
show :: MigrationError -> String
$cshow :: MigrationError -> String
showsPrec :: Int -> MigrationError -> ShowS
$cshowsPrec :: Int -> MigrationError -> ShowS
Show, MigrationError -> MigrationError -> Bool
(MigrationError -> MigrationError -> Bool)
-> (MigrationError -> MigrationError -> Bool) -> Eq MigrationError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MigrationError -> MigrationError -> Bool
$c/= :: MigrationError -> MigrationError -> Bool
== :: MigrationError -> MigrationError -> Bool
$c== :: MigrationError -> MigrationError -> Bool
Eq)
instance Exception MigrationError
data MigrationContext = MigrationContext { MigrationContext -> QIdentifier
mcMetaMigrationTable :: QIdentifier
, MigrationContext -> QIdentifier
mcMigrationTable :: QIdentifier
}
data QP = forall p . ToRow p => QP p
instance ToRow QP where
toRow :: QP -> [Action]
toRow (QP p
qp) = p -> [Action]
forall a. ToRow a => a -> [Action]
toRow p
qp
migrate :: ToRow p => Connection -> Schema -> [(Text, Query, p)] -> IO ()
migrate :: Connection -> Schema -> [(Text, Query, p)] -> IO ()
migrate Connection
connection Schema
schema =
MigrationContext
-> Connection -> Schema -> [(Text, Query, p)] -> IO ()
forall p.
ToRow p =>
MigrationContext
-> Connection -> Schema -> [(Text, Query, p)] -> IO ()
migrate' MigrationContext
tables Connection
connection Schema
schema
where
tables :: MigrationContext
tables = MigrationContext :: QIdentifier -> QIdentifier -> MigrationContext
MigrationContext { mcMetaMigrationTable :: QIdentifier
mcMetaMigrationTable = Schema -> Text -> QIdentifier
QIdentifier Schema
schema Text
"__peregrin_migration_meta__"
, mcMigrationTable :: QIdentifier
mcMigrationTable = Schema -> Text -> QIdentifier
QIdentifier Schema
schema Text
"__peregrin_migration__"
}
migrate' :: ToRow p => MigrationContext -> Connection -> Schema -> [(Text, Query, p)] -> IO ()
migrate' :: MigrationContext
-> Connection -> Schema -> [(Text, Query, p)] -> IO ()
migrate' MigrationContext
tables Connection
c Schema
schema [(Text, Query, p)]
migrations = do
IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int64 -> IO ()) -> IO Int64 -> IO ()
forall a b. (a -> b) -> a -> b
$ IO Int64 -> IO Int64
forall a. IO a -> IO a
transact (IO Int64 -> IO Int64) -> IO Int64 -> IO Int64
forall a b. (a -> b) -> a -> b
$ Query -> Only Schema -> IO Int64
forall a. ToRow a => Query -> a -> IO Int64
execute Query
sqlCreateSchema (Schema -> Only Schema
forall a. a -> Only a
Only Schema
schema)
IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int64 -> IO ()) -> IO Int64 -> IO ()
forall a b. (a -> b) -> a -> b
$ IO Int64 -> IO Int64
forall a. IO a -> IO a
transact (IO Int64 -> IO Int64) -> IO Int64 -> IO Int64
forall a b. (a -> b) -> a -> b
$ Query -> Only QIdentifier -> IO Int64
forall a. ToRow a => Query -> a -> IO Int64
execute Query
sqlCreateMetaTbl (QIdentifier -> Only QIdentifier
forall a. a -> Only a
Only QIdentifier
metaTable)
IO () -> IO ()
forall a. IO a -> IO a
withLock (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Int32 -> [(Query, Only QIdentifier)] -> IO ()
forall a. ToRow a => Int32 -> [(Query, a)] -> IO ()
metaMigrate Int32
1 [ (Query
sqlInsertMetaVersion0, (QIdentifier -> Only QIdentifier
forall a. a -> Only a
Only QIdentifier
metaTable))
, (Query
sqlCreateMigrationTbl, (QIdentifier -> Only QIdentifier
forall a. a -> Only a
Only QIdentifier
migrationTable))
]
[(Text, Query, p)] -> ((Text, Query, p) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Text, Query, p)]
migrations (((Text, Query, p) -> IO ()) -> IO ())
-> ((Text, Query, p) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Text
mid, Query
q, p
p) ->
IO () -> IO ()
forall a. IO a -> IO a
withLock (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
ByteString
sql <- Connection -> Query -> p -> IO ByteString
forall q. ToRow q => Connection -> Query -> q -> IO ByteString
formatQuery Connection
c Query
q p
p
Maybe Migration
existingMigration :: (Maybe Migration) <-
[Migration] -> Maybe Migration
forall a. [a] -> Maybe a
listToMaybe ([Migration] -> Maybe Migration)
-> IO [Migration] -> IO (Maybe Migration)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Query -> (QIdentifier, Text) -> IO [Migration]
forall a r. (ToRow a, FromRow r) => Query -> a -> IO [r]
query Query
sqlFindMigration ( QIdentifier
migrationTable
, Text
mid
)
case Maybe Migration
existingMigration of
Just (Migration Text
_ ByteString
sql') | ByteString
sql ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
sql' ->
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Migration
_ ->
MigrationError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (MigrationError -> IO ()) -> MigrationError -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> MigrationError
MigrationModifiedError Text
mid
Maybe Migration
Nothing -> do
IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int64 -> IO ()) -> IO Int64 -> IO ()
forall a b. (a -> b) -> a -> b
$ Query -> (QIdentifier, Text, ByteString) -> IO Int64
forall a. ToRow a => Query -> a -> IO Int64
execute Query
sqlInsertMigration ( QIdentifier
migrationTable
, Text
mid
, ByteString
sql
)
IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int64 -> IO ()) -> IO Int64 -> IO ()
forall a b. (a -> b) -> a -> b
$ Query -> IO Int64
execute_ (Query -> IO Int64) -> Query -> IO Int64
forall a b. (a -> b) -> a -> b
$ ByteString -> Query
Query ByteString
sql
where
migrationTable :: QIdentifier
migrationTable = MigrationContext -> QIdentifier
mcMigrationTable MigrationContext
tables
metaTable :: QIdentifier
metaTable = MigrationContext -> QIdentifier
mcMetaMigrationTable MigrationContext
tables
metaMigrate :: ToRow a => Int32 -> [(Query, a)] -> IO ()
metaMigrate :: Int32 -> [(Query, a)] -> IO ()
metaMigrate Int32
metaVersion [(Query, a)]
sqls = do
Only Int32
currentMetaVersion <- Only Int32 -> Maybe (Only Int32) -> Only Int32
forall a. a -> Maybe a -> a
fromMaybe (Int32 -> Only Int32
forall a. a -> Only a
Only Int32
0) (Maybe (Only Int32) -> Only Int32)
-> IO (Maybe (Only Int32)) -> IO (Only Int32)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
([Only Int32] -> Maybe (Only Int32))
-> IO [Only Int32] -> IO (Maybe (Only Int32))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Only Int32] -> Maybe (Only Int32)
forall a. [a] -> Maybe a
listToMaybe (Query -> Only QIdentifier -> IO [Only Int32]
forall a r. (ToRow a, FromRow r) => Query -> a -> IO [r]
query Query
sqlGetMetaVersion (Only QIdentifier -> IO [Only Int32])
-> Only QIdentifier -> IO [Only Int32]
forall a b. (a -> b) -> a -> b
$ QIdentifier -> Only QIdentifier
forall a. a -> Only a
Only QIdentifier
metaTable)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int32
currentMetaVersion Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
1 Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
== Int32
metaVersion) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
[(Query, a)] -> ((Query, a) -> IO Int64) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Query, a)]
sqls (((Query, a) -> IO Int64) -> IO ())
-> ((Query, a) -> IO Int64) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Query
q, a
ps) -> Query -> a -> IO Int64
forall a. ToRow a => Query -> a -> IO Int64
execute Query
q a
ps
Int64
rowCount <- Query -> (QIdentifier, Int32, Int32) -> IO Int64
forall a. ToRow a => Query -> a -> IO Int64
execute Query
sqlUpdateMetaVersion ( QIdentifier
metaTable
, Int32
metaVersion
, Int32
currentMetaVersion
)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int64
rowCount Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Int64
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Unexpected row count " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int64 -> String
forall a. Show a => a -> String
show Int64
rowCount String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" from update on \"migration_meta\" table!"
transact :: IO a -> IO a
transact = IsolationLevel -> Connection -> IO a -> IO a
forall a. IsolationLevel -> Connection -> IO a -> IO a
withTransactionLevel IsolationLevel
ReadCommitted Connection
c
execute :: ToRow a => Query -> a -> IO Int64
execute :: Query -> a -> IO Int64
execute = Connection -> Query -> a -> IO Int64
forall q. ToRow q => Connection -> Query -> q -> IO Int64
P.execute Connection
c
execute_ :: Query -> IO Int64
execute_ :: Query -> IO Int64
execute_ = Connection -> Query -> IO Int64
P.execute_ Connection
c
query :: (ToRow a, FromRow r) => Query -> a -> IO [r]
query :: Query -> a -> IO [r]
query = Connection -> Query -> a -> IO [r]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
P.query Connection
c
withLock :: IO a -> IO a
withLock IO a
txn =
IO a -> IO a
forall a. IO a -> IO a
transact (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int64 -> IO ()) -> IO Int64 -> IO ()
forall a b. (a -> b) -> a -> b
$ Query -> [QIdentifier] -> IO Int64
forall a. ToRow a => Query -> a -> IO Int64
execute Query
sqlLockMetaTbl [QIdentifier
metaTable]
IO a
txn
sqlCreateSchema :: Query
sqlCreateSchema =
Query
"CREATE SCHEMA IF NOT EXISTS ?"
sqlCreateMetaTbl :: Query
sqlCreateMetaTbl =
Query
"CREATE TABLE IF NOT EXISTS ? (\
\ \"meta_version\" INTEGER PRIMARY KEY\
\)"
sqlGetMetaVersion :: Query
sqlGetMetaVersion =
Query
"SELECT \"meta_version\" FROM ?"
sqlUpdateMetaVersion :: Query
sqlUpdateMetaVersion =
Query
"UPDATE ? \
\ SET \"meta_version\" = ? \
\ WHERE \"meta_version\" = ?"
sqlLockMetaTbl :: Query
sqlLockMetaTbl =
Query
"LOCK TABLE ? IN ACCESS EXCLUSIVE MODE"
sqlInsertMetaVersion0 :: Query
sqlInsertMetaVersion0 =
Query
"INSERT INTO ? (\"meta_version\") VALUES (0)"
sqlCreateMigrationTbl :: Query
sqlCreateMigrationTbl =
Query
"CREATE TABLE ? ( \
\ \"id\" TEXT PRIMARY KEY,\
\ \"sql\" TEXT NOT NULL\
\)"
sqlFindMigration :: Query
sqlFindMigration =
Query
"SELECT \"id\", \"sql\"\
\ FROM ? \
\ WHERE \"id\" = ?"
sqlInsertMigration :: Query
sqlInsertMigration =
Query
"INSERT INTO ? \
\ (\"id\", \"sql\") \
\ VALUES (?, ?)"