{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}

-- | This module provides the high-level API to migrate a database.
module Database.Beam.AutoMigrate
  ( -- * Annotating a database
    -- $annotatingDbSettings
    defaultAnnotatedDbSettings,

    -- * Generating a Schema
    -- $generatingASchema
    fromAnnotatedDbSettings,

    -- * Downcasting an AnnotatedDatabaseSettings into a simple DatabaseSettings
    deAnnotateDatabase,

    -- * Generating and running migrations
    Migration,
    migrate,
    runMigrationUnsafe,
    runMigrationWithEditUpdate,
    tryRunMigrationsWithEditUpdate,
    calcMigrationSteps,

    -- * Creating a migration from a Diff
    createMigration,

    -- * Migration utility functions
    splitEditsOnSafety,
    fastApproximateRowCountFor,

    -- * Printing migrations for debugging purposes
    prettyEditActionDescription,
    prettyEditSQL,
    showMigration,
    printMigration,
    printMigrationIO,

    -- * Unsafe functions
    unsafeRunMigration,

    -- * Handy re-exports
    module Exports,

    -- * Internals
    FromAnnotated,
    ToAnnotated,
    sqlSingleQuoted,
    sqlEscaped,
    editToSqlCommand,
  )
where

import Control.Exception
import Control.Monad.Except
import Control.Monad.Identity (runIdentity)
import Control.Monad.State.Strict
import Data.Bifunctor (first)
import Data.Function ((&))
import Data.Int (Int64)
import Data.List (foldl')
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe)
import Data.Proxy
import qualified Data.Set as S
import Data.String.Conv (toS)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Lazy as LT
import Database.Beam.AutoMigrate.Annotated as Exports
import Database.Beam.AutoMigrate.Compat as Exports
import Database.Beam.AutoMigrate.Diff as Exports
import Database.Beam.AutoMigrate.Generic as Exports
import Database.Beam.AutoMigrate.Postgres (getSchema)
import Database.Beam.AutoMigrate.Types as Exports
import Database.Beam.AutoMigrate.Util hiding (tableName)
import Database.Beam.AutoMigrate.Validity as Exports
import Database.Beam.Backend.SQL hiding (tableName)
import qualified Database.Beam.Backend.SQL.AST as AST
import qualified Database.Beam.Postgres as Pg
import qualified Database.Beam.Postgres.Syntax as Pg
import Database.Beam.Schema (Database, DatabaseSettings)
import Database.Beam.Schema.Tables (DatabaseEntity (..))
import qualified Database.PostgreSQL.Simple as Pg
import GHC.Generics hiding (prec)
import Lens.Micro (over, (^.), _1, _2)
import qualified Text.Pretty.Simple as PS

-- $annotatingDbSettings
-- The first thing to do in order to be able to use this library is to convert a Beam's 'DatabaseSettings'
-- into an 'AnnotatedDatabaseSettings'. You typically have two options in order to do that:
--
-- 1. If you don't have an existing 'DatabaseSettings' from a previous application, you can simply call
--    'defaultAnnotatedDbSettings' with 'defaultDbSettings', as in @defaultAnnotatedDbSettings defaultDbSettings@;
--
-- 2. If you are starting from an existing 'DatabaseSettings', then simply call 'defaultAnnotatedDbSettings'
--    passing your existing 'DatabaseSettings'.

-- | Simple synonym to make the signatures for 'defaultAnnotatedDbSettings' and 'fromAnnotatedDbSettings'
-- less scary. From a user's standpoint, there is nothing you have to implement.
type ToAnnotated (be :: *) (db :: DatabaseKind) e1 e2 =
  ( Generic (db (e1 be db)),
    Generic (db (e2 be db)),
    Database be db,
    GZipDatabase
      be
      (e1 be db)
      (e2 be db)
      (e2 be db)
      (Rep (db (e1 be db)))
      (Rep (db (e2 be db)))
      (Rep (db (e2 be db)))
  )

-- | Simple class to make the signatures for 'defaultAnnotatedDbSettings' and 'fromAnnotatedDbSettings'
-- less scary. From a user's standpoint, there is nothing you have to implement.
type FromAnnotated (be :: *) (db :: DatabaseKind) e1 e2 =
  ( Generic (db (e1 be db)),
    Generic (db (e2 be db)),
    Database be db,
    GZipDatabase
      be
      (e2 be db)
      (e2 be db)
      (e1 be db)
      (Rep (db (e2 be db)))
      (Rep (db (e2 be db)))
      (Rep (db (e1 be db)))
  )

-- | Turns a Beam's 'DatabaseSettings' into an 'AnnotatedDatabaseSettings'.
defaultAnnotatedDbSettings ::
  forall be db.
  ToAnnotated be db DatabaseEntity AnnotatedDatabaseEntity =>
  DatabaseSettings be db ->
  AnnotatedDatabaseSettings be db
defaultAnnotatedDbSettings :: DatabaseSettings be db -> AnnotatedDatabaseSettings be db
defaultAnnotatedDbSettings DatabaseSettings be db
db =
  Identity (AnnotatedDatabaseSettings be db)
-> AnnotatedDatabaseSettings be db
forall a. Identity a -> a
runIdentity (Identity (AnnotatedDatabaseSettings be db)
 -> AnnotatedDatabaseSettings be db)
-> Identity (AnnotatedDatabaseSettings be db)
-> AnnotatedDatabaseSettings be db
forall a b. (a -> b) -> a -> b
$
    Proxy be
-> (forall tbl.
    (IsAnnotatedDatabaseEntity be tbl,
     AnnotatedDatabaseEntityRegularRequirements be tbl) =>
    DatabaseEntity be db tbl
    -> AnnotatedDatabaseEntity be db tbl
    -> Identity (AnnotatedDatabaseEntity be db tbl))
-> DatabaseSettings be db
-> AnnotatedDatabaseSettings be db
-> Identity (AnnotatedDatabaseSettings be db)
forall (db :: (* -> *) -> *) (f :: * -> *) (g :: * -> *)
       (h :: * -> *) (m :: * -> *) be.
(Generic (db f), Generic (db g), Generic (db h), Monad m,
 GZipDatabase be f g h (Rep (db f)) (Rep (db g)) (Rep (db h))) =>
Proxy be
-> (forall tbl.
    (IsAnnotatedDatabaseEntity be tbl,
     AnnotatedDatabaseEntityRegularRequirements be tbl) =>
    f tbl -> g tbl -> m (h tbl))
-> db f
-> db g
-> m (db h)
zipTables (Proxy be
forall k (t :: k). Proxy t
Proxy @be) forall tbl.
(IsAnnotatedDatabaseEntity be tbl,
 AnnotatedDatabaseEntityRegularRequirements be tbl) =>
DatabaseEntity be db tbl
-> AnnotatedDatabaseEntity be db tbl
-> Identity (AnnotatedDatabaseEntity be db tbl)
forall (m :: * -> *) ty.
(Monad m, IsAnnotatedDatabaseEntity be ty,
 AnnotatedDatabaseEntityRegularRequirements be ty) =>
DatabaseEntity be db ty
-> AnnotatedDatabaseEntity be db ty
-> m (AnnotatedDatabaseEntity be db ty)
annotate DatabaseSettings be db
db (AnnotatedDatabaseSettings be db
forall a. HasCallStack => a
undefined :: AnnotatedDatabaseSettings be db)
  where
    annotate ::
      ( Monad m,
        IsAnnotatedDatabaseEntity be ty,
        AnnotatedDatabaseEntityRegularRequirements be ty
      ) =>
      DatabaseEntity be db ty ->
      AnnotatedDatabaseEntity be db ty ->
      m (AnnotatedDatabaseEntity be db ty)
    annotate :: DatabaseEntity be db ty
-> AnnotatedDatabaseEntity be db ty
-> m (AnnotatedDatabaseEntity be db ty)
annotate (DatabaseEntity DatabaseEntityDescriptor be ty
edesc) AnnotatedDatabaseEntity be db ty
_ =
      AnnotatedDatabaseEntity be db ty
-> m (AnnotatedDatabaseEntity be db ty)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AnnotatedDatabaseEntity be db ty
 -> m (AnnotatedDatabaseEntity be db ty))
-> AnnotatedDatabaseEntity be db ty
-> m (AnnotatedDatabaseEntity be db ty)
forall a b. (a -> b) -> a -> b
$ AnnotatedDatabaseEntityDescriptor be ty
-> DatabaseEntity be db ty -> AnnotatedDatabaseEntity be db ty
forall be entityType (db :: (* -> *) -> *).
(IsAnnotatedDatabaseEntity be entityType,
 IsDatabaseEntity be entityType) =>
AnnotatedDatabaseEntityDescriptor be entityType
-> DatabaseEntity be db entityType
-> AnnotatedDatabaseEntity be db entityType
AnnotatedDatabaseEntity (DatabaseEntityDescriptor be ty
-> AnnotatedDatabaseEntityDescriptor be ty
forall be entityType.
(IsAnnotatedDatabaseEntity be entityType,
 AnnotatedDatabaseEntityRegularRequirements be entityType) =>
DatabaseEntityDescriptor be entityType
-> AnnotatedDatabaseEntityDescriptor be entityType
dbAnnotatedEntityAuto DatabaseEntityDescriptor be ty
edesc) (DatabaseEntityDescriptor be ty -> DatabaseEntity be db ty
forall be entityType (db :: (* -> *) -> *).
IsDatabaseEntity be entityType =>
DatabaseEntityDescriptor be entityType
-> DatabaseEntity be db entityType
DatabaseEntity DatabaseEntityDescriptor be ty
edesc)

-- | Downcast an 'AnnotatedDatabaseSettings' into Beam's standard 'DatabaseSettings'.
deAnnotateDatabase ::
  forall be db.
  FromAnnotated be db DatabaseEntity AnnotatedDatabaseEntity =>
  AnnotatedDatabaseSettings be db ->
  DatabaseSettings be db
deAnnotateDatabase :: AnnotatedDatabaseSettings be db -> DatabaseSettings be db
deAnnotateDatabase AnnotatedDatabaseSettings be db
db =
  Identity (DatabaseSettings be db) -> DatabaseSettings be db
