{-# 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(..))

-- | Migration information stored in 'migration' table.
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

-- | Exception happened running migrations.
data MigrationError =
    -- | The migration with the given ID has been modified in the
    -- program code since it was applied. Since this can have very
    -- unpredictable effects it is considered an error.
    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

-- | Context for migrations.
data MigrationContext = MigrationContext { MigrationContext -> QIdentifier
mcMetaMigrationTable :: QIdentifier
                                         , MigrationContext -> QIdentifier
mcMigrationTable :: QIdentifier
                                         }

-- | Parameter wrapper for a query. Used in when there are several
-- sets of parameters which must have the same type.
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

-- | Apply a list of migrations to a database. For example,
--
-- > migrate conn schema [("a", "CREATE TABLE ...", QP $ Only $ Table schema "foo")]
-- >                     [("b", "INSERT INTO TABLE ...", QP $ (Table schema "foo", "bar"))]
--
-- will apply the given SQL statements __in order__ and track them by
-- the identifiers "a" and "b". It is recommended to use __fixed__,
-- randomly generated UUIDs to identify migrations, though you are
-- free to use whatever identifiers you like as long as they are
-- unique within the given schema. For example, on a Linux system you
-- can run the command `uuidgen -r` on the command line and paste that
-- into your migration list.
--
-- If the parameter sets are all of the same "shape" (type), then the
-- `P $` prefix may be omitted — it serves only to make sure that
-- the types match up.
--
-- The given 'Schema' parameter indicates the schema used for the
-- /metadata/ stored to track which migrations have been applied. It
-- does not affect the migrations themselves in any way. Therefore,
-- __ALL__ migrations should __ALWAYS__ specify their schema
-- explicitly in the SQL.
--
-- Any migrations that have already been applied will be skipped. If
-- the SQL text for any given migration /changes/, a
-- 'MigrationModifiedError' exception will be thrown.
--
-- Migrations are tracked using two tables, namely
-- "@\__peregrin_migration_meta\__@" and "@\__peregrin_migration\__@",
-- which will automatically be created in the given 'Schema'.
--
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
  -- Must always create the "migration_meta" table (and its
  -- schema) if necessary. Having just created this table without
  -- any rows represents "version 0" of the metadata data
  -- structures. These operations are idempotent and so we don't
  -- need any lock.
  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)
  -- Apply meta-migrations.
  IO () -> IO ()
forall a. IO a -> IO a
withLock (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    -- Apply meta-migrations; these are hardcoded for obvious reasons.
    -- EXCEPT for the very first migration, NO changes may be made to
    -- the "migration_meta" table in any migration here. This is to
    -- ensure 'perpetual' compatibility.
    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))
                  ]
  -- Apply all the migrations; we do it one-by-one since our lock is
  -- itself automatically released by PostgreSQL at the end of each of
  -- each transaction.
  [(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
      -- Subsitute parameters
      ByteString
sql <- Connection -> Query -> p -> IO ByteString
forall q. ToRow q => Connection -> Query -> q -> IO ByteString
formatQuery Connection
c Query
q p
p
      -- Check if change set has already been applied
      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

    -- Tables
    migrationTable :: QIdentifier
migrationTable = MigrationContext -> QIdentifier
mcMigrationTable MigrationContext
tables
    metaTable :: QIdentifier
metaTable = MigrationContext -> QIdentifier
mcMetaMigrationTable MigrationContext
tables

    -- Apply a meta-migration.
    metaMigrate :: ToRow a => Int32 -> [(Query, a)] -> IO ()
    metaMigrate :: Int32 -> [(Query, a)] -> IO ()
metaMigrate Int32
metaVersion [(Query, a)]
sqls = do
      -- Get the meta-version; defaults to 0 if we've only just
      -- created the metadata table.
      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)
      -- If the migration is applicable, then we apply it.
      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!"

    -- Shorthand:
    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

    -- Perform a transaction with the exclusive lock held. The lock is
    -- automatically released when the transaction ends.
    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

    -- Support SQL:
    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 (?, ?)"