{-|
Module      :  Database.Persist.Migration.Postgres
Maintainer  :  Brandon Chinn <brandonchinn178@gmail.com>
Stability   :  experimental
Portability :  portable

Defines the migration backend for PostgreSQL.
-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}

module Database.Persist.Migration.Postgres
  ( backend
  , getMigration
  , runMigration
  ) where

import Data.Maybe (maybeToList)
import Data.Text (Text)
import qualified Data.Text as Text
import Database.Persist.Migration
import qualified Database.Persist.Migration.Core as Migration
import Database.Persist.Sql (SqlPersistT)

-- | Run a migration with the Postgres backend.
runMigration :: MigrateSettings -> Migration -> SqlPersistT IO ()
runMigration :: MigrateSettings -> Migration -> SqlPersistT IO ()
runMigration = MigrateBackend -> MigrateSettings -> Migration -> SqlPersistT IO ()
forall (m :: * -> *).
MonadIO m =>
MigrateBackend -> MigrateSettings -> Migration -> SqlPersistT m ()
Migration.runMigration MigrateBackend
backend

-- | Get a migration with the Postgres backend.
getMigration :: MigrateSettings -> Migration -> SqlPersistT IO [MigrateSql]
getMigration :: MigrateSettings -> Migration -> SqlPersistT IO [MigrateSql]
getMigration = MigrateBackend
-> MigrateSettings -> Migration -> SqlPersistT IO [MigrateSql]
forall (m :: * -> *).
MonadIO m =>
MigrateBackend
-> MigrateSettings -> Migration -> SqlPersistT m [MigrateSql]
Migration.getMigration MigrateBackend
backend

-- | The migration backend for Postgres.
backend :: MigrateBackend
backend :: MigrateBackend
backend = MigrateBackend :: (Operation -> SqlPersistT IO [MigrateSql]) -> MigrateBackend
MigrateBackend
  { getMigrationSql :: Operation -> SqlPersistT IO [MigrateSql]
getMigrationSql = Operation -> SqlPersistT IO [MigrateSql]
getMigrationSql'
  }

getMigrationSql' :: Operation -> SqlPersistT IO [MigrateSql]

getMigrationSql' :: Operation -> SqlPersistT IO [MigrateSql]
getMigrationSql' CreateTable{[TableConstraint]
[Column]
Text
constraints :: Operation -> [TableConstraint]
schema :: Operation -> [Column]
name :: Operation -> Text
constraints :: [TableConstraint]
schema :: [Column]
name :: Text
..} = MigrateSql -> SqlPersistT IO [MigrateSql]
forall (m :: * -> *). Monad m => MigrateSql -> m [MigrateSql]
fromMigrateSql (MigrateSql -> SqlPersistT IO [MigrateSql])
-> MigrateSql -> SqlPersistT IO [MigrateSql]
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> MigrateSql -> MigrateSql
mapSql
  (\Text
sql -> [Text] -> Text
Text.unwords [Text
"CREATE TABLE IF NOT EXISTS", Text -> Text
quote Text
name, Text
"(", Text
sql, Text
")"])
  (MigrateSql -> MigrateSql) -> MigrateSql -> MigrateSql
forall a b. (a -> b) -> a -> b
$ ([Text] -> Text) -> [MigrateSql] -> MigrateSql
concatSql [Text] -> Text
uncommas [MigrateSql]
tableDefs
  where
    tableDefs :: [MigrateSql]
tableDefs = (Column -> MigrateSql) -> [Column] -> [MigrateSql]
forall a b. (a -> b) -> [a] -> [b]
map Column -> MigrateSql
showColumn [Column]
schema [MigrateSql] -> [MigrateSql] -> [MigrateSql]
forall a. [a] -> [a] -> [a]
++ (TableConstraint -> MigrateSql)
-> [TableConstraint] -> [MigrateSql]
forall a b. (a -> b) -> [a] -> [b]
map TableConstraint -> MigrateSql
showTableConstraint [TableConstraint]
constraints

getMigrationSql' DropTable{Text
table :: Operation -> Text
table :: Text
..} = [Text] -> SqlPersistT IO [MigrateSql]
forall (m :: * -> *). Monad m => [Text] -> m [MigrateSql]
fromWords
  [Text
"DROP TABLE IF EXISTS", Text -> Text
quote Text
table]