forall a. Identity a -> a
runIdentity (Identity (DatabaseSettings be db) -> DatabaseSettings be db)
-> Identity (DatabaseSettings be db) -> DatabaseSettings be db
forall a b. (a -> b) -> a -> b
$ Proxy be
-> (forall tbl.
    (IsAnnotatedDatabaseEntity be tbl,
     AnnotatedDatabaseEntityRegularRequirements be tbl) =>
    AnnotatedDatabaseEntity be db tbl
    -> AnnotatedDatabaseEntity be db tbl
    -> Identity (DatabaseEntity be db tbl))
-> AnnotatedDatabaseSettings be db
-> AnnotatedDatabaseSettings be db
-> Identity (DatabaseSettings be db)
forall (db :: (* -> *) -> *) (f :: * -> *) (g :: * -> *)
       (h :: * -> *) (m :: * -> *) be.
(Generic (db f), Generic (db g), Generic (db h), Monad m,
 GZipDatabase be f g h (Rep (db f)) (Rep (db g)) (Rep (db h))) =>
Proxy be
-> (forall tbl.
    (IsAnnotatedDatabaseEntity be tbl,
     AnnotatedDatabaseEntityRegularRequirements be tbl) =>
    f tbl -> g tbl -> m (h tbl))
-> db f
-> db g
-> m (db h)
zipTables (Proxy be
forall k (t :: k). Proxy t
Proxy @be) (\AnnotatedDatabaseEntity be db tbl
ann AnnotatedDatabaseEntity be db tbl
_ -> DatabaseEntity be db tbl -> Identity (DatabaseEntity be db tbl)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DatabaseEntity be db tbl -> Identity (DatabaseEntity be db tbl))
-> DatabaseEntity be db tbl -> Identity (DatabaseEntity be db tbl)
forall a b. (a -> b) -> a -> b
$ AnnotatedDatabaseEntity be db tbl
ann AnnotatedDatabaseEntity be db tbl
-> Getting
     (DatabaseEntity be db tbl)
     (AnnotatedDatabaseEntity be db tbl)
     (DatabaseEntity be db tbl)
-> DatabaseEntity be db tbl
forall s a. s -> Getting a s a -> a
^. Getting
  (DatabaseEntity be db tbl)
  (AnnotatedDatabaseEntity be db tbl)
  (DatabaseEntity be db tbl)
forall be (db :: (* -> *) -> *) entityType.
SimpleGetter
  (AnnotatedDatabaseEntity be db entityType)
  (DatabaseEntity be db entityType)
deannotate) AnnotatedDatabaseSettings be db
db AnnotatedDatabaseSettings be db
db

-- $generatingASchema
-- Once you have an 'AnnotatedDatabaseSettings', you can produce a 'Schema' simply by calling
-- 'fromAnnotatedDbSettings'. The second parameter can be used to selectively turn off automatic FK-discovery
-- for one or more tables. For more information about specifying your own table constraints, refer to the
-- 'Database.Beam.AutoMigrate.Annotated' module.

-- | Turns an 'AnnotatedDatabaseSettings' into a 'Schema'. Under the hood, this function will do the
-- following:
--
-- * It will turn each 'TableEntity' of your database into a 'Table';
-- * It will turn each 'PgEnum' enumeration type into an 'Enumeration', which will map to an @ENUM@ type in the DB;
-- * It will run what we call the __/automatic FK-discovery algorithm/__. What this means practically speaking
--   is that if a reference to an external 'PrimaryKey' is found, and such 'PrimaryKey' uniquely identifies
--   another 'TableEntity' in your database, the automatic FK-discovery algorithm will turn into into a
--   'ForeignKey' 'TableConstraint', without any user intervention. In case there is ambiguity instead, the
--   library will fail with a static error until the user won't disable the relevant tables (via the provided
--  'Proxy' type) and annotate them to do the \"right thing\".
fromAnnotatedDbSettings ::
  ( FromAnnotated be db DatabaseEntity AnnotatedDatabaseEntity,
    GSchema be db anns (Rep (AnnotatedDatabaseSettings be db))
  ) =>
  AnnotatedDatabaseSettings be db ->
  Proxy (anns :: [Annotation]) ->
  Schema
fromAnnotatedDbSettings :: AnnotatedDatabaseSettings be db -> Proxy anns -> Schema
fromAnnotatedDbSettings AnnotatedDatabaseSettings be db
db Proxy anns
p = AnnotatedDatabaseSettings be db
-> Proxy anns
-> Rep (AnnotatedDatabaseSettings be db) Any
-> Schema
forall be (db :: (* -> *) -> *) (anns :: [Annotation])
       (x :: * -> *) p.
GSchema be db anns x =>
AnnotatedDatabaseSettings be db -> Proxy anns -> x p -> Schema
gSchema AnnotatedDatabaseSettings be db
db Proxy anns
p (AnnotatedDatabaseSettings be db
-> Rep (AnnotatedDatabaseSettings be db) Any
forall a x. Generic a => a -> Rep a x
from AnnotatedDatabaseSettings be db
db)

editsToPgSyntax :: [WithPriority Edit] -> [Pg.PgSyntax]
editsToPgSyntax :: [WithPriority Edit] -> [PgSyntax]
editsToPgSyntax = (WithPriority Edit -> PgSyntax)
-> [WithPriority Edit] -> [PgSyntax]
forall a b. (a -> b) -> [a] -> [b]
map (Edit -> PgSyntax
toSqlSyntax (Edit -> PgSyntax)
-> (WithPriority Edit -> Edit) -> WithPriority Edit -> PgSyntax
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Edit, Priority) -> Edit
forall a b. (a, b) -> a
fst ((Edit, Priority) -> Edit)
-> (WithPriority Edit -> (Edit, Priority))
-> WithPriority Edit
-> Edit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithPriority Edit -> (Edit, Priority)
forall a. WithPriority a -> (a, Priority)
unPriority)

-- | A database 'Migration'.
type Migration m = ExceptT MigrationError (StateT [WithPriority Edit] m) ()

data MigrationError
  = DiffFailed DiffError
  | HaskellSchemaValidationFailed [ValidationFailed]
  | DatabaseSchemaValidationFailed [ValidationFailed]
  | UnsafeEditsDetected [EditAction]
  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)

instance Exception MigrationError

-- | Split the given list of 'Edit's based on their 'EditSafety' setting.
splitEditsOnSafety :: [WithPriority Edit] -> ([WithPriority Edit], [WithPriority Edit])
splitEditsOnSafety :: [WithPriority Edit] -> ([WithPriority Edit], [WithPriority Edit])
splitEditsOnSafety =
  (([WithPriority Edit], [WithPriority Edit])
 -> WithPriority Edit -> ([WithPriority Edit], [WithPriority Edit]))
-> ([WithPriority Edit], [WithPriority Edit])
-> [WithPriority Edit]
-> ([WithPriority Edit], [WithPriority Edit])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
    ( \([WithPriority Edit], [WithPriority Edit])
acc WithPriority Edit
p ->
        if EditSafety -> Edit -> Bool
editSafetyIs EditSafety
Unsafe ((Edit, Priority) -> Edit
forall a b. (a, b) -> a
fst ((Edit, Priority) -> Edit) -> (Edit, Priority) -> Edit
forall a b. (a -> b) -> a -> b
$ WithPriority Edit -> (Edit, Priority)
forall a. WithPriority a -> (a, Priority)
unPriority WithPriority Edit
p)
          then ASetter
  ([WithPriority Edit], [WithPriority Edit])
  ([WithPriority Edit], [WithPriority Edit])
  [WithPriority Edit]
  [WithPriority Edit]
-> ([WithPriority Edit] -> [WithPriority Edit])
-> ([WithPriority Edit], [WithPriority Edit])
-> ([WithPriority Edit], [WithPriority Edit])
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  ([WithPriority Edit], [WithPriority Edit])
  ([WithPriority Edit], [WithPriority Edit])
  [WithPriority Edit]
  [WithPriority Edit]
forall s t a b. Field1 s t a b => Lens s t a b
_1 (WithPriority Edit
p WithPriority Edit -> [WithPriority Edit] -> [WithPriority Edit]
forall a. a -> [a] -> [a]
:) ([WithPriority Edit], [WithPriority Edit])
acc
          else ASetter
  ([WithPriority Edit], [WithPriority Edit])
  ([WithPriority Edit], [WithPriority Edit])
  [WithPriority Edit]
  [WithPriority Edit]
-> ([WithPriority Edit] -> [WithPriority Edit])
-> ([WithPriority Edit], [WithPriority Edit])
-> ([WithPriority Edit], [WithPriority Edit])
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  ([WithPriority Edit], [WithPriority Edit])
  ([WithPriority Edit], [WithPriority Edit])
  [WithPriority Edit]
  [WithPriority Edit]
forall s t a b. Field2 s t a b => Lens s t a b
_2 (WithPriority Edit
p WithPriority Edit -> [WithPriority Edit] -> [WithPriority Edit]
forall a. a -> [a] -> [a]
:) ([WithPriority Edit], [WithPriority Edit])
acc
    )
    ([WithPriority Edit]
forall a. Monoid a => a
mempty, [WithPriority Edit]
forall a. Monoid a => a
mempty)

-- | Given a 'Connection' to a database and a 'Schema' (which can be generated using 'fromAnnotatedDbSettings')
-- it returns a 'Migration', which can then be executed via 'runMigration'.
migrate :: MonadIO m => Pg.Connection -> Schema -> Migration m
migrate :: Connection -> Schema -> Migration m
migrate Connection
conn Schema
hsSchema = do
  Schema
dbSchema <- StateT [WithPriority Edit] m Schema
-> ExceptT MigrationError (StateT [WithPriority Edit] m) Schema
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT [WithPriority Edit] m Schema
 -> ExceptT MigrationError (StateT [WithPriority Edit] m) Schema)
-> (IO Schema -> StateT [WithPriority Edit] m Schema)
-> IO Schema
-> ExceptT MigrationError (StateT [WithPriority Edit] m) Schema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO Schema -> StateT [WithPriority Edit] m Schema
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Schema
 -> ExceptT MigrationError (StateT [WithPriority Edit] m) Schema)
-> IO Schema
-> ExceptT MigrationError (StateT [WithPriority Edit] m) Schema
forall a b. (a -> b) -> a -> b
$ Connection -> IO Schema
getSchema Connection
conn
  Either MigrationError () -> Migration m
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either MigrationError () -> Migration m)
-> Either MigrationError () -> Migration m
forall a b. (a -> b) -> a -> b
$ ([ValidationFailed] -> MigrationError)
-> Either [ValidationFailed] () -> Either MigrationError ()
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first [ValidationFailed] -> MigrationError
HaskellSchemaValidationFailed (Schema -> Either [ValidationFailed] ()
validateSchema Schema
hsSchema)
  Either MigrationError () -> Migration m
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either MigrationError () -> Migration m)
-> Either MigrationError () -> Migration m
forall a b. (a -> b) -> a -> b
$ ([ValidationFailed] -> MigrationError)
-> Either [ValidationFailed] () -> Either MigrationError ()
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first [ValidationFailed] -> MigrationError
DatabaseSchemaValidationFailed (Schema -> Either [ValidationFailed] ()
validateSchema Schema
dbSchema)
  let schemaDiff :: Diff
schemaDiff = Schema -> Schema -> Diff
forall a. Diffable a => a -> a -> Diff
diff Schema
hsSchema Schema
dbSchema
  case Diff
schemaDiff of
    Left DiffError
e -> MigrationError -> Migration m
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (DiffError -> MigrationError
DiffFailed DiffError
e)
    Right [WithPriority Edit]
edits -> StateT [WithPriority Edit] m () -> Migration m
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ([WithPriority Edit] -> StateT [WithPriority Edit] m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put [WithPriority Edit]
edits)

-- | Runs the input 'Migration' in a concrete 'Postgres' backend.
--
-- __IMPORTANT:__ This function /does not/ run inside a SQL transaction, hence the @unsafe@ prefix.
unsafeRunMigration :: (MonadBeam Pg.Postgres m, MonadIO m) => Migration m -> m ()
unsafeRunMigration :: Migration m -> m ()
unsafeRunMigration Migration m
m = do
  Either MigrationError [WithPriority Edit]
migs <- Migration m -> m (Either MigrationError [WithPriority Edit])
forall (m :: * -> *).
Monad m =>
Migration m -> m (Either MigrationError [WithPriority Edit])
evalMigration Migration m
m
  case Either MigrationError [WithPriority Edit]
migs of
    Left MigrationError
e -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MigrationError -> IO ()
forall e a. Exception e => e -> IO a
throwIO MigrationError
e
    Right ([WithPriority Edit] -> [WithPriority Edit]
sortEdits -> [WithPriority Edit]
edits) ->
      BeamSqlBackendSyntax Postgres -> m ()
forall be (m :: * -> *).
MonadBeam be m =>
BeamSqlBackendSyntax be -> m ()
runNoReturn (BeamSqlBackendSyntax Postgres -> m ())
-> BeamSqlBackendSyntax Postgres -> m ()
forall a b. (a -> b) -> a -> b
$ PgCommandType -> PgSyntax -> PgCommandSyntax
Pg.PgCommandSyntax PgCommandType
Pg.PgCommandTypeDdl ([PgSyntax] -> PgSyntax
forall a. Monoid a => [a] -> a
mconcat ([PgSyntax] -> PgSyntax)
-> ([WithPriority Edit] -> [PgSyntax])
-> [WithPriority Edit]
-> PgSyntax
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [WithPriority Edit] -> [PgSyntax]
editsToPgSyntax ([WithPriority Edit] -> PgSyntax)
-> [WithPriority Edit] -> PgSyntax
forall a b. (a -> b) -> a -> b
$ [WithPriority Edit]
edits)

-- | Runs the input 'Migration' in a concrete 'Postgres' backend.
runMigrationUnsafe :: MonadBeam Pg.Postgres Pg.Pg => Pg.Connection -> Migration Pg.Pg -> IO ()
runMigrationUnsafe :: Connection -> Migration Pg -> IO ()
runMigrationUnsafe Connection
conn Migration Pg
mig = Connection -> IO () -> IO ()
forall a. Connection -> IO a -> IO a
Pg.withTransaction Connection
conn (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> Pg () -> IO ()
forall a. Connection -> Pg a -> IO a
Pg.runBeamPostgres Connection
conn (Migration Pg -> Pg ()
forall (m :: * -> *).
(MonadBeam Postgres m, MonadIO m) =>
Migration m -> m ()
unsafeRunMigration Migration Pg
mig)

-- | Run the steps of the migration in priority order, providing a hook to allow the user
-- to take action for 'Unsafe' edits. The given function is only called for unsafe edits.
--
-- This allows you to perform some checks for when the edit safe in some circumstances.
--
-- * Deleting an empty table/column
-- * Making an empty column non-nullable
runMigrationWithEditUpdate ::
  MonadBeam Pg.Postgres Pg.Pg =>
  ([WithPriority Edit] -> [WithPriority Edit]) ->
  Pg.Connection ->
  Schema ->
  IO ()
runMigrationWithEditUpdate :: ([WithPriority Edit] -> [WithPriority Edit])
-> Connection -> Schema -> IO ()
runMigrationWithEditUpdate [WithPriority Edit] -> [WithPriority Edit]
editUpdate Connection
conn Schema
hsSchema = do
  -- Create the migration with all the safeety information
  [WithPriority Edit]
edits <- (MigrationError -> IO [WithPriority Edit])
-> ([WithPriority Edit] -> IO [WithPriority Edit])
-> Either MigrationError [WithPriority Edit]
-> IO [WithPriority Edit]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either MigrationError -> IO [WithPriority Edit]
forall e a. Exception e => e -> IO a
throwIO [WithPriority Edit] -> IO [WithPriority Edit]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either MigrationError [WithPriority Edit]
 -> IO [WithPriority Edit])
-> IO (Either MigrationError [WithPriority Edit])
-> IO [WithPriority Edit]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Migration IO -> IO (Either MigrationError [WithPriority Edit])
forall (m :: * -> *).
Monad m =>
Migration m -> m (Either MigrationError [WithPriority Edit])
evalMigration (Connection -> Schema -> Migration IO
forall (m :: * -> *).
MonadIO m =>
Connection -> Schema -> Migration m
migrate Connection
conn Schema
hsSchema)
  -- Apply the user function to possibly update the list of edits to allow the user to
  -- intervene in the event of unsafe edits.
  let newEdits :: [WithPriority Edit]
newEdits = [WithPriority Edit] -> [WithPriority Edit]
sortEdits ([WithPriority Edit] -> [WithPriority Edit])
-> [WithPriority Edit] -> [WithPriority Edit]
forall a b. (a -> b) -> a -> b
$ [WithPriority Edit] -> [WithPriority Edit]
editUpdate ([WithPriority Edit] -> [WithPriority Edit])
-> [WithPriority Edit] -> [WithPriority Edit]
forall a b. (a -> b) -> a -> b
$ [WithPriority Edit] -> [WithPriority Edit]
sortEdits [WithPriority Edit]
edits
  -- If the new list of edits still contains any unsafe edits then fail out.

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([WithPriority Edit]
newEdits [WithPriority Edit] -> [WithPriority Edit] -> Bool
forall a. Eq a => a -> a -> Bool
/= [WithPriority Edit] -> [WithPriority Edit]
sortEdits [WithPriority Edit]
edits) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    String -> IO ()
putStrLn String
"Changes requested to diff induced migration. Attempting..."
    [WithPriority Edit] -> IO ()
prettyPrintEdits [WithPriority Edit]
newEdits

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((WithPriority Edit -> Bool) -> [WithPriority Edit] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (EditSafety -> Edit -> Bool
editSafetyIs EditSafety
Unsafe (Edit -> Bool)
-> (WithPriority Edit -> Edit) -> WithPriority Edit -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Edit, Priority) -> Edit
forall a b. (a, b) -> a
fst ((Edit, Priority) -> Edit)
-> (WithPriority Edit -> (Edit, Priority))
-> WithPriority Edit
-> Edit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithPriority Edit -> (Edit, Priority)
forall a. WithPriority a -> (a, Priority)
unPriority) [WithPriority Edit]
newEdits) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    MigrationError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (MigrationError -> IO ()) -> MigrationError -> IO ()
forall a b. (a -> b) -> a -> b
$ [EditAction] -> MigrationError
UnsafeEditsDetected ([EditAction] -> MigrationError) -> [EditAction] -> MigrationError
forall a b. (a -> b) -> a -> b
$ (WithPriority Edit -> EditAction)
-> [WithPriority Edit] -> [EditAction]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(WithPriority (Edit
e, Priority
_)) -> Edit -> EditAction
_editAction Edit
e) [WithPriority Edit]
newEdits

  -- Execute all the edits within a single transaction so we rollback if any of them fail.
  Connection -> IO () -> IO ()
forall a. Connection -> IO a -> IO a
Pg.withTransaction Connection
conn (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Connection -> Pg () -> IO ()
forall a. Connection -> Pg a -> IO a
Pg.runBeamPostgres Connection
conn (Pg () -> IO ()) -> Pg () -> IO ()
forall a b. (a -> b) -> a -> b
$
      [WithPriority Edit] -> (WithPriority Edit -> Pg ()) -> Pg ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [WithPriority Edit]
newEdits ((WithPriority Edit -> Pg ()) -> Pg ())
-> (WithPriority Edit -> Pg ()) -> Pg ()
forall a b. (a -> b) -> a -> b
$ \(WithPriority (Edit
edit, Priority
_)) -> do
        case Edit -> Either EditCondition EditSafety
_editCondition Edit
edit of
          Right EditSafety
Unsafe -> IO () -> Pg ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Pg ()) -> IO () -> Pg ()
forall a b. (a -> b) -> a -> b
$ MigrationError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (MigrationError -> IO ()) -> MigrationError -> IO ()
forall a b. (a -> b) -> a -> b
$ [EditAction] -> MigrationError
UnsafeEditsDetected [Edit -> EditAction
_editAction Edit
edit]
          -- Safe or slow, run that edit.
          Right EditSafety