getMigrationSql' RenameTable{Text
to :: Operation -> Text
from :: Operation -> Text
to :: Text
from :: Text
..} = [Text] -> SqlPersistT IO [MigrateSql]
forall (m :: * -> *). Monad m => [Text] -> m [MigrateSql]
fromWords
  [Text
"ALTER TABLE", Text -> Text
quote Text
from, Text
"RENAME TO", Text -> Text
quote Text
to]

getMigrationSql' AddConstraint{Text
TableConstraint
constraint :: Operation -> TableConstraint
constraint :: TableConstraint
table :: Text
table :: Operation -> Text
..} = [Text] -> SqlPersistT IO [MigrateSql]
forall (m :: * -> *). Monad m => [Text] -> m [MigrateSql]
fromWords
  [Text
"ALTER TABLE", Text -> Text
quote Text
table, Text
statement]
  where
    statement :: Text
statement = case TableConstraint
constraint of
      PrimaryKey [Text]
cols -> [Text] -> Text
Text.unwords [Text
"ADD PRIMARY KEY (", [Text] -> Text
uncommas' [Text]
cols, Text
")"]
      Unique Text
label [Text]
cols -> [Text] -> Text
Text.unwords
        [Text
"ADD CONSTRAINT", Text -> Text
quote Text
label, Text
"UNIQUE (", [Text] -> Text
uncommas' [Text]
cols, Text
")"]

getMigrationSql' DropConstraint{Text
constraintName :: Operation -> Text
constraintName :: Text
table :: Text
table :: Operation -> Text
..} = [Text] -> SqlPersistT IO [MigrateSql]
forall (m :: * -> *). Monad m => [Text] -> m [MigrateSql]
fromWords
  [Text
"ALTER TABLE", Text -> Text
quote Text
table, Text
"DROP CONSTRAINT", Text
constraintName]

getMigrationSql' AddColumn{Maybe PersistValue
Text
Column
colDefault :: Operation -> Maybe PersistValue
column :: Operation -> Column
colDefault :: Maybe PersistValue
column :: Column
table :: Text
table :: Operation -> Text
..} = [MigrateSql] -> SqlPersistT IO [MigrateSql]
forall (m :: * -> *) a. Monad m => a -> m a
return ([MigrateSql] -> SqlPersistT IO [MigrateSql])
-> [MigrateSql] -> SqlPersistT IO [MigrateSql]
forall a b. (a -> b) -> a -> b
$ MigrateSql
createQuery MigrateSql -> [MigrateSql] -> [MigrateSql]
forall a. a -> [a] -> [a]
: Maybe MigrateSql -> [MigrateSql]
forall a. Maybe a -> [a]
maybeToList Maybe MigrateSql
alterQuery
  where
    Column{[ColumnProp]
Text
SqlType
$sel:colProps:Column :: Column -> [ColumnProp]
$sel:colType:Column :: Column -> SqlType
$sel:colName:Column :: Column -> Text
colProps :: [ColumnProp]
colType :: SqlType
colName :: Text
..} = Column
column
    alterTable :: Text
alterTable = [Text] -> Text
Text.unwords [Text
"ALTER TABLE", Text -> Text
quote Text
table]
    -- The CREATE query with the default specified by AddColumn{colDefault}
    withoutDefault :: MigrateSql
withoutDefault = Column -> MigrateSql
showColumn (Column -> MigrateSql) -> Column -> MigrateSql
forall a b. (a -> b) -> a -> b
$ Column
column { $sel:colProps:Column :: [ColumnProp]
colProps = (ColumnProp -> Bool) -> [ColumnProp] -> [ColumnProp]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (ColumnProp -> Bool) -> ColumnProp -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ColumnProp -> Bool
isDefault) [ColumnProp]
colProps }
    createDefault :: MigrateSql
createDefault = case Maybe PersistValue
colDefault of
      Maybe PersistValue
Nothing -> Text -> [PersistValue] -> MigrateSql
MigrateSql Text
"" []
      Just PersistValue
def -> Text -> [PersistValue] -> MigrateSql
MigrateSql Text
"DEFAULT ?" [PersistValue
def]
    createQuery :: MigrateSql
createQuery = ([Text] -> Text) -> [MigrateSql] -> MigrateSql
concatSql
      (\[Text]
sqls -> [Text] -> Text
Text.unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text
alterTable, Text
"ADD COLUMN"] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
sqls)
      [MigrateSql
withoutDefault, MigrateSql
createDefault]
    -- The ALTER query to drop/set the default (if colDefault was set)
    alterQuery :: Maybe MigrateSql