safeMaybeSlow -> EditSafety -> Edit -> Pg ()
forall (m :: * -> *) be.
(MonadIO m, MonadBeam be m,
 BeamSqlBackendSyntax be ~ PgCommandSyntax) =>
EditSafety -> Edit -> m ()
safeOrSlow EditSafety
safeMaybeSlow Edit
edit
          Left EditCondition
ec -> do
            -- Edit is conditional, run the condition to see how safe it is to run this edit.
            String -> Pg ()
forall (m :: * -> *). MonadIO m => String -> m ()
printmsg (String -> Pg ()) -> String -> Pg ()
forall a b. (a -> b) -> a -> b
$ String
"edit has condition: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a b. StringConv a b => a -> b
toS (EditCondition -> ByteString
prettyEditConditionQuery EditCondition
ec)
            EditSafety
checkedSafety <- EditCondition -> Pg EditSafety
_editCondition_check EditCondition
ec
            case EditSafety
checkedSafety of
              EditSafety
Unsafe -> do
                -- Edit determined to be unsafe, don't run it.
                String -> Pg ()
forall (m :: * -> *). MonadIO m => String -> m ()
printmsg String
"edit unsafe by condition"
                IO () -> Pg ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Pg ()) -> IO () -> Pg ()
forall a b. (a -> b) -> a -> b
$ MigrationError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (MigrationError -> IO ()) -> MigrationError -> IO ()
forall a b. (a -> b) -> a -> b
$ [EditAction] -> MigrationError
UnsafeEditsDetected [Edit -> EditAction
_editAction Edit
edit]
              EditSafety
safeMaybeSlow -> do
                -- Safe or slow, run that edit.
                String -> Pg ()
forall (m :: * -> *). MonadIO m => String -> m ()
printmsg String
"edit condition satisfied"
                EditSafety -> Edit -> Pg ()
forall (m :: * -> *) be.
(MonadIO m, MonadBeam be m,
 BeamSqlBackendSyntax be ~ PgCommandSyntax) =>
EditSafety -> Edit -> m ()
safeOrSlow EditSafety
safeMaybeSlow Edit
edit
  where
    safeOrSlow :: EditSafety -> Edit -> m ()
safeOrSlow EditSafety
safety Edit
edit = do
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (EditSafety
safety EditSafety -> EditSafety -> Bool
forall a. Eq a => a -> a -> Bool
== EditSafety
PotentiallySlow) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
printmsg String
"Running potentially slow edit"
        String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
printmsg (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ EditAction -> Text
prettyEditActionDescription (EditAction -> Text) -> EditAction -> Text
forall a b. (a -> b) -> a -> b
$ Edit -> EditAction
_editAction Edit
edit

      BeamSqlBackendSyntax be -> m ()
forall be (m :: * -> *).
MonadBeam be m =>
BeamSqlBackendSyntax be -> m ()
runNoReturn (BeamSqlBackendSyntax be -> m ())
-> BeamSqlBackendSyntax be -> m ()
forall a b. (a -> b) -> a -> b
$ Edit -> PgCommandSyntax
editToSqlCommand Edit
edit

    printmsg :: MonadIO m => String -> m ()
    printmsg :: String -> m ()
printmsg = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (String -> IO ()) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn (String -> IO ()) -> ShowS -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. Monoid a => a -> a -> a
mappend String
"[beam-migrate] "

-- | Helper query to retrieve the approximate row count from the @pg_class@ table.
--
-- Number of live rows in the table. This is only an estimate used by the planner. It is
-- updated by VACUUM, ANALYZE, and a few DDL commands such as CREATE INDEX.
--
-- This can be used as a check to see if an otherwise 'Unsafe' 'EditAction' is safe to execute.
--
-- See:
-- * <https://wiki.postgresql.org/wiki/Count_estimate PostgreSQL Wiki Count Estimate> and
-- * <https://www.postgresql.org/docs/current/catalog-pg-class.html PostgreSQL Manual for @pg_class@>
-- for more information.
fastApproximateRowCountFor :: TableName -> Pg.Pg (Maybe Int64)
fastApproximateRowCountFor :: TableName -> Pg (Maybe Int64)
fastApproximateRowCountFor TableName
tblName = BeamSqlBackendSyntax Postgres -> Pg (Maybe Int64)
forall be (m :: * -> *) x.
(MonadBeam be m, FromBackendRow be x) =>
BeamSqlBackendSyntax be -> m (Maybe x)
runReturningOne (BeamSqlBackendSyntax Postgres -> Pg (Maybe Int64))
-> BeamSqlBackendSyntax Postgres -> Pg (Maybe Int64)
forall a b. (a -> b) -> a -> b
$ Sql92SelectSyntax PgCommandSyntax -> PgCommandSyntax
forall cmd. IsSql92Syntax cmd => Sql92SelectSyntax cmd -> cmd
selectCmd (Sql92SelectSyntax PgCommandSyntax -> PgCommandSyntax)
-> Sql92SelectSyntax PgCommandSyntax -> PgCommandSyntax
forall a b. (a -> b) -> a -> b
$ PgSyntax -> PgSelectSyntax
Pg.PgSelectSyntax (PgSyntax -> PgSelectSyntax) -> PgSyntax -> PgSelectSyntax
forall a b. (a -> b) -> a -> b
$ PgSyntax
qry
  where
    qry :: PgSyntax
qry =
      ByteString -> PgSyntax
Pg.emit (ByteString -> PgSyntax) -> ByteString -> PgSyntax
forall a b. (a -> b) -> a -> b
$
        Text -> ByteString
forall a b. StringConv a b => a -> b
toS (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$
          Text
"SELECT reltuples AS approximate_row_count FROM pg_class WHERE relname = "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
sqlEscaped (TableName -> Text
tableName TableName
tblName)
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
";"

-- Unfortunately Postgres' syntax is different when setting or dropping constaints. For example when we
-- drop the default value we /don't/ repeat which was the original default value (which makes sense), but
-- doing so means we have to discriminate between these two events to render the SQL fragment correctly.
data AlterTableAction
  = SetConstraint
  | DropConstraint
  deriving (Int -> AlterTableAction -> ShowS
[AlterTableAction] -> ShowS
AlterTableAction -> String
(Int -> AlterTableAction -> ShowS)
-> (AlterTableAction -> String)
-> ([AlterTableAction] -> ShowS)
-> Show AlterTableAction
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AlterTableAction] -> ShowS
$cshowList :: [AlterTableAction] -> ShowS
show :: AlterTableAction -> String
$cshow :: AlterTableAction -> String
showsPrec :: Int -> AlterTableAction -> ShowS
$cshowsPrec :: Int -> AlterTableAction -> ShowS
Show, AlterTableAction -> AlterTableAction -> Bool
(AlterTableAction -> AlterTableAction -> Bool)
-> (AlterTableAction -> AlterTableAction -> Bool)
-> Eq AlterTableAction
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AlterTableAction -> AlterTableAction -> Bool
$c/= :: AlterTableAction -> AlterTableAction -> Bool
== :: AlterTableAction -> AlterTableAction -> Bool
$c== :: AlterTableAction -> AlterTableAction -> Bool
Eq)

-- | Converts a single 'Edit' into the relevant 'PgSyntax' necessary to generate the final SQL.
toSqlSyntax :: Edit -> Pg.PgSyntax
toSqlSyntax :: Edit -> PgSyntax
toSqlSyntax Edit
e =
  PgSyntax -> PgSyntax
safetyPrefix (PgSyntax -> PgSyntax) -> PgSyntax -> PgSyntax
forall a b. (a -> b) -> a -> b
$ Edit -> EditAction
_editAction Edit
e EditAction -> (EditAction -> PgSyntax) -> PgSyntax
forall a b. a -> (a -> b) -> b
& \case
    EditAction_Automatic AutomaticEditAction
ea -> case AutomaticEditAction
ea of
      TableAdded TableName
tblName Table
tbl ->
        Text -> PgSyntax
ddlSyntax
          ( Text
"CREATE TABLE " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
sqlEscaped (TableName -> Text
tableName TableName
tblName)
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ("
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " (((ColumnName, Column) -> Text) -> [(ColumnName, Column)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (ColumnName, Column) -> Text
renderTableColumn (Map ColumnName Column -> [(ColumnName, Column)]
forall k a. Map k a -> [(k, a)]
M.toList (Table -> Map ColumnName Column
tableColumns Table
tbl)))
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
          )
      TableRemoved TableName
tblName ->
        Text -> PgSyntax
ddlSyntax (Text
"DROP TABLE " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
sqlEscaped (TableName -> Text
tableName TableName
tblName))
      TableConstraintAdded TableName
tblName TableConstraint
cstr ->
        Text -> PgSyntax
updateSyntax (TableName -> Text
alterTable TableName
tblName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TableConstraint -> Text
renderAddConstraint TableConstraint
cstr)
      TableConstraintRemoved TableName
tblName TableConstraint
cstr ->
        Text -> PgSyntax
updateSyntax (TableName -> Text
alterTable TableName
tblName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TableConstraint -> Text
renderDropConstraint TableConstraint
cstr)
      SequenceAdded SequenceName
sName (Sequence TableName
_tName ColumnName
_cName) -> SequenceName -> PgSyntax
createSequenceSyntax SequenceName
sName
      SequenceRemoved SequenceName
sName -> SequenceName -> PgSyntax
dropSequenceSyntax SequenceName
sName
      EnumTypeAdded EnumerationName
tyName Enumeration
vals -> EnumerationName -> Enumeration -> PgSyntax
createTypeSyntax EnumerationName
tyName Enumeration
vals
      EnumTypeRemoved (EnumerationName Text
tyName) -> Text -> PgSyntax
ddlSyntax (Text
"DROP TYPE " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tyName)
      EnumTypeValueAdded (EnumerationName Text
tyName) Text
newVal InsertionOrder
order Text
insPoint ->
        Text -> PgSyntax
ddlSyntax
          ( Text
"ALTER TYPE " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tyName
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ADD VALUE "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
sqlSingleQuoted Text
newVal
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> InsertionOrder -> Text
renderInsertionOrder InsertionOrder
order
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
sqlSingleQuoted Text
insPoint
          )
      ColumnAdded TableName
tblName ColumnName
colName Column
col ->
        Text -> PgSyntax
updateSyntax
          ( TableName -> Text
alterTable TableName
tblName
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"ADD COLUMN "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
sqlEscaped (ColumnName -> Text
columnName ColumnName
colName)
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ColumnType -> Text
renderDataType (Column -> ColumnType
columnType Column
col)
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
" " ((ColumnConstraint -> Text) -> [ColumnConstraint] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (AlterTableAction -> ColumnConstraint -> Text
renderColumnConstraint AlterTableAction
SetConstraint) (Set ColumnConstraint -> [ColumnConstraint]
forall a. Set a -> [a]
S.toList (Set ColumnConstraint -> [ColumnConstraint])
-> Set ColumnConstraint -> [ColumnConstraint]
forall a b. (a -> b) -> a -> b
$ Column -> Set ColumnConstraint
columnConstraints Column
col))
          )
      ColumnRemoved TableName
tblName ColumnName
colName ->
        Text -> PgSyntax
updateSyntax (TableName -> Text
alterTable TableName
tblName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"DROP COLUMN " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
sqlEscaped (ColumnName -> Text
columnName ColumnName
colName))
      ColumnTypeChanged TableName
tblName ColumnName
colName ColumnType
_old ColumnType
new ->
        Text -> PgSyntax
updateSyntax
          ( TableName -> Text
alterTable TableName
tblName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"ALTER COLUMN "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
sqlEscaped (ColumnName -> Text
columnName ColumnName
colName)
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" TYPE "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ColumnType -> Text
renderDataType ColumnType
new
          )
      ColumnConstraintAdded TableName
tblName ColumnName
colName ColumnConstraint
cstr ->
        Text -> PgSyntax
updateSyntax
          ( TableName -> Text
alterTable TableName
tblName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"ALTER COLUMN "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
sqlEscaped (ColumnName -> Text
columnName ColumnName
colName)
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" SET "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> AlterTableAction -> ColumnConstraint -> Text
renderColumnConstraint AlterTableAction
SetConstraint ColumnConstraint
cstr
          )
      ColumnConstraintRemoved TableName
tblName ColumnName
colName ColumnConstraint
cstr ->
        Text -> PgSyntax
updateSyntax
          ( TableName -> Text
alterTable TableName
tblName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"ALTER COLUMN "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
sqlEscaped (ColumnName -> Text
columnName ColumnName
colName)
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" DROP "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> AlterTableAction -> ColumnConstraint -> Text
renderColumnConstraint AlterTableAction
DropConstraint ColumnConstraint
cstr
          )
    EditAction_Manual ManualEditAction
ea -> case ManualEditAction
ea of
      ColumnRenamed TableName
tblName ColumnName
oldName ColumnName
newName ->
        Text -> PgSyntax
updateSyntax
          ( TableName -> Text
alterTable TableName
tblName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"RENAME COLUMN "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
sqlEscaped (ColumnName -> Text
columnName ColumnName
oldName)
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" TO "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
sqlEscaped (ColumnName -> Text
columnName ColumnName
newName)
          )
  where
    safetyPrefix :: PgSyntax -> PgSyntax
safetyPrefix PgSyntax
query =
      if EditSafety -> Edit -> Bool
editSafetyIs EditSafety
Safe Edit
e
        then ByteString -> PgSyntax
Pg.emit ByteString
"        " PgSyntax -> PgSyntax -> PgSyntax
forall a. Semigroup a => a -> a -> a
<> PgSyntax
query
        else ByteString -> PgSyntax
Pg.emit ByteString
"<UNSAFE>" PgSyntax -> PgSyntax -> PgSyntax
forall a. Semigroup a => a -> a -> a
<> PgSyntax
query

    ddlSyntax :: Text -> PgSyntax
ddlSyntax Text
query = ByteString -> PgSyntax
Pg.emit (ByteString -> PgSyntax)
-> (Text -> ByteString) -> Text -> PgSyntax
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
TE.encodeUtf8 (Text -> PgSyntax) -> Text -> PgSyntax
forall a b. (a -> b) -> a -> b
$ Text
query Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
";\n"
    updateSyntax :: Text -> PgSyntax
updateSyntax Text
query = ByteString -> PgSyntax
Pg.emit (ByteString -> PgSyntax)
-> (Text -> ByteString) -> Text -> PgSyntax
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
TE.encodeUtf8 (Text -> PgSyntax) -> Text -> PgSyntax
forall a b. (a -> b) -> a -> b
$ Text
query Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
";\n"

    alterTable :: TableName -> Text
    alterTable :: TableName -> Text
alterTable (TableName Text
tName) = Text
"ALTER TABLE " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
sqlEscaped Text
tName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "

    renderTableColumn :: (ColumnName, Column) -> Text
    renderTableColumn :: (ColumnName, Column) -> Text
renderTableColumn (ColumnName
colName, Column
col) =
      Text -> Text
sqlEscaped (ColumnName -> Text
columnName ColumnName
colName) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ColumnType -> Text
renderDataType (Column -> ColumnType
columnType Column
col)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
" " ((ColumnConstraint -> Text) -> [ColumnConstraint] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (AlterTableAction -> ColumnConstraint -> Text
renderColumnConstraint AlterTableAction
SetConstraint) (Set ColumnConstraint -> [ColumnConstraint]
forall a. Set a -> [a]
S.toList (Set ColumnConstraint -> [ColumnConstraint])
-> Set ColumnConstraint -> [ColumnConstraint]
forall a b. (a -> b) -> a -> b
$ Column -> Set ColumnConstraint
columnConstraints Column
col))

    renderInsertionOrder :: InsertionOrder -> Text
    renderInsertionOrder :: InsertionOrder -> Text
renderInsertionOrder InsertionOrder
Before = Text
"BEFORE"
    renderInsertionOrder InsertionOrder
After = Text
"AFTER"

    renderCreateTableConstraint :: TableConstraint -> Text
    renderCreateTableConstraint :: TableConstraint -> Text
renderCreateTableConstraint = \case
      Unique Text
fname Set ColumnName
cols ->
        Text
conKeyword Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
sqlEscaped Text
fname
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" UNIQUE ("
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " ((ColumnName -> Text) -> [ColumnName] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text
sqlEscaped (Text -> Text) -> (ColumnName -> Text) -> ColumnName -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ColumnName -> Text
columnName) (Set ColumnName -> [ColumnName]
forall a. Set a -> [a]
S.toList Set ColumnName
cols))
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
      PrimaryKey Text