alterQuery =
      let action :: MigrateSql
action = case [ColumnProp] -> Maybe PersistValue
getDefault [ColumnProp]
colProps of
            Maybe PersistValue
Nothing -> Text -> MigrateSql
pureSql Text
"DROP DEFAULT"
            Just PersistValue
v -> Text -> [PersistValue] -> MigrateSql
MigrateSql Text
"SET DEFAULT ?" [PersistValue
v]
          alterQuery' :: MigrateSql
alterQuery' = (Text -> Text) -> MigrateSql -> MigrateSql
mapSql
            (\Text
sql -> [Text] -> Text
Text.unwords [Text
alterTable, Text
"ALTER COLUMN", Text -> Text
quote Text
colName, Text
sql])
            MigrateSql
action
      in MigrateSql
alterQuery' MigrateSql -> Maybe PersistValue -> Maybe MigrateSql
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Maybe PersistValue
colDefault

getMigrationSql' RenameColumn{Text
to :: Text
from :: Text
table :: Text
to :: Operation -> Text
from :: Operation -> Text
table :: Operation -> Text
..} = [Text] -> SqlPersistT IO [MigrateSql]
forall (m :: * -> *). Monad m => [Text] -> m [MigrateSql]
fromWords
  [Text
"ALTER TABLE", Text -> Text
quote Text
table, Text
"RENAME COLUMN", Text -> Text
quote Text
from, Text
"TO", Text -> Text
quote Text
to]

getMigrationSql' DropColumn{ColumnIdentifier
columnId :: Operation -> ColumnIdentifier
columnId :: ColumnIdentifier
..} = [Text] -> SqlPersistT IO [MigrateSql]
forall (m :: * -> *). Monad m => [Text] -> m [MigrateSql]
fromWords
  [Text
"ALTER TABLE", Text -> Text
quote Text
tab, Text
"DROP COLUMN", Text -> Text
quote Text
col]
  where
    (Text
tab, Text
col) = ColumnIdentifier
columnId

getMigrationSql' RawOperation{Text
SqlPersistT IO [MigrateSql]
rawOp :: Operation -> SqlPersistT IO [MigrateSql]
message :: Operation -> Text
rawOp :: SqlPersistT IO [MigrateSql]
message :: Text
..} = SqlPersistT IO [MigrateSql]
rawOp

{- Helpers -}

fromMigrateSql :: Monad m => MigrateSql -> m [MigrateSql]
fromMigrateSql :: MigrateSql -> m [MigrateSql]
fromMigrateSql = [MigrateSql] -> m [MigrateSql]
forall (m :: * -> *) a. Monad m => a -> m a
return ([MigrateSql] -> m [MigrateSql])
-> (MigrateSql -> [MigrateSql]) -> MigrateSql -> m [MigrateSql]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MigrateSql -> [MigrateSql]
forall (f :: * -> *) a. Applicative f => a -> f a
pure

fromWords :: Monad m => [Text] -> m [MigrateSql]
fromWords :: [Text] -> m [MigrateSql]
fromWords = MigrateSql -> m [MigrateSql]
forall (m :: * -> *). Monad m => MigrateSql -> m [MigrateSql]
fromMigrateSql (MigrateSql -> m [MigrateSql])
-> ([Text] -> MigrateSql) -> [Text] -> m [MigrateSql]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> MigrateSql
pureSql (Text -> MigrateSql) -> ([Text] -> Text) -> [Text] -> MigrateSql
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
Text.unwords

-- | True if the given ColumnProp sets a default.
isDefault :: ColumnProp -> Bool
isDefault :: ColumnProp -> Bool
isDefault (Default PersistValue
_) = Bool
True
isDefault ColumnProp
_ = Bool
False

-- | Get the default value from the given ColumnProps.
getDefault :: [ColumnProp] -> Maybe PersistValue
getDefault :: [ColumnProp] -> Maybe PersistValue
getDefault [] = Maybe PersistValue
forall a. Maybe a
Nothing
getDefault (Default PersistValue
v : [ColumnProp]
_) = PersistValue -> Maybe PersistValue
forall a. a -> Maybe a
Just PersistValue
v
getDefault (ColumnProp
_:[ColumnProp]
props) = [ColumnProp] -> Maybe PersistValue
getDefault [ColumnProp]
props