fname Set ColumnName
cols ->
        Text
conKeyword Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
sqlEscaped Text
fname
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" PRIMARY KEY ("
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " ((ColumnName -> Text) -> [ColumnName] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text
sqlEscaped (Text -> Text) -> (ColumnName -> Text) -> ColumnName -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ColumnName -> Text
columnName) (Set ColumnName -> [ColumnName]
forall a. Set a -> [a]
S.toList Set ColumnName
cols))
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
      ForeignKey Text
fname (TableName -> Text
tableName -> Text
tName) (Set (ColumnName, ColumnName) -> [(ColumnName, ColumnName)]
forall a. Set a -> [a]
S.toList -> [(ColumnName, ColumnName)]
colPair) ReferenceAction
onDelete ReferenceAction
onUpdate ->
        let ([Text]
fkCols, [Text]
referenced) =
              ( ((ColumnName, ColumnName) -> Text)
-> [(ColumnName, ColumnName)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text
sqlEscaped (Text -> Text)
-> ((ColumnName, ColumnName) -> Text)
-> (ColumnName, ColumnName)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ColumnName -> Text
columnName (ColumnName -> Text)
-> ((ColumnName, ColumnName) -> ColumnName)
-> (ColumnName, ColumnName)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ColumnName, ColumnName) -> ColumnName
forall a b. (a, b) -> a
fst) [(ColumnName, ColumnName)]
colPair,
                ((ColumnName, ColumnName) -> Text)
-> [(ColumnName, ColumnName)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text
sqlEscaped (Text -> Text)
-> ((ColumnName, ColumnName) -> Text)
-> (ColumnName, ColumnName)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ColumnName -> Text
columnName (ColumnName -> Text)
-> ((ColumnName, ColumnName) -> ColumnName)
-> (ColumnName, ColumnName)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ColumnName, ColumnName) -> ColumnName
forall a b. (a, b) -> b
snd) [(ColumnName, ColumnName)]
colPair
              )
         in Text
conKeyword Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
sqlEscaped Text
fname
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" FOREIGN KEY ("
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
fkCols
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") REFERENCES "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
sqlEscaped Text
tName
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"("
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
referenced
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> ReferenceAction -> Text
forall a. (Monoid a, IsString a) => a -> ReferenceAction -> a
renderAction Text
"ON DELETE" ReferenceAction
onDelete
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> ReferenceAction -> Text
forall a. (Monoid a, IsString a) => a -> ReferenceAction -> a
renderAction Text
"ON UPDATE" ReferenceAction
onUpdate
      where
        conKeyword :: Text
conKeyword = Text
"CONSTRAINT "

    renderAddConstraint :: TableConstraint -> Text
    renderAddConstraint :: TableConstraint -> Text
renderAddConstraint = Text -> Text -> Text
forall a. Monoid a => a -> a -> a
mappend Text
"ADD " (Text -> Text)
-> (TableConstraint -> Text) -> TableConstraint -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableConstraint -> Text
renderCreateTableConstraint

    renderDropConstraint :: TableConstraint -> Text
    renderDropConstraint :: TableConstraint -> Text
renderDropConstraint TableConstraint
tc = case TableConstraint
tc of
      Unique Text
cName Set ColumnName
_ -> Text -> Text
dropC Text
cName
      PrimaryKey Text
cName Set ColumnName
_ -> Text -> Text
dropC Text
cName
      ForeignKey Text
cName TableName
_ Set (ColumnName, ColumnName)
_ ReferenceAction
_ ReferenceAction
_ -> Text -> Text
dropC Text
cName
      where
        dropC :: Text -> Text
dropC = Text -> Text -> Text
forall a. Monoid a => a -> a -> a
mappend Text
"DROP CONSTRAINT " (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
sqlEscaped

    renderAction :: a -> ReferenceAction -> a
renderAction a
actionPrefix = \case
      ReferenceAction
NoAction -> a
forall a. Monoid a => a
mempty
      ReferenceAction
Cascade -> a
" " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
actionPrefix a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
" " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"CASCADE "
      ReferenceAction
Restrict -> a
" " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
actionPrefix a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
" " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"RESTRICT "
      ReferenceAction
SetNull -> a
" " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
actionPrefix a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
" " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"SET NULL "
      ReferenceAction
SetDefault -> a
" " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
actionPrefix a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
" " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"SET DEFAULT "

    renderColumnConstraint :: AlterTableAction -> ColumnConstraint -> Text
    renderColumnConstraint :: AlterTableAction -> ColumnConstraint -> Text
renderColumnConstraint AlterTableAction
act = \case
      ColumnConstraint
NotNull -> Text
"NOT NULL"
      Default Text
defValue | AlterTableAction
act AlterTableAction -> AlterTableAction -> Bool
forall a. Eq a => a -> a -> Bool
== AlterTableAction
SetConstraint -> Text
"DEFAULT " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
defValue
      Default Text
_ -> Text
"DEFAULT"

    createTypeSyntax :: EnumerationName -> Enumeration -> Pg.PgSyntax
    createTypeSyntax :: EnumerationName -> Enumeration -> PgSyntax
createTypeSyntax (EnumerationName Text
ty) (Enumeration [Text]
vals) =
      ByteString -> PgSyntax
Pg.emit (ByteString -> PgSyntax) -> ByteString -> PgSyntax
forall a b. (a -> b) -> a -> b
$
        Text -> ByteString
forall a b. StringConv a b => a -> b
toS (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$
          Text
"CREATE TYPE " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ty Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" AS ENUM (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"," ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
sqlSingleQuoted [Text]
vals) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
");\n"

    createSequenceSyntax :: SequenceName -> Pg.PgSyntax
    createSequenceSyntax :: SequenceName -> PgSyntax
createSequenceSyntax (SequenceName Text
s) = ByteString -> PgSyntax
Pg.emit (ByteString -> PgSyntax) -> ByteString -> PgSyntax
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
forall a b. StringConv a b => a -> b
toS (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Text
"CREATE SEQUENCE " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
sqlEscaped Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
";\n"

    dropSequenceSyntax :: SequenceName -> Pg.PgSyntax
    dropSequenceSyntax :: SequenceName -> PgSyntax
dropSequenceSyntax (SequenceName Text
s) = ByteString -> PgSyntax
Pg.emit (ByteString -> PgSyntax) -> ByteString -> PgSyntax
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
forall a b. StringConv a b => a -> b
toS (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Text
"DROP SEQUENCE " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
sqlEscaped Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
";\n"

renderStdType :: AST.DataType -> Text
renderStdType :: DataType -> Text
renderStdType = \case
  -- From the Postgres' documentation:
  -- \"character without length specifier is equivalent to character(1).\"
  (AST.DataTypeChar Bool
False Maybe Word
prec Maybe Text
charSet) ->
    Text
"CHAR" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe Word -> Text
sqlOptPrec (Word -> Maybe Word
forall a. a -> Maybe a
Just (Word -> Maybe Word) -> Word -> Maybe Word
forall a b. (a -> b) -> a -> b
$ Word -> Maybe Word -> Word
forall a. a -> Maybe a -> a
fromMaybe Word
1 Maybe Word
prec) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe Text -> Text
sqlOptCharSet Maybe Text
charSet
  (AST.DataTypeChar Bool
True Maybe Word
prec Maybe Text
charSet) ->
    Text
"VARCHAR" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe Word -> Text
sqlOptPrec Maybe Word
prec Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe Text -> Text
sqlOptCharSet Maybe Text
charSet
  (AST.DataTypeNationalChar Bool
varying Maybe Word
prec) ->
    let ty :: Text
ty = if Bool
varying then Text
"NATIONAL CHARACTER VARYING" else Text
"NATIONAL CHAR"
     in Text
ty Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe Word -> Text
sqlOptPrec Maybe Word
prec
  (AST.DataTypeBit Bool
varying Maybe Word
prec) ->
    let ty :: Text
ty = if Bool
varying then Text
"BIT VARYING" else Text
"BIT"
     in Text
ty Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe Word -> Text
sqlOptPrec Maybe Word
prec
  (AST.DataTypeNumeric Maybe (Word, Maybe Word)
prec) -> Text
"NUMERIC" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe (Word, Maybe Word) -> Text
sqlOptNumericPrec Maybe (Word, Maybe Word)
prec
  -- Even though beam emits 'DOUBLE here'
  -- (see: https://github.com/tathougies/beam/blob/b245bf2c0b4c810dbac334d08ca572cec49e4d83/beam-postgres/Database/Beam/Postgres/Syntax.hs#L544)
  -- the \"double\" type doesn't exist in Postgres.
  -- Rather, the "NUMERIC" and "DECIMAL" types are equivalent in Postgres, and that's what we use here.
  (AST.DataTypeDecimal Maybe (Word, Maybe Word)
prec) -> Text
"NUMERIC" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe (Word, Maybe Word) -> Text
sqlOptNumericPrec Maybe (Word, Maybe Word)
prec
  DataType
AST.DataTypeInteger -> Text
"INT"
  DataType
AST.DataTypeSmallInt -> Text
"SMALLINT"
  DataType
AST.DataTypeBigInt -> Text
"BIGINT"
  (AST.DataTypeFloat Maybe Word
prec) -> Text
"FLOAT" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe Word -> Text
sqlOptPrec Maybe Word
prec
  DataType
AST.DataTypeReal -> Text
"REAL"
  DataType
AST.DataTypeDoublePrecision -> Text
"DOUBLE PRECISION"
  DataType
AST.DataTypeDate -> Text
"DATE"
  (AST.DataTypeTime Maybe Word
prec Bool
withTz) -> Bool -> Text -> Maybe Word -> Text
wTz Bool
withTz Text
"TIME" Maybe Word
prec Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe Word -> Text
sqlOptPrec Maybe Word
prec
  (AST.DataTypeTimeStamp Maybe Word
prec Bool
withTz) -> Bool -> Text -> Maybe Word -> Text
wTz Bool
withTz Text
"TIMESTAMP" Maybe Word
prec Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe Word -> Text
sqlOptPrec Maybe Word
prec
  (AST.DataTypeInterval ExtractField
_i) ->
    String -> Text
forall a. HasCallStack => String -> a
error (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$
      String
"Impossible: DataTypeInterval doesn't map to any SQLXX beam typeclass, so we don't know"
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" how to render it."
  (AST.DataTypeIntervalFromTo ExtractField
_from ExtractField
_to) ->
    String -> Text
forall a. HasCallStack => String -> a
error (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$
      String
"Impossible: DataTypeIntervalFromTo doesn't map to any SQLXX beam typeclass, so we don't know"
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" how to render it."
  DataType
AST.DataTypeBoolean -> Text
"BOOL"
  DataType
AST.DataTypeBinaryLargeObject -> Text
"BYTEA"
  DataType
AST.DataTypeCharacterLargeObject -> Text
"TEXT"
  (AST.DataTypeArray DataType
dt Int
sz) ->
    DataType -> Text
renderStdType DataType
dt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
sz) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"
  (AST.DataTypeRow [(Text, DataType)]
_rows) ->
    String -> Text
forall a. HasCallStack => String -> a
error String
"DataTypeRow not supported both for beam-postgres and this library."
  (AST.DataTypeDomain Text
nm) -> Text
"\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nm Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""
  where
    wTz :: Bool -> Text -> Maybe Word -> Text
wTz Bool
withTz Text
tt Maybe Word
prec =
      Text
tt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe Word -> Text
sqlOptPrec Maybe Word
prec Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if Bool
withTz then Text
" WITH" else Text
" WITHOUT") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" TIME ZONE"

-- This function also overlaps with beam-migrate functionalities.
renderDataType :: ColumnType -> Text
renderDataType :: ColumnType -> Text
renderDataType = \case
  SqlStdType DataType
stdType -> DataType -> Text
renderStdType DataType
stdType
  -- text-based enum types
  DbEnumeration (EnumerationName Text
_) Enumeration
_ ->
    ColumnType -> Text
renderDataType (DataType -> ColumnType
SqlStdType (Bool -> Maybe Word -> Maybe Text -> DataType
AST.DataTypeChar Bool
True Maybe Word
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing))
  -- Json types
  PgSpecificType PgDataType
PgJson -> String -> Text
forall a b. StringConv a b => a -> b
toS (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ PgDataTypeSyntax -> String
forall syntax. Sql92DisplaySyntax syntax => syntax -> String
displaySyntax PgDataTypeSyntax
Pg.pgJsonType
  PgSpecificType PgDataType
PgJsonB -> String -> Text
forall a b. StringConv a b => a -> b
toS (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ PgDataTypeSyntax -> String
forall syntax. Sql92DisplaySyntax syntax => syntax -> String
displaySyntax PgDataTypeSyntax
Pg.pgJsonbType
  -- Range types
  PgSpecificType PgDataType
PgRangeInt4 -> ByteString -> Text
forall a b. StringConv a b => a -> b
toS (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ PgIsRange PgInt4Range => ByteString
forall k (n :: k). PgIsRange n => ByteString
Pg.rangeName @Pg.PgInt4Range
  PgSpecificType PgDataType
PgRangeInt8 -> ByteString -> Text
forall a b. StringConv a b => a -> b
toS (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ PgIsRange PgInt8Range => ByteString
forall k (n :: k). PgIsRange n => ByteString
Pg.rangeName @Pg.PgInt8Range
  PgSpecificType PgDataType
PgRangeNum -> ByteString -> Text
forall a b. StringConv a b => a -> b
toS (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ PgIsRange PgNumRange => ByteString
forall k (n :: k). PgIsRange n => ByteString
Pg.rangeName @Pg.PgNumRange
  PgSpecificType PgDataType
PgRangeTs -> ByteString -> Text
forall a b. StringConv a b => a -> b
toS (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ PgIsRange PgTsRange => ByteString
forall k (n :: k). PgIsRange n => ByteString
Pg.rangeName @Pg.PgTsRange
  PgSpecificType PgDataType
PgRangeTsTz -> ByteString -> Text
forall a b. StringConv a b => a -> b
toS (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ PgIsRange PgTsTzRange => ByteString
forall k (n :: k). PgIsRange n => ByteString
Pg.rangeName @Pg.PgTsTzRange
  PgSpecificType PgDataType
PgRangeDate -> ByteString -> Text
forall a b. StringConv a b => a -> b
toS (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ PgIsRange PgDateRange => ByteString
forall k (n :: k). PgIsRange n => ByteString
Pg.rangeName @Pg.PgDateRange
  -- UUID
  PgSpecificType PgDataType
PgUuid -> String -> Text
forall a b. StringConv a b => a -> b
toS (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ PgDataTypeSyntax -> String
forall syntax. Sql92DisplaySyntax syntax => syntax -> String
displaySyntax PgDataTypeSyntax
Pg.pgUuidType
  -- enumerations
  PgSpecificType (PgEnumeration (EnumerationName Text
ty)) -> Text
ty
  -- oid
  PgSpecificType PgDataType
PgOid -> Text
"oid"
  -- ltree
  PgSpecificType PgDataType
PgLTree -> Text
"ltree"
  -- vector
  PgSpecificType (PgVector Maybe Natural
Nothing) -> Text
"vector"
  PgSpecificType (PgVector (Just Natural
n)) -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [Text
"vector(", String -> Text
T.pack (String -> Text) -> (Natural -> String) -> Natural -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> String
forall a. Show a => a -> String
show (Natural -> Text) -> Natural -> Text
forall a b. (a -> b) -> a -> b
$ Natural
n, Text
")"]
  -- Arrays
  SqlArrayType (SqlArrayType ColumnType
_ Word
_) Word
_ -> String -> Text
forall a. HasCallStack => String -> a
error String
"beam-automigrate: invalid nested array."
  SqlArrayType ColumnType
_ Word
0 -> String -> Text
forall a. HasCallStack => String -> a
error String
"beam-automigrate: array with zero dimensions"
  SqlArrayType ColumnType
t Word
d -> ColumnType -> Text
renderDataType ColumnType
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat (Int -> Text -> [Text]
forall a. Int -> a -> [a]
replicate (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
d) Text
"[]")

evalMigration :: Monad m => Migration m -> m (Either MigrationError [WithPriority Edit])
evalMigration :: Migration m -> m (Either MigrationError [WithPriority Edit])
evalMigration Migration m
m = do
  (Either MigrationError ()
a, [WithPriority Edit]
s) <- StateT [WithPriority Edit] m (Either MigrationError ())
-> [WithPriority Edit]
-> m (Either MigrationError (), [WithPriority Edit])
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (Migration m
-> StateT [WithPriority Edit] m (Either MigrationError ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT Migration m
m) [WithPriority Edit]
forall a. Monoid a => a
mempty
  case Either MigrationError ()
a of
    Left MigrationError
e -> Either MigrationError [WithPriority Edit]
-> m (Either MigrationError [WithPriority Edit])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MigrationError -> Either MigrationError [WithPriority Edit]
forall a b. a -> Either a b
Left MigrationError
e)
    Right () -> Either MigrationError [WithPriority Edit]
-> m (Either MigrationError [WithPriority Edit])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([WithPriority Edit] -> Either MigrationError [WithPriority Edit]
forall a b. b -> Either a b
Right [WithPriority Edit]
s)

-- | Create the migration from a 'Diff'.
createMigration :: Monad m => Diff -> Migration m
createMigration :: Diff -> Migration m
createMigration (Left DiffError
e) = MigrationError -> Migration m
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (DiffError -> MigrationError
DiffFailed DiffError
e)
createMigration (Right [WithPriority Edit]
edits) = StateT [WithPriority Edit] m (Either MigrationError ())
-> Migration m
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (StateT [WithPriority Edit] m (Either MigrationError ())
 -> Migration m)
-> StateT [WithPriority Edit] m (Either MigrationError ())
-> Migration m
forall a b. (a -> b) -> a -> b
$ do
  [WithPriority Edit] -> StateT [WithPriority Edit] m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put [WithPriority Edit]
edits
  Either MigrationError ()
-> StateT [WithPriority Edit] m (Either MigrationError ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Either MigrationError ()
forall a b. b -> Either a b
Right ())

-- | Prints the migration to stdout. Useful for debugging and diagnostic.
printMigration :: MonadIO m => Migration m -> m ()
printMigration :: Migration m -> m ()
printMigration Migration m
m = do
  Migration m -> m String
forall (m :: * -> *). MonadIO m => Migration m -> m String
showMigration Migration m
m m String -> (String -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (String -> IO ()) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn

-- | Pretty-prints the migration. Useful for debugging and diagnostic.
showMigration :: MonadIO m => Migration m -> m String
showMigration :: Migration m -> m String
showMigration Migration m
m = do
  (Either MigrationError ()
a, [WithPriority Edit]
sortedEdits) <- ([WithPriority Edit] -> [WithPriority Edit])
-> (Either MigrationError (), [WithPriority Edit])
-> (Either MigrationError (), [WithPriority Edit])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [WithPriority Edit] -> [WithPriority Edit]
sortEdits ((Either MigrationError (), [WithPriority Edit])
 -> (Either MigrationError (), [WithPriority Edit]))
-> m (Either MigrationError (), [WithPriority Edit])
-> m (Either MigrationError (), [WithPriority Edit])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT [WithPriority Edit] m (Either MigrationError ())
-> [WithPriority Edit]
-> m (Either MigrationError (), [WithPriority Edit])
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (Migration m
-> StateT [WithPriority Edit] m (Either MigrationError ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT Migration m
m) [WithPriority Edit]
forall a. Monoid a => a
mempty
  case Either MigrationError ()
a of
    Left MigrationError
e -> IO String -> m String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ MigrationError -> IO String
forall e a. Exception e => e -> IO a
throwIO MigrationError
e
    Right () -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (PgSyntax -> String) -> [PgSyntax] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PgSyntax -> String
forall syntax. Sql92DisplaySyntax syntax => syntax -> String
displaySyntax ([PgSyntax] -> [String]) -> [PgSyntax] -> [String]
forall a b. (a -> b) -> a -> b
$ [WithPriority Edit] -> [PgSyntax]
editsToPgSyntax [WithPriority Edit]
sortedEdits

printMigrationIO :: Migration Pg.Pg -> IO ()
printMigrationIO :: Migration Pg -> IO ()
printMigrationIO Migration Pg
mig = Connection -> Pg () -> IO ()
forall a. Connection -> Pg a -> IO a
Pg.runBeamPostgres (Connection
forall a. HasCallStack => a
undefined :: Pg.Connection) (Pg () -> IO ()) -> Pg () -> IO ()
forall a b. (a -> b) -> a -> b
$ Migration Pg -> Pg ()
forall (m :: * -> *). MonadIO m => Migration m -> m ()
printMigration Migration Pg
mig

editToSqlCommand :: Edit -> Pg.PgCommandSyntax
editToSqlCommand :: Edit -> PgCommandSyntax
editToSqlCommand = PgCommandType -> PgSyntax -> PgCommandSyntax
Pg.PgCommandSyntax PgCommandType
Pg.PgCommandTypeDdl (PgSyntax -> PgCommandSyntax)
-> (Edit -> PgSyntax) -> Edit -> PgCommandSyntax
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Edit -> PgSyntax
toSqlSyntax

prettyEditSQL :: Edit -> Text
prettyEditSQL :: Edit -> Text
prettyEditSQL = String -> Text
T.pack (String -> Text) -> (Edit -> String) -> Edit -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PgSyntax -> String
forall syntax. Sql92DisplaySyntax syntax => syntax -> String
displaySyntax (PgSyntax -> String) -> (Edit -> PgSyntax) -> Edit -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PgCommandSyntax -> PgSyntax
Pg.fromPgCommand (PgCommandSyntax -> PgSyntax)
-> (Edit -> PgCommandSyntax) -> Edit -> PgSyntax
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Edit -> PgCommandSyntax
editToSqlCommand

prettyEditActionDescription :: EditAction -> Text
prettyEditActionDescription :: EditAction -> Text
prettyEditActionDescription = [Text] -> Text
T.unwords ([Text] -> Text) -> (EditAction -> [Text]) -> EditAction -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
  EditAction_Automatic AutomaticEditAction
ea -> case AutomaticEditAction
ea of
    TableAdded TableName
tblName Table
table ->
      [Text
"create table:", TableName -> Text
qt TableName
tblName, Text
"\n", Table -> Text
forall a. Show a => a -> Text
pshow' Table
table]
    TableRemoved TableName
tblName ->
      [Text
"remove table:", TableName -> Text
qt TableName
tblName]
    TableConstraintAdded TableName
tblName TableConstraint
tableConstraint ->
      [Text
"add table constraint to:", TableName -> Text
qt TableName
tblName, Text
"\n", TableConstraint -> Text
forall a. Show a => a -> Text
pshow' TableConstraint
tableConstraint]
    TableConstraintRemoved TableName
tblName TableConstraint
tableConstraint ->
      [Text
"remove table constraint from:", TableName -> Text
qt TableName
tblName, Text
"\n", TableConstraint -> Text
forall a. Show a => a -> Text
pshow' TableConstraint
tableConstraint]
    ColumnAdded TableName
tblName ColumnName
colName Column
column ->
      [Text
"add column:", ColumnName -> Text
qc ColumnName
colName, Text
", from:", TableName -> Text
qt TableName
tblName, Text
"\n", Column -> Text
forall a. Show a => a -> Text
pshow' Column
column]
    ColumnRemoved TableName
tblName ColumnName
colName ->
      [Text
"remove column:", ColumnName -> Text
qc ColumnName
colName, Text
", from:", TableName -> Text
qt TableName
tblName]
    ColumnTypeChanged TableName
tblName ColumnName
colName ColumnType
oldColumnType ColumnType
newColumnType ->
      [ Text
"change type of column:",
        ColumnName -> Text
qc ColumnName
colName,
        Text
"in table:",
        TableName -> Text
qt TableName
tblName,
        Text
"\nfrom:",
        ColumnType -> Text
renderDataType ColumnType
oldColumnType,
        Text
"\nto:",
        ColumnType -> Text
renderDataType ColumnType
newColumnType
      ]
    ColumnConstraintAdded TableName
tblName ColumnName
colName ColumnConstraint
columnConstraint ->
      [ Text
"add column constraint to:",
        ColumnName -> Text
qc ColumnName
colName,
        Text
"in table:",
        TableName -> Text
qt TableName
tblName,
        Text
"\n",
        ColumnConstraint -> Text
forall a. Show a => a -> Text
pshow' ColumnConstraint
columnConstraint
      ]
    ColumnConstraintRemoved TableName
tblName ColumnName
colName ColumnConstraint
columnConstraint ->
      [ Text
"remove column constraint from:",
        ColumnName -> Text
qc ColumnName
colName,
        Text
"in table:",
        TableName -> Text
qt TableName
tblName,
        Text
"\n",
        ColumnConstraint -> Text
forall a. Show a => a -> Text
pshow' ColumnConstraint
columnConstraint
      ]
    EnumTypeAdded EnumerationName
eName Enumeration
enumeration ->
      [Text
"add enum type:", EnumerationName -> Text
enumName EnumerationName
eName, Enumeration -> Text
forall a. Show a => a -> Text
pshow' Enumeration
enumeration]
    EnumTypeRemoved EnumerationName
eName ->
      [Text
"remove enum type:", EnumerationName -> Text
enumName EnumerationName
eName]
    EnumTypeValueAdded EnumerationName
eName Text
newValue InsertionOrder
insertionOrder Text
insertedAt ->
      [ Text
"add enum value to enum:",
        EnumerationName -> Text
enumName EnumerationName
eName,
        Text
", value:",
        Text
newValue,
        Text
", with order:",
        InsertionOrder -> Text
forall a. Show a => a -> Text
pshow' InsertionOrder
insertionOrder,
        Text
", at pos",
        Text
insertedAt
      ]
    SequenceAdded SequenceName
sequenceName Sequence
sequence0 ->
      [Text
"add sequence:", SequenceName -> Text
qs SequenceName
sequenceName, Sequence -> Text
forall a. Show a => a -> Text
pshow' Sequence
sequence0]
    SequenceRemoved SequenceName
sequenceName ->
      [Text
"remove sequence:", SequenceName -> Text
qs SequenceName
sequenceName]
  EditAction_Manual ManualEditAction
ea -> case ManualEditAction
ea of
    ColumnRenamed TableName
tblName ColumnName
oldName ColumnName
newName ->
      [ Text
"rename column in table:",
        TableName -> Text
qt TableName
tblName,
        Text
"\nfrom:",
        ColumnName -> Text
qc ColumnName
oldName,
        Text
"\nto:",
        ColumnName -> Text
qc ColumnName
newName
      ]
  where
    q :: a -> a
q a
t = a
"'" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
t a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"'"
    qt :: TableName -> Text
qt = Text -> Text
forall a. (Semigroup a, IsString a) => a -> a
q (Text -> Text) -> (TableName -> Text) -> TableName -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableName -> Text
tableName
    qc :: ColumnName -> Text
qc = Text -> Text
forall a. (Semigroup a, IsString a) => a -> a
q (Text -> Text) -> (ColumnName -> Text) -> ColumnName -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ColumnName -> Text
columnName
    qs :: SequenceName -> Text
qs = Text -> Text
forall a. (Semigroup a, IsString a) => a -> a
q (Text -> Text) -> (SequenceName -> Text) -> SequenceName -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SequenceName -> Text
seqName

    pshow' :: Show a => a -> Text
    pshow' :: a -> Text
pshow' = Text -> Text
LT.toStrict (Text -> Text) -> (a -> Text) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Text
forall a. Show a => a -> Text
PS.pShow

prettyPrintEdits :: [WithPriority Edit] -> IO ()
prettyPrintEdits :: [WithPriority Edit] -> IO ()
prettyPrintEdits [WithPriority Edit]
edits = String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (WithPriority Edit -> Text) -> [WithPriority Edit] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Edit -> Text
prettyEditSQL (Edit -> Text)
-> (WithPriority Edit -> Edit) -> WithPriority Edit -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Edit, Priority) -> Edit
forall a b. (a, b) -> a
fst ((Edit, Priority) -> Edit)
-> (WithPriority Edit -> (Edit, Priority))
-> WithPriority Edit
-> Edit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithPriority Edit -> (Edit, Priority)
forall a. WithPriority a -> (a, Priority)
unPriority) ([WithPriority Edit] -> [WithPriority Edit]
sortEdits [WithPriority Edit]
edits)

-- | Compare the existing schema in the database with the expected
-- schema in Haskell and try to edit the existing schema as necessary
tryRunMigrationsWithEditUpdate
  :: ( Generic (db (DatabaseEntity be db))
     , (Generic (db (AnnotatedDatabaseEntity be db)))
     , Database be db
     , (GZipDatabase be
         (AnnotatedDatabaseEntity be db)
         (AnnotatedDatabaseEntity be db)
         (DatabaseEntity be db)
         (Rep (db (AnnotatedDatabaseEntity be db)))
         (Rep (db (AnnotatedDatabaseEntity be db)))
         (Rep (db (DatabaseEntity be db)))
       )
     , (GSchema be db '[] (Rep (db (AnnotatedDatabaseEntity be db))))
     )
  => AnnotatedDatabaseSettings be db
  -> Pg.Connection
  -> IO ()
tryRunMigrationsWithEditUpdate :: AnnotatedDatabaseSettings be db -> Connection -> IO ()
tryRunMigrationsWithEditUpdate AnnotatedDatabaseSettings be db
annotatedDb Connection
conn = do
    let expectedHaskellSchema :: Schema
expectedHaskellSchema = AnnotatedDatabaseSettings be db -> Proxy '[] -> Schema
forall be (db :: (* -> *) -> *) (anns :: [Annotation]).
(FromAnnotated be db DatabaseEntity AnnotatedDatabaseEntity,
 GSchema be db anns (Rep (AnnotatedDatabaseSettings be db))) =>
AnnotatedDatabaseSettings be db -> Proxy anns -> Schema
fromAnnotatedDbSettings AnnotatedDatabaseSettings be db
annotatedDb (Proxy '[]
forall k (t :: k). Proxy t
Proxy @'[])
    Schema
actualDatabaseSchema <- Connection -> IO Schema
getSchema Connection
conn
    case Schema -> Schema -> Diff
forall a. Diffable a => a -> a -> Diff
diff Schema
expectedHaskellSchema Schema
actualDatabaseSchema of
      Left DiffError
err -> do
        String -> IO ()
putStrLn String
"Error detecting database migration requirements: "
        DiffError -> IO ()
forall a. Show a => a -> IO ()
print DiffError
err
      Right [] ->
        String -> IO ()
putStrLn String
"No database migration required, continuing startup."
      Right [WithPriority Edit]
edits -> do
        String -> IO ()
putStrLn String
"Database migration required, attempting..."
        [WithPriority Edit] -> IO ()
prettyPrintEdits [WithPriority Edit]
edits

        IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
try (MonadBeam Postgres Pg =>
([WithPriority Edit] -> [WithPriority Edit])
-> Connection -> Schema -> IO ()
([WithPriority Edit] -> [WithPriority Edit])
-> Connection -> Schema -> IO ()
runMigrationWithEditUpdate [WithPriority Edit] -> [WithPriority Edit]
forall a. a -> a
Prelude.id Connection
conn Schema
expectedHaskellSchema) IO (Either SomeException ())
-> (Either SomeException () -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Left (SomeException
e :: SomeException) ->
            String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Database migration error: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e
          Right ()
_ ->
            () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Compute the `Diff` consisting of the steps that would be taken to migrate from the current actual
-- database schema to the given one, without actually performing the migration.
calcMigrationSteps
  :: ( Generic (db (DatabaseEntity be db))
     , (Generic (db (AnnotatedDatabaseEntity be db)))
     , Database be db
     , (GZipDatabase be
         (AnnotatedDatabaseEntity be db)
         (AnnotatedDatabaseEntity be db)
         (DatabaseEntity be db)
         (Rep (db (AnnotatedDatabaseEntity be db)))
         (Rep (db (AnnotatedDatabaseEntity be db)))
         (Rep (db (DatabaseEntity be db)))
       )
     , (GSchema be db '[] (Rep (db (AnnotatedDatabaseEntity be db))))
     )
  => AnnotatedDatabaseSettings be db
  -> Pg.Connection
  -> IO Diff
calcMigrationSteps :: AnnotatedDatabaseSettings be db -> Connection -> IO Diff
calcMigrationSteps AnnotatedDatabaseSettings be db
annotatedDb Connection
conn = do
    let expectedHaskellSchema :: Schema
expectedHaskellSchema = AnnotatedDatabaseSettings be db -> Proxy '[] -> Schema
forall be (db :: (* -> *) -> *) (anns :: [Annotation]).
(FromAnnotated be db DatabaseEntity AnnotatedDatabaseEntity,
 GSchema be db anns (Rep (AnnotatedDatabaseSettings be db))) =>
AnnotatedDatabaseSettings be db -> Proxy anns -> Schema
fromAnnotatedDbSettings AnnotatedDatabaseSettings be db
annotatedDb (Proxy '[]
forall k (t :: k). Proxy t
Proxy @'[])
    Schema
actualDatabaseSchema <- Connection -> IO Schema
getSchema Connection
conn
    Diff -> IO Diff
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Diff -> IO Diff) -> Diff -> IO Diff
forall a b. (a -> b) -> a -> b
$ Schema -> Schema -> Diff
forall a. Diffable a => a -> a -> Diff
diff Schema
expectedHaskellSchema Schema
actualDatabaseSchema