-- | Show a 'Column'.
showColumn :: Column -> MigrateSql
showColumn :: Column -> MigrateSql
showColumn Column{[ColumnProp]
Text
SqlType
colProps :: [ColumnProp]
colType :: SqlType
colName :: Text
$sel:colProps:Column :: Column -> [ColumnProp]
$sel:colType:Column :: Column -> SqlType
$sel:colName:Column :: Column -> Text
..} = ([Text] -> Text) -> [MigrateSql] -> MigrateSql
concatSql
  (\[Text]
sqls -> [Text] -> Text
Text.unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text -> Text
quote Text
colName, Text
sqlType] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
sqls)
  ([MigrateSql] -> MigrateSql) -> [MigrateSql] -> MigrateSql
forall a b. (a -> b) -> a -> b
$ (ColumnProp -> MigrateSql) -> [ColumnProp] -> [MigrateSql]
forall a b. (a -> b) -> [a] -> [b]
map ColumnProp -> MigrateSql
showColumnProp [ColumnProp]
colProps
  where
    sqlType :: Text
sqlType = case (ColumnProp
AutoIncrement ColumnProp -> [ColumnProp] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ColumnProp]
colProps, SqlType
colType) of
      (Bool
True, SqlType
SqlInt32) -> Text
"SERIAL"
      (Bool
True, SqlType
SqlInt64) -> Text
"BIGSERIAL"
      (Bool, SqlType)
_ -> SqlType -> Text
showSqlType SqlType
colType

-- | Show a 'SqlType'. See `showSqlType` from `Database.Persist.Postgresql`.
showSqlType :: SqlType -> Text
showSqlType :: SqlType -> Text
showSqlType = \case
  SqlType
SqlString -> Text
"VARCHAR"
  SqlType
SqlInt32 -> Text
"INT4"
  SqlType
SqlInt64 -> Text
"INT8"
  SqlType
SqlReal -> Text
"DOUBLE PRECISION"
  SqlNumeric Word32
s Word32
prec -> [Text] -> Text
Text.concat [Text
"NUMERIC(", Word32 -> Text
showT Word32
s, Text
",", Word32 -> Text
showT Word32
prec, Text
")"]
  SqlType
SqlDay -> Text
"DATE"
  SqlType
SqlTime -> Text
"TIME"
  SqlType
SqlDayTime -> Text
"TIMESTAMP WITH TIME ZONE"
  SqlType
SqlBlob -> Text
"BYTEA"
  SqlType
SqlBool -> Text
"BOOLEAN"
  SqlOther (Text -> Text
Text.toLower -> Text
"integer") -> Text
"INT4"
  SqlOther Text
t -> Text
t
  where
    showT :: Word32 -> Text
showT = String -> Text
Text.pack (String -> Text) -> (Word32 -> String) -> Word32 -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> String
forall a. Show a => a -> String
show

-- | Show a 'ColumnProp'.
showColumnProp :: ColumnProp -> MigrateSql
showColumnProp :: ColumnProp -> MigrateSql
showColumnProp = \case
  ColumnProp
NotNull -> Text -> MigrateSql
pureSql Text
"NOT NULL"
  References (Text
tab, Text
col) -> Text -> MigrateSql
pureSql (Text -> MigrateSql) -> Text -> MigrateSql
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.unwords
    [Text
"REFERENCES", Text -> Text
quote Text
tab, Text
"(", Text -> Text
quote Text
col, Text
")"]
  ColumnProp
AutoIncrement -> Text -> MigrateSql
pureSql Text
""
  Default PersistValue
v -> Text -> [PersistValue] -> MigrateSql
MigrateSql Text
"DEFAULT ?" [PersistValue
v]

-- | Show a `TableConstraint`.
showTableConstraint :: TableConstraint -> MigrateSql
showTableConstraint :: TableConstraint -> MigrateSql
showTableConstraint = Text -> MigrateSql
pureSql (Text -> MigrateSql)
-> (TableConstraint -> Text) -> TableConstraint -> MigrateSql
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
  PrimaryKey [Text]
cols -> [Text] -> Text
Text.unwords [Text
"PRIMARY KEY (", [Text] -> Text
uncommas' [Text]
cols, Text
")"]
  Unique Text
name [Text]
cols -> [Text] -> Text
Text.unwords [Text
"CONSTRAINT", Text -> Text
quote Text
name, Text
"UNIQUE (", [Text] -> Text
uncommas' [Text]
cols, Text
")"]