module Database.PostgreSQL.PQTypes.Checks (
checkDatabase
, createTable
, createDomain
, ExtrasOptions(..)
, defaultExtrasOptions
, ObjectsValidationMode(..)
, migrateDatabase
) where
import Control.Arrow ((&&&))
import Control.Concurrent (threadDelay)
import Control.Monad
import Control.Monad.Catch
import Control.Monad.Reader
import Data.Int
import Data.Function
import Data.List (partition)
import Data.Maybe
import Data.Monoid.Utils
import Data.Ord (comparing)
import Data.Typeable (cast)
import qualified Data.String
import Data.Text (Text)
import Database.PostgreSQL.PQTypes
import GHC.Stack (HasCallStack)
import Log
import TextShow
import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Text as T
import Database.PostgreSQL.PQTypes.ExtrasOptions
import Database.PostgreSQL.PQTypes.Checks.Util
import Database.PostgreSQL.PQTypes.Migrate
import Database.PostgreSQL.PQTypes.Model
import Database.PostgreSQL.PQTypes.SQL.Builder
import Database.PostgreSQL.PQTypes.Versions
headExc :: String -> [a] -> a
headExc :: forall a. String -> [a] -> a
headExc String
s [] = forall a. HasCallStack => String -> a
error String
s
headExc String
_ (a
x:[a]
_) = a
x
migrateDatabase
:: (MonadIO m, MonadDB m, MonadLog m, MonadMask m)
=> ExtrasOptions
-> [Extension]
-> [CompositeType]
-> [Domain]
-> [Table]
-> [Migration m]
-> m ()
migrateDatabase :: forall (m :: * -> *).
(MonadIO m, MonadDB m, MonadLog m, MonadMask m) =>
ExtrasOptions
-> [Extension]
-> [CompositeType]
-> [Domain]
-> [Table]
-> [Migration m]
-> m ()
migrateDatabase ExtrasOptions
options
[Extension]
extensions [CompositeType]
composites [Domain]
domains [Table]
tables [Migration m]
migrations = do
forall (m :: * -> *). (MonadDB m, MonadLog m, MonadThrow m) => m ()
setDBTimeZoneToUTC
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *).
(MonadDB m, MonadLog m, MonadThrow m) =>
Extension -> m ()
checkExtension [Extension]
extensions
TablesWithVersions
tablesWithVersions <- forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
[Table] -> m TablesWithVersions
getTableVersions (Table
tableVersions forall a. a -> [a] -> [a]
: [Table]
tables)
forall (m :: * -> *).
(MonadIO m, MonadDB m, MonadLog m, MonadMask m) =>
ExtrasOptions
-> [Domain] -> TablesWithVersions -> [Migration m] -> m ()
checkDBConsistency ExtrasOptions
options [Domain]
domains TablesWithVersions
tablesWithVersions [Migration m]
migrations
forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
MonadDB m =>
TablesWithVersions
-> CompositesCreationMode
-> ObjectsValidationMode
-> [CompositeType]
-> m ValidationResult
checkCompositesStructure TablesWithVersions
tablesWithVersions
CompositesCreationMode
CreateCompositesIfDatabaseEmpty
(ExtrasOptions -> ObjectsValidationMode
eoObjectsValidationMode ExtrasOptions
options)
[CompositeType]
composites
forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
[Domain] -> m ValidationResult
checkDomainsStructure [Domain]
domains
forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
ExtrasOptions -> TablesWithVersions -> m ValidationResult
checkDBStructure ExtrasOptions
options TablesWithVersions
tablesWithVersions
forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
[Migration m] -> m ValidationResult
checkTablesWereDropped [Migration m]
migrations
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExtrasOptions -> ObjectsValidationMode
eoObjectsValidationMode ExtrasOptions
options forall a. Eq a => a -> a -> Bool
== ObjectsValidationMode
DontAllowUnknownObjects) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
(MonadDB m, MonadLog m) =>
[Table] -> m ValidationResult
checkUnknownTables [Table]
tables
forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
(MonadDB m, MonadLog m) =>
[Table] -> m ValidationResult
checkExistenceOfVersionsForTables (Table
tableVersions forall a. a -> [a] -> [a]
: [Table]
tables)
forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtrasOptions -> TablesWithVersions -> ValidationResult
checkVersions ExtrasOptions
options forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
[Table] -> m TablesWithVersions
getTableVersions (Table
tableVersions forall a. a -> [a] -> [a]
: [Table]
tables)
forall (m :: * -> *). MonadDB m => m ()
commit
checkDatabase
:: forall m . (MonadDB m, MonadLog m, MonadThrow m)
=> ExtrasOptions
-> [CompositeType]
-> [Domain]
-> [Table]
-> m ()
checkDatabase :: forall (m :: * -> *).
(MonadDB m, MonadLog m, MonadThrow m) =>
ExtrasOptions -> [CompositeType] -> [Domain] -> [Table] -> m ()
checkDatabase ExtrasOptions
options [CompositeType]
composites [Domain]
domains [Table]
tables = do
TablesWithVersions
tablesWithVersions <- forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
[Table] -> m TablesWithVersions
getTableVersions (Table
tableVersions forall a. a -> [a] -> [a]
: [Table]
tables)
forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck forall a b. (a -> b) -> a -> b
$ ExtrasOptions -> TablesWithVersions -> ValidationResult
checkVersions ExtrasOptions
options TablesWithVersions
tablesWithVersions
forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
MonadDB m =>
TablesWithVersions
-> CompositesCreationMode
-> ObjectsValidationMode
-> [CompositeType]
-> m ValidationResult
checkCompositesStructure TablesWithVersions
tablesWithVersions
CompositesCreationMode
DontCreateComposites
(ExtrasOptions -> ObjectsValidationMode
eoObjectsValidationMode ExtrasOptions
options)
[CompositeType]
composites
forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
[Domain] -> m ValidationResult
checkDomainsStructure [Domain]
domains
forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
ExtrasOptions -> TablesWithVersions -> m ValidationResult
checkDBStructure ExtrasOptions
options TablesWithVersions
tablesWithVersions
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExtrasOptions -> ObjectsValidationMode
eoObjectsValidationMode ExtrasOptions
options forall a. Eq a => a -> a -> Bool
== ObjectsValidationMode
DontAllowUnknownObjects) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
(MonadDB m, MonadLog m) =>
[Table] -> m ValidationResult
checkUnknownTables [Table]
tables
forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
(MonadDB m, MonadLog m) =>
[Table] -> m ValidationResult
checkExistenceOfVersionsForTables (Table
tableVersions forall a. a -> [a] -> [a]
: [Table]
tables)
forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Table] -> m ValidationResult
checkInitialSetups [Table]
tables
where
checkInitialSetups :: [Table] -> m ValidationResult
checkInitialSetups :: [Table] -> m ValidationResult
checkInitialSetups [Table]
tbls =
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Table -> m ValidationResult
checkInitialSetup' forall a b. (a -> b) -> a -> b
$ [Table]
tbls
checkInitialSetup' :: Table -> m ValidationResult
checkInitialSetup' :: Table -> m ValidationResult
checkInitialSetup' t :: Table
t@Table{Int32
[Check]
[ForeignKey]
[TableIndex]
[Trigger]
[TableColumn]
Maybe PrimaryKey
Maybe TableInitialSetup
RawSQL ()
tblInitialSetup :: Table -> Maybe TableInitialSetup
tblTriggers :: Table -> [Trigger]
tblIndexes :: Table -> [TableIndex]
tblForeignKeys :: Table -> [ForeignKey]
tblChecks :: Table -> [Check]
tblPrimaryKey :: Table -> Maybe PrimaryKey
tblColumns :: Table -> [TableColumn]
tblVersion :: Table -> Int32
tblName :: Table -> RawSQL ()
tblInitialSetup :: Maybe TableInitialSetup
tblTriggers :: [Trigger]
tblIndexes :: [TableIndex]
tblForeignKeys :: [ForeignKey]
tblChecks :: [Check]
tblPrimaryKey :: Maybe PrimaryKey
tblColumns :: [TableColumn]
tblVersion :: Int32
tblName :: RawSQL ()
..} = case Maybe TableInitialSetup
tblInitialSetup of
Maybe TableInitialSetup
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
Just TableInitialSetup
is -> TableInitialSetup
-> forall (m :: * -> *). (MonadDB m, MonadThrow m) => m Bool
checkInitialSetup TableInitialSetup
is forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
True -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ValidationResult
validationError forall a b. (a -> b) -> a -> b
$ Text
"Initial setup for table '"
forall a. Semigroup a => a -> a -> a
<> Table -> Text
tblNameText Table
t forall a. Semigroup a => a -> a -> a
<> Text
"' is not valid"
currentCatalog :: (MonadDB m, MonadThrow m) => m (RawSQL ())
currentCatalog :: forall (m :: * -> *). (MonadDB m, MonadThrow m) => m (RawSQL ())
currentCatalog = do
forall (m :: * -> *). MonadDB m => SQL -> m ()
runSQL_ SQL
"SELECT current_catalog::text"
String
dbname <- forall (m :: * -> *) row t.
(MonadDB m, MonadThrow m, FromRow row) =>
(row -> t) -> m t
fetchOne forall a. Identity a -> a
runIdentity
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL forall a b. (a -> b) -> a -> b
$ String
"\"" forall a. [a] -> [a] -> [a]
++ String
dbname forall a. [a] -> [a] -> [a]
++ String
"\""
checkExtension :: (MonadDB m, MonadLog m, MonadThrow m) => Extension -> m ()
checkExtension :: forall (m :: * -> *).
(MonadDB m, MonadLog m, MonadThrow m) =>
Extension -> m ()
checkExtension (Extension RawSQL ()
extension) = do
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ forall a b. (a -> b) -> a -> b
$ Text
"Checking for extension '" forall a. Semigroup a => a -> a -> a
<> Text
txtExtension forall a. Semigroup a => a -> a -> a
<> Text
"'"
Bool
extensionExists <- forall sql (m :: * -> *).
(IsSQL sql, MonadDB m, MonadThrow m) =>
sql -> m Bool
runQuery01 forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_extension" forall a b. (a -> b) -> a -> b
$ do
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"TRUE"
forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"extname" forall a b. (a -> b) -> a -> b
$ RawSQL () -> Text
unRawSQL RawSQL ()
extension
if Bool -> Bool
not Bool
extensionExists
then do
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ forall a b. (a -> b) -> a -> b
$ Text
"Creating extension '" forall a. Semigroup a => a -> a -> a
<> Text
txtExtension forall a. Semigroup a => a -> a -> a
<> Text
"'"
forall (m :: * -> *). MonadDB m => SQL -> m ()
runSQL_ forall a b. (a -> b) -> a -> b
$ SQL
"CREATE EXTENSION IF NOT EXISTS" forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL () -> SQL
raw RawSQL ()
extension
else forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ forall a b. (a -> b) -> a -> b
$ Text
"Extension '" forall a. Semigroup a => a -> a -> a
<> Text
txtExtension forall a. Semigroup a => a -> a -> a
<> Text
"' exists"
where
txtExtension :: Text
txtExtension = RawSQL () -> Text
unRawSQL RawSQL ()
extension
setDBTimeZoneToUTC :: (MonadDB m, MonadLog m, MonadThrow m) => m ()
setDBTimeZoneToUTC :: forall (m :: * -> *). (MonadDB m, MonadLog m, MonadThrow m) => m ()
setDBTimeZoneToUTC = do
forall (m :: * -> *). MonadDB m => SQL -> m ()
runSQL_ SQL
"SHOW timezone"
String
timezone :: String <- forall (m :: * -> *) row t.
(MonadDB m, MonadThrow m, FromRow row) =>
(row -> t) -> m t
fetchOne forall a. Identity a -> a
runIdentity
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
timezone forall a. Eq a => a -> a -> Bool
/= String
"UTC") forall a b. (a -> b) -> a -> b
$ do
RawSQL ()
dbname <- forall (m :: * -> *). (MonadDB m, MonadThrow m) => m (RawSQL ())
currentCatalog
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ forall a b. (a -> b) -> a -> b
$ Text
"Setting '" forall a. Semigroup a => a -> a -> a
<> RawSQL () -> Text
unRawSQL RawSQL ()
dbname
forall a. Semigroup a => a -> a -> a
<> Text
"' database to return timestamps in UTC"
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ forall a b. (a -> b) -> a -> b
$ RawSQL ()
"ALTER DATABASE" forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
dbname forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
"SET TIMEZONE = 'UTC'"
getDBTableNames :: (MonadDB m) => m [Text]
getDBTableNames :: forall (m :: * -> *). MonadDB m => m [Text]
getDBTableNames = do
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ forall a b. (a -> b) -> a -> b
$ SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"information_schema.tables" forall a b. (a -> b) -> a -> b
$ do
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"table_name::text"
forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere SQL
"table_name <> 'table_versions'"
forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere SQL
"table_type = 'BASE TABLE'"
forall v (m :: * -> *).
(MonadState v m, SqlWhere v) =>
SqlSelect -> m ()
sqlWhereExists forall a b. (a -> b) -> a -> b
$ SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"unnest(current_schemas(false)) as cs" forall a b. (a -> b) -> a -> b
$ do
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"TRUE"
forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere SQL
"cs = table_schema"
[Text]
dbTableNames <- forall (m :: * -> *) row t.
(MonadDB m, FromRow row) =>
(row -> t) -> m [t]
fetchMany forall a. Identity a -> a
runIdentity
forall (m :: * -> *) a. Monad m => a -> m a
return [Text]
dbTableNames
checkVersions :: ExtrasOptions -> TablesWithVersions -> ValidationResult
checkVersions :: ExtrasOptions -> TablesWithVersions -> ValidationResult
checkVersions ExtrasOptions
options = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Table, Int32) -> ValidationResult
checkVersion
where
checkVersion :: (Table, Int32) -> ValidationResult
checkVersion :: (Table, Int32) -> ValidationResult
checkVersion (t :: Table
t@Table{Int32
[Check]
[ForeignKey]
[TableIndex]
[Trigger]
[TableColumn]
Maybe PrimaryKey
Maybe TableInitialSetup
RawSQL ()
tblInitialSetup :: Maybe TableInitialSetup
tblTriggers :: [Trigger]
tblIndexes :: [TableIndex]
tblForeignKeys :: [ForeignKey]
tblChecks :: [Check]
tblPrimaryKey :: Maybe PrimaryKey
tblColumns :: [TableColumn]
tblVersion :: Int32
tblName :: RawSQL ()
tblInitialSetup :: Table -> Maybe TableInitialSetup
tblTriggers :: Table -> [Trigger]
tblIndexes :: Table -> [TableIndex]
tblForeignKeys :: Table -> [ForeignKey]
tblChecks :: Table -> [Check]
tblPrimaryKey :: Table -> Maybe PrimaryKey
tblColumns :: Table -> [TableColumn]
tblVersion :: Table -> Int32
tblName :: Table -> RawSQL ()
..}, Int32
v)
| if ExtrasOptions -> Bool
eoAllowHigherTableVersions ExtrasOptions
options
then Int32
tblVersion forall a. Ord a => a -> a -> Bool
<= Int32
v
else Int32
tblVersion forall a. Eq a => a -> a -> Bool
== Int32
v = forall a. Monoid a => a
mempty
| Int32
v forall a. Eq a => a -> a -> Bool
== Int32
0 = Text -> ValidationResult
validationError forall a b. (a -> b) -> a -> b
$
Text
"Table '" forall a. Semigroup a => a -> a -> a
<> Table -> Text
tblNameText Table
t forall a. Semigroup a => a -> a -> a
<> Text
"' must be created"
| Bool
otherwise = Text -> ValidationResult
validationError forall a b. (a -> b) -> a -> b
$
Text
"Table '" forall a. Semigroup a => a -> a -> a
<> Table -> Text
tblNameText Table
t
forall a. Semigroup a => a -> a -> a
<> Text
"' must be migrated" forall m. (IsString m, Monoid m) => m -> m -> m
<+> forall a. TextShow a => a -> Text
showt Int32
v forall m. (IsString m, Monoid m) => m -> m -> m
<+> Text
"->"
forall m. (IsString m, Monoid m) => m -> m -> m
<+> forall a. TextShow a => a -> Text
showt Int32
tblVersion
checkUnknownTables :: (MonadDB m, MonadLog m) => [Table] -> m ValidationResult
checkUnknownTables :: forall (m :: * -> *).
(MonadDB m, MonadLog m) =>
[Table] -> m ValidationResult
checkUnknownTables [Table]
tables = do
[Text]
dbTableNames <- forall (m :: * -> *). MonadDB m => m [Text]
getDBTableNames
let tableNames :: [Text]
tableNames = forall a b. (a -> b) -> [a] -> [b]
map (RawSQL () -> Text
unRawSQL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Table -> RawSQL ()
tblName) [Table]
tables
absent :: [Text]
absent = [Text]
dbTableNames forall a. Eq a => [a] -> [a] -> [a]
L.\\ [Text]
tableNames
notPresent :: [Text]
notPresent = [Text]
tableNames forall a. Eq a => [a] -> [a] -> [a]
L.\\ [Text]
dbTableNames
if (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ [Text]
absent) Bool -> Bool -> Bool
|| (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ [Text]
notPresent)
then do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. (IsString m, Monoid m) => m -> m -> m
(<+>) Text
"Unknown table:") [Text]
absent
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. (IsString m, Monoid m) => m -> m -> m
(<+>) Text
"Table not present in the database:") [Text]
notPresent
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
(Text -> [Text] -> ValidationResult
validateIsNull Text
"Unknown tables:" [Text]
absent) forall a. Semigroup a => a -> a -> a
<>
(Text -> [Text] -> ValidationResult
validateIsNull Text
"Tables not present in the database:" [Text]
notPresent)
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
validateIsNull :: Text -> [Text] -> ValidationResult
validateIsNull :: Text -> [Text] -> ValidationResult
validateIsNull Text
_ [] = forall a. Monoid a => a
mempty
validateIsNull Text
msg [Text]
ts = Text -> ValidationResult
validationError forall a b. (a -> b) -> a -> b
$ Text
msg forall m. (IsString m, Monoid m) => m -> m -> m
<+> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
ts
checkExistenceOfVersionsForTables
:: (MonadDB m, MonadLog m)
=> [Table] -> m ValidationResult
checkExistenceOfVersionsForTables :: forall (m :: * -> *).
(MonadDB m, MonadLog m) =>
[Table] -> m ValidationResult
checkExistenceOfVersionsForTables [Table]
tables = do
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ forall a b. (a -> b) -> a -> b
$ SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"table_versions" forall a b. (a -> b) -> a -> b
$ do
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"name::text"
([Text]
existingTableNames :: [Text]) <- forall (m :: * -> *) row t.
(MonadDB m, FromRow row) =>
(row -> t) -> m [t]
fetchMany forall a. Identity a -> a
runIdentity
let tableNames :: [Text]
tableNames = forall a b. (a -> b) -> [a] -> [b]
map (RawSQL () -> Text
unRawSQL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Table -> RawSQL ()
tblName) [Table]
tables
absent :: [Text]
absent = [Text]
existingTableNames forall a. Eq a => [a] -> [a] -> [a]
L.\\ [Text]
tableNames
notPresent :: [Text]
notPresent = [Text]
tableNames forall a. Eq a => [a] -> [a] -> [a]
L.\\ [Text]
existingTableNames
if (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ [Text]
absent) Bool -> Bool -> Bool
|| (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ [Text]
notPresent)
then do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. (IsString m, Monoid m) => m -> m -> m
(<+>) Text
"Unknown entry in 'table_versions':") [Text]
absent
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. (IsString m, Monoid m) => m -> m -> m
(<+>) Text
"Table not present in the 'table_versions':")
[Text]
notPresent
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
(Text -> [Text] -> ValidationResult
validateIsNull Text
"Unknown entry in table_versions':" [Text]
absent ) forall a. Semigroup a => a -> a -> a
<>
(Text -> [Text] -> ValidationResult
validateIsNull Text
"Tables not present in the 'table_versions':" [Text]
notPresent)
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
checkDomainsStructure :: (MonadDB m, MonadThrow m)
=> [Domain] -> m ValidationResult
checkDomainsStructure :: forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
[Domain] -> m ValidationResult
checkDomainsStructure [Domain]
defs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Domain]
defs forall a b. (a -> b) -> a -> b
$ \Domain
def -> do
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_type t1" forall a b. (a -> b) -> a -> b
$ do
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"t1.typname::text"
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"(SELECT pg_catalog.format_type(t2.oid, t2.typtypmod) \
\FROM pg_catalog.pg_type t2 \
\WHERE t2.oid = t1.typbasetype)"
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"NOT t1.typnotnull"
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"t1.typdefault"
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"ARRAY(SELECT c.conname::text FROM pg_catalog.pg_constraint c \
\WHERE c.contypid = t1.oid ORDER by c.oid)"
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"ARRAY(SELECT regexp_replace(pg_get_constraintdef(c.oid, true), '\
\CHECK \\((.*)\\)', '\\1') FROM pg_catalog.pg_constraint c \
\WHERE c.contypid = t1.oid \
\ORDER by c.oid)"
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"ARRAY(SELECT c.convalidated FROM pg_catalog.pg_constraint c \
\WHERE c.contypid = t1.oid \
\ORDER by c.oid)"
forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"t1.typname" forall a b. (a -> b) -> a -> b
$ RawSQL () -> Text
unRawSQL forall a b. (a -> b) -> a -> b
$ Domain -> RawSQL ()
domName Domain
def
Maybe Domain
mdom <- forall (m :: * -> *) row t.
(MonadDB m, MonadThrow m, FromRow row) =>
(row -> t) -> m (Maybe t)
fetchMaybe forall a b. (a -> b) -> a -> b
$
\(String
dname, ColumnType
dtype, Bool
nullable, Maybe String
defval, Array1 String
cnames, Array1 String
conds, Array1 Bool
valids) ->
Domain
{ domName :: RawSQL ()
domName = forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL String
dname
, domType :: ColumnType
domType = ColumnType
dtype
, domNullable :: Bool
domNullable = Bool
nullable
, domDefault :: Maybe (RawSQL ())
domDefault = forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
defval
, domChecks :: Set Check
domChecks =
[Check] -> Set Check
mkChecks forall a b. (a -> b) -> a -> b
$ forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3
(\String
cname String
cond Bool
validated ->
Check
{ chkName :: RawSQL ()
chkName = forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL String
cname
, chkCondition :: RawSQL ()
chkCondition = forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL String
cond
, chkValidated :: Bool
chkValidated = Bool
validated
}) (forall a. Array1 a -> [a]
unArray1 Array1 String
cnames) (forall a. Array1 a -> [a]
unArray1 Array1 String
conds) (forall a. Array1 a -> [a]
unArray1 Array1 Bool
valids)
}
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Maybe Domain
mdom of
Just Domain
dom
| Domain
dom forall a. Eq a => a -> a -> Bool
/= Domain
def -> Text -> Text -> ValidationResult -> ValidationResult
topMessage Text
"domain" (RawSQL () -> Text
unRawSQL forall a b. (a -> b) -> a -> b
$ Domain -> RawSQL ()
domName Domain
dom) forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [
forall a.
(Eq a, Show a) =>
Domain -> Domain -> Text -> (Domain -> a) -> ValidationResult
compareAttr Domain
dom Domain
def Text
"name" Domain -> RawSQL ()
domName
, forall a.
(Eq a, Show a) =>
Domain -> Domain -> Text -> (Domain -> a) -> ValidationResult
compareAttr Domain
dom Domain
def Text
"type" Domain -> ColumnType
domType
, forall a.
(Eq a, Show a) =>
Domain -> Domain -> Text -> (Domain -> a) -> ValidationResult
compareAttr Domain
dom Domain
def Text
"nullable" Domain -> Bool
domNullable
, forall a.
(Eq a, Show a) =>
Domain -> Domain -> Text -> (Domain -> a) -> ValidationResult
compareAttr Domain
dom Domain
def Text
"default" Domain -> Maybe (RawSQL ())
domDefault
, forall a.
(Eq a, Show a) =>
Domain -> Domain -> Text -> (Domain -> a) -> ValidationResult
compareAttr Domain
dom Domain
def Text
"checks" Domain -> Set Check
domChecks
]
| Bool
otherwise -> forall a. Monoid a => a
mempty
Maybe Domain
Nothing -> Text -> ValidationResult
validationError forall a b. (a -> b) -> a -> b
$ Text
"Domain '" forall a. Semigroup a => a -> a -> a
<> RawSQL () -> Text
unRawSQL (Domain -> RawSQL ()
domName Domain
def)
forall a. Semigroup a => a -> a -> a
<> Text
"' doesn't exist in the database"
where
compareAttr :: (Eq a, Show a)
=> Domain -> Domain -> Text -> (Domain -> a) -> ValidationResult
compareAttr :: forall a.
(Eq a, Show a) =>
Domain -> Domain -> Text -> (Domain -> a) -> ValidationResult
compareAttr Domain
dom Domain
def Text
attrname Domain -> a
attr
| Domain -> a
attr Domain
dom forall a. Eq a => a -> a -> Bool
== Domain -> a
attr Domain
def = forall a. Monoid a => a
mempty
| Bool
otherwise = Text -> ValidationResult
validationError forall a b. (a -> b) -> a -> b
$
Text
"Attribute '" forall a. Semigroup a => a -> a -> a
<> Text
attrname
forall a. Semigroup a => a -> a -> a
<> Text
"' does not match (database:" forall m. (IsString m, Monoid m) => m -> m -> m
<+> String -> Text
T.pack (forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Domain -> a
attr Domain
dom)
forall a. Semigroup a => a -> a -> a
<> Text
", definition:" forall m. (IsString m, Monoid m) => m -> m -> m
<+> String -> Text
T.pack (forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Domain -> a
attr Domain
def) forall a. Semigroup a => a -> a -> a
<> Text
")"
checkTablesWereDropped :: (MonadDB m, MonadThrow m) =>
[Migration m] -> m ValidationResult
checkTablesWereDropped :: forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
[Migration m] -> m ValidationResult
checkTablesWereDropped [Migration m]
mgrs = do
let droppedTableNames :: [RawSQL ()]
droppedTableNames = [ forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName Migration m
mgr
| Migration m
mgr <- [Migration m]
mgrs, forall (m :: * -> *). Migration m -> Bool
isDropTableMigration Migration m
mgr ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [RawSQL ()]
droppedTableNames forall a b. (a -> b) -> a -> b
$
\RawSQL ()
tblName -> do
Maybe Int32
mver <- forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
String -> m (Maybe Int32)
checkTableVersion (Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSQL () -> Text
unRawSQL forall a b. (a -> b) -> a -> b
$ RawSQL ()
tblName)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if forall a. Maybe a -> Bool
isNothing Maybe Int32
mver
then forall a. Monoid a => a
mempty
else Text -> ValidationResult
validationError forall a b. (a -> b) -> a -> b
$ Text
"The table '" forall a. Semigroup a => a -> a -> a
<> RawSQL () -> Text
unRawSQL RawSQL ()
tblName
forall a. Semigroup a => a -> a -> a
<> Text
"' that must have been dropped"
forall a. Semigroup a => a -> a -> a
<> Text
" is still present in the database."
data CompositesCreationMode
= CreateCompositesIfDatabaseEmpty
| DontCreateComposites
deriving CompositesCreationMode -> CompositesCreationMode -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CompositesCreationMode -> CompositesCreationMode -> Bool
$c/= :: CompositesCreationMode -> CompositesCreationMode -> Bool
== :: CompositesCreationMode -> CompositesCreationMode -> Bool
$c== :: CompositesCreationMode -> CompositesCreationMode -> Bool
Eq
checkCompositesStructure
:: MonadDB m
=> TablesWithVersions
-> CompositesCreationMode
-> ObjectsValidationMode
-> [CompositeType]
-> m ValidationResult
checkCompositesStructure :: forall (m :: * -> *).
MonadDB m =>
TablesWithVersions
-> CompositesCreationMode
-> ObjectsValidationMode
-> [CompositeType]
-> m ValidationResult
checkCompositesStructure TablesWithVersions
tablesWithVersions CompositesCreationMode
ccm ObjectsValidationMode
ovm [CompositeType]
compositeList = forall (m :: * -> *). MonadDB m => m [CompositeType]
getDBCompositeTypes forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
[] | TablesWithVersions -> Bool
noTablesPresent TablesWithVersions
tablesWithVersions Bool -> Bool -> Bool
&& CompositesCreationMode
ccm forall a. Eq a => a -> a -> Bool
== CompositesCreationMode
CreateCompositesIfDatabaseEmpty -> do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompositeType -> RawSQL ()
sqlCreateComposite) [CompositeType]
compositeList
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
[CompositeType]
dbCompositeTypes -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
[ ValidationResult
checkNotPresentComposites
, ValidationResult
checkDatabaseComposites
]
where
compositeMap :: Map Text [CompositeColumn]
compositeMap = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map ((RawSQL () -> Text
unRawSQL forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompositeType -> RawSQL ()
ctName) forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& CompositeType -> [CompositeColumn]
ctColumns) [CompositeType]
compositeList
checkNotPresentComposites :: ValidationResult
checkNotPresentComposites =
let notPresent :: [Text]
notPresent = forall a. Set a -> [a]
S.toList forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> Set k
M.keysSet Map Text [CompositeColumn]
compositeMap
forall a. Ord a => Set a -> Set a -> Set a
S.\\ forall a. Ord a => [a] -> Set a
S.fromList (forall a b. (a -> b) -> [a] -> [b]
map (RawSQL () -> Text
unRawSQL forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompositeType -> RawSQL ()
ctName) [CompositeType]
dbCompositeTypes)
in Text -> [Text] -> ValidationResult
validateIsNull Text
"Composite types not present in the database:" [Text]
notPresent
checkDatabaseComposites :: ValidationResult
checkDatabaseComposites = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (a -> b) -> [a] -> [b]
`map` [CompositeType]
dbCompositeTypes) forall a b. (a -> b) -> a -> b
$ \CompositeType
dbComposite ->
let cname :: Text
cname = RawSQL () -> Text
unRawSQL forall a b. (a -> b) -> a -> b
$ CompositeType -> RawSQL ()
ctName CompositeType
dbComposite
in case Text
cname forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Map Text [CompositeColumn]
compositeMap of
Just [CompositeColumn]
columns -> Text -> Text -> ValidationResult -> ValidationResult
topMessage Text
"composite type" Text
cname forall a b. (a -> b) -> a -> b
$
Int -> [CompositeColumn] -> [CompositeColumn] -> ValidationResult
checkColumns Int
1 [CompositeColumn]
columns (CompositeType -> [CompositeColumn]
ctColumns CompositeType
dbComposite)
Maybe [CompositeColumn]
Nothing -> case ObjectsValidationMode
ovm of
ObjectsValidationMode
AllowUnknownObjects -> forall a. Monoid a => a
mempty
ObjectsValidationMode
DontAllowUnknownObjects -> Text -> ValidationResult
validationError forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
[ Text
"Composite type '"
, String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show CompositeType
dbComposite
, Text
"' from the database doesn't have a corresponding code definition"
]
where
checkColumns
:: Int -> [CompositeColumn] -> [CompositeColumn] -> ValidationResult
checkColumns :: Int -> [CompositeColumn] -> [CompositeColumn] -> ValidationResult
checkColumns Int
_ [] [] = forall a. Monoid a => a
mempty
checkColumns Int
_ [CompositeColumn]
rest [] = Text -> ValidationResult
validationError forall a b. (a -> b) -> a -> b
$
forall t. Show t => Text -> Text -> t -> Text
objectHasLess Text
"Composite type" Text
"columns" [CompositeColumn]
rest
checkColumns Int
_ [] [CompositeColumn]
rest = Text -> ValidationResult
validationError forall a b. (a -> b) -> a -> b
$
forall t. Show t => Text -> Text -> t -> Text
objectHasMore Text
"Composite type" Text
"columns" [CompositeColumn]
rest
checkColumns !Int
n (CompositeColumn
d:[CompositeColumn]
defs) (CompositeColumn
c:[CompositeColumn]
cols) = forall a. Monoid a => [a] -> a
mconcat [
Bool -> ValidationResult
validateNames forall a b. (a -> b) -> a -> b
$ CompositeColumn -> RawSQL ()
ccName CompositeColumn
d forall a. Eq a => a -> a -> Bool
== CompositeColumn -> RawSQL ()
ccName CompositeColumn
c
, Bool -> ValidationResult
validateTypes forall a b. (a -> b) -> a -> b
$ CompositeColumn -> ColumnType
ccType CompositeColumn
d forall a. Eq a => a -> a -> Bool
== CompositeColumn -> ColumnType
ccType CompositeColumn
c
, Int -> [CompositeColumn] -> [CompositeColumn] -> ValidationResult
checkColumns (Int
nforall a. Num a => a -> a -> a
+Int
1) [CompositeColumn]
defs [CompositeColumn]
cols
]
where
validateNames :: Bool -> ValidationResult
validateNames Bool
True = forall a. Monoid a => a
mempty
validateNames Bool
False = Text -> ValidationResult
validationError forall a b. (a -> b) -> a -> b
$
Text -> Text -> (CompositeColumn -> Text) -> Text
errorMsg (Text
"no. " forall a. Semigroup a => a -> a -> a
<> forall a. TextShow a => a -> Text
showt Int
n) Text
"names" (RawSQL () -> Text
unRawSQL forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompositeColumn -> RawSQL ()
ccName)
validateTypes :: Bool -> ValidationResult
validateTypes Bool
True = forall a. Monoid a => a
mempty
validateTypes Bool
False = Text -> ValidationResult
validationError forall a b. (a -> b) -> a -> b
$
Text -> Text -> (CompositeColumn -> Text) -> Text
errorMsg (RawSQL () -> Text
unRawSQL forall a b. (a -> b) -> a -> b
$ CompositeColumn -> RawSQL ()
ccName CompositeColumn
d) Text
"types" (String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompositeColumn -> ColumnType
ccType)
errorMsg :: Text -> Text -> (CompositeColumn -> Text) -> Text
errorMsg Text
ident Text
attr CompositeColumn -> Text
f =
Text
"Column '" forall a. Semigroup a => a -> a -> a
<> Text
ident forall a. Semigroup a => a -> a -> a
<> Text
"' differs in"
forall m. (IsString m, Monoid m) => m -> m -> m
<+> Text
attr forall m. (IsString m, Monoid m) => m -> m -> m
<+> Text
"(database:" forall m. (IsString m, Monoid m) => m -> m -> m
<+> CompositeColumn -> Text
f CompositeColumn
c forall a. Semigroup a => a -> a -> a
<> Text
", definition:" forall m. (IsString m, Monoid m) => m -> m -> m
<+> CompositeColumn -> Text
f CompositeColumn
d forall a. Semigroup a => a -> a -> a
<> Text
")."
checkDBStructure
:: forall m. (MonadDB m, MonadThrow m)
=> ExtrasOptions
-> TablesWithVersions
-> m ValidationResult
checkDBStructure :: forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
ExtrasOptions -> TablesWithVersions -> m ValidationResult
checkDBStructure ExtrasOptions
options TablesWithVersions
tables = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM TablesWithVersions
tables forall a b. (a -> b) -> a -> b
$ \(Table
table, Int32
version) -> do
ValidationResult
result <- Text -> Text -> ValidationResult -> ValidationResult
topMessage Text
"table" (Table -> Text
tblNameText Table
table) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Table -> m ValidationResult
checkTableStructure Table
table
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if ExtrasOptions -> Bool
eoAllowHigherTableVersions ExtrasOptions
options Bool -> Bool -> Bool
&& Table -> Int32
tblVersion Table
table forall a. Ord a => a -> a -> Bool
< Int32
version
then ValidationResult -> ValidationResult
validationErrorsToInfos ValidationResult
result
else ValidationResult
result
where
checkTableStructure :: Table -> m ValidationResult
checkTableStructure :: Table -> m ValidationResult
checkTableStructure table :: Table
table@Table{Int32
[Check]
[ForeignKey]
[TableIndex]
[Trigger]
[TableColumn]
Maybe PrimaryKey
Maybe TableInitialSetup
RawSQL ()
tblInitialSetup :: Maybe TableInitialSetup
tblTriggers :: [Trigger]
tblIndexes :: [TableIndex]
tblForeignKeys :: [ForeignKey]
tblChecks :: [Check]
tblPrimaryKey :: Maybe PrimaryKey
tblColumns :: [TableColumn]
tblVersion :: Int32
tblName :: RawSQL ()
tblInitialSetup :: Table -> Maybe TableInitialSetup
tblTriggers :: Table -> [Trigger]
tblIndexes :: Table -> [TableIndex]
tblForeignKeys :: Table -> [ForeignKey]
tblChecks :: Table -> [Check]
tblPrimaryKey :: Table -> Maybe PrimaryKey
tblColumns :: Table -> [TableColumn]
tblVersion :: Table -> Int32
tblName :: Table -> RawSQL ()
..} = do
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ forall a b. (a -> b) -> a -> b
$ SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_attribute a" forall a b. (a -> b) -> a -> b
$ do
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"a.attname::text"
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"pg_catalog.format_type(a.atttypid, a.atttypmod)"
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> SQL
parenthesize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Sqlable a => a -> SQL
toSQLCommand forall a b. (a -> b) -> a -> b
$
SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_collation c, pg_catalog.pg_type t" forall a b. (a -> b) -> a -> b
$ do
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"c.collname::text"
forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere SQL
"c.oid = a.attcollation AND t.oid = a.atttypid AND a.attcollation <> t.typcollation"
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"NOT a.attnotnull"
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> SQL
parenthesize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Sqlable a => a -> SQL
toSQLCommand forall a b. (a -> b) -> a -> b
$
SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_attrdef d" forall a b. (a -> b) -> a -> b
$ do
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"pg_catalog.pg_get_expr(d.adbin, d.adrelid)"
forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere SQL
"d.adrelid = a.attrelid"
forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere SQL
"d.adnum = a.attnum"
forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere SQL
"a.atthasdef"
forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere SQL
"a.attnum > 0"
forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere SQL
"NOT a.attisdropped"
forall v (m :: * -> *) sql.
(MonadState v m, SqlWhere v, Sqlable sql) =>
SQL -> sql -> m ()
sqlWhereEqSql SQL
"a.attrelid" forall a b. (a -> b) -> a -> b
$ Table -> SQL
sqlGetTableID Table
table
forall v (m :: * -> *).
(MonadState v m, SqlOrderBy v) =>
SQL -> m ()
sqlOrderBy SQL
"a.attnum"
[TableColumn]
desc <- forall (m :: * -> *) row t.
(MonadDB m, FromRow row) =>
(row -> t) -> m [t]
fetchMany (String, ColumnType, Maybe Text, Bool, Maybe String) -> TableColumn
fetchTableColumn
Maybe (PrimaryKey, RawSQL ())
pk <- forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
Table -> m (Maybe (PrimaryKey, RawSQL ()))
sqlGetPrimaryKey Table
table
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ forall a b. (a -> b) -> a -> b
$ Table -> SQL
sqlGetChecks Table
table
[Check]
checks <- forall (m :: * -> *) row t.
(MonadDB m, FromRow row) =>
(row -> t) -> m [t]
fetchMany (String, String, Bool) -> Check
fetchTableCheck
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ forall a b. (a -> b) -> a -> b
$ Table -> SQL
sqlGetIndexes Table
table
[(TableIndex, RawSQL ())]
indexes <- forall (m :: * -> *) row t.
(MonadDB m, FromRow row) =>
(row -> t) -> m [t]
fetchMany (String, Array1 String, Array1 String, String, Bool, Bool,
Maybe String)
-> (TableIndex, RawSQL ())
fetchTableIndex
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ forall a b. (a -> b) -> a -> b
$ Table -> SQL
sqlGetForeignKeys Table
table
[(ForeignKey, RawSQL ())]
fkeys <- forall (m :: * -> *) row t.
(MonadDB m, FromRow row) =>
(row -> t) -> m [t]
fetchMany (String, Array1 String, String, Array1 String, Char, Char, Bool,
Bool, Bool)
-> (ForeignKey, RawSQL ())
fetchForeignKey
[(Trigger, RawSQL ())]
triggers <- forall (m :: * -> *).
MonadDB m =>
RawSQL () -> m [(Trigger, RawSQL ())]
getDBTriggers RawSQL ()
tblName
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [
Int -> [TableColumn] -> [TableColumn] -> ValidationResult
checkColumns Int
1 [TableColumn]
tblColumns [TableColumn]
desc
, Maybe PrimaryKey
-> Maybe (PrimaryKey, RawSQL ()) -> ValidationResult
checkPrimaryKey Maybe PrimaryKey
tblPrimaryKey Maybe (PrimaryKey, RawSQL ())
pk
, [Check] -> [Check] -> ValidationResult
checkChecks [Check]
tblChecks [Check]
checks
, [TableIndex] -> [(TableIndex, RawSQL ())] -> ValidationResult
checkIndexes [TableIndex]
tblIndexes [(TableIndex, RawSQL ())]
indexes
, [ForeignKey] -> [(ForeignKey, RawSQL ())] -> ValidationResult
checkForeignKeys [ForeignKey]
tblForeignKeys [(ForeignKey, RawSQL ())]
fkeys
, [Trigger] -> [(Trigger, RawSQL ())] -> ValidationResult
checkTriggers [Trigger]
tblTriggers [(Trigger, RawSQL ())]
triggers
]
where
fetchTableColumn
:: (String, ColumnType, Maybe Text, Bool, Maybe String) -> TableColumn
fetchTableColumn :: (String, ColumnType, Maybe Text, Bool, Maybe String) -> TableColumn
fetchTableColumn (String
name, ColumnType
ctype, Maybe Text
collation, Bool
nullable, Maybe String
mdefault) = TableColumn {
colName :: RawSQL ()
colName = forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL String
name
, colType :: ColumnType
colType = ColumnType
ctype
, colCollation :: Maybe (RawSQL ())
colCollation = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall row. (Show row, ToRow row) => Text -> row -> RawSQL row
rawSQL () forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
collation
, colNullable :: Bool
colNullable = Bool
nullable
, colDefault :: Maybe (RawSQL ())
colDefault = forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` Maybe String
mdefault
}
checkColumns
:: Int -> [TableColumn] -> [TableColumn] -> ValidationResult
checkColumns :: Int -> [TableColumn] -> [TableColumn] -> ValidationResult
checkColumns Int
_ [] [] = forall a. Monoid a => a
mempty
checkColumns Int
_ [TableColumn]
rest [] = Text -> ValidationResult
validationError forall a b. (a -> b) -> a -> b
$
forall t. Show t => Text -> Text -> t -> Text
objectHasLess Text
"Table" Text
"columns" [TableColumn]
rest
checkColumns Int
_ [] [TableColumn]
rest = Text -> ValidationResult
validationError forall a b. (a -> b) -> a -> b
$
forall t. Show t => Text -> Text -> t -> Text
objectHasMore Text
"Table" Text
"columns" [TableColumn]
rest
checkColumns !Int
n (TableColumn
d:[TableColumn]
defs) (TableColumn
c:[TableColumn]
cols) = forall a. Monoid a => [a] -> a
mconcat [
Bool -> ValidationResult
validateNames forall a b. (a -> b) -> a -> b
$ TableColumn -> RawSQL ()
colName TableColumn
d forall a. Eq a => a -> a -> Bool
== TableColumn -> RawSQL ()
colName TableColumn
c
, Bool -> ValidationResult
validateTypes forall a b. (a -> b) -> a -> b
$ TableColumn -> ColumnType
colType TableColumn
d forall a. Eq a => a -> a -> Bool
== TableColumn -> ColumnType
colType TableColumn
c Bool -> Bool -> Bool
||
(TableColumn -> ColumnType
colType TableColumn
d forall a. Eq a => a -> a -> Bool
== ColumnType
BigSerialT Bool -> Bool -> Bool
&& TableColumn -> ColumnType
colType TableColumn
c forall a. Eq a => a -> a -> Bool
== ColumnType
BigIntT)
, Bool -> ValidationResult
validateDefaults forall a b. (a -> b) -> a -> b
$ TableColumn -> Maybe (RawSQL ())
colDefault TableColumn
d forall a. Eq a => a -> a -> Bool
== TableColumn -> Maybe (RawSQL ())
colDefault TableColumn
c Bool -> Bool -> Bool
||
(TableColumn -> Maybe (RawSQL ())
colDefault TableColumn
d forall a. Eq a => a -> a -> Bool
== forall a. Maybe a
Nothing
Bool -> Bool -> Bool
&& ((Text -> Text -> Bool
T.isPrefixOf Text
"nextval('" forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSQL () -> Text
unRawSQL) forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` TableColumn -> Maybe (RawSQL ())
colDefault TableColumn
c)
forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Bool
True)
, Bool -> ValidationResult
validateNullables forall a b. (a -> b) -> a -> b
$ TableColumn -> Bool
colNullable TableColumn
d forall a. Eq a => a -> a -> Bool
== TableColumn -> Bool
colNullable TableColumn
c
, Int -> [TableColumn] -> [TableColumn] -> ValidationResult
checkColumns (Int
nforall a. Num a => a -> a -> a
+Int
1) [TableColumn]
defs [TableColumn]
cols
]
where
validateNames :: Bool -> ValidationResult
validateNames Bool
True = forall a. Monoid a => a
mempty
validateNames Bool
False = Text -> ValidationResult
validationError forall a b. (a -> b) -> a -> b
$
Text -> Text -> (TableColumn -> Text) -> Text
errorMsg (Text
"no. " forall a. Semigroup a => a -> a -> a
<> forall a. TextShow a => a -> Text
showt Int
n) Text
"names" (RawSQL () -> Text
unRawSQL forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableColumn -> RawSQL ()
colName)
validateTypes :: Bool -> ValidationResult
validateTypes Bool
True = forall a. Monoid a => a
mempty
validateTypes Bool
False = Text -> ValidationResult
validationError forall a b. (a -> b) -> a -> b
$
Text -> Text -> (TableColumn -> Text) -> Text
errorMsg Text
cname Text
"types" (String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableColumn -> ColumnType
colType)
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL () -> Text
sqlHint (RawSQL ()
"TYPE" forall m. (IsString m, Monoid m) => m -> m -> m
<+> ColumnType -> RawSQL ()
columnTypeToSQL (TableColumn -> ColumnType
colType TableColumn
d))
validateNullables :: Bool -> ValidationResult
validateNullables Bool
True = forall a. Monoid a => a
mempty
validateNullables Bool
False = Text -> ValidationResult
validationError forall a b. (a -> b) -> a -> b
$
Text -> Text -> (TableColumn -> Text) -> Text
errorMsg Text
cname Text
"nullables" (forall a. TextShow a => a -> Text
showt forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableColumn -> Bool
colNullable)
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL () -> Text
sqlHint ((if TableColumn -> Bool
colNullable TableColumn
d then RawSQL ()
"DROP" else RawSQL ()
"SET")
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
"NOT NULL")
validateDefaults :: Bool -> ValidationResult
validateDefaults Bool
True = forall a. Monoid a => a
mempty
validateDefaults Bool
False = Text -> ValidationResult
validationError forall a b. (a -> b) -> a -> b
$
(Text -> Text -> (TableColumn -> Text) -> Text
errorMsg Text
cname Text
"defaults" (forall a. TextShow a => a -> Text
showt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RawSQL () -> Text
unRawSQL forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableColumn -> Maybe (RawSQL ())
colDefault))
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL () -> Text
sqlHint RawSQL ()
set_default
where
set_default :: RawSQL ()
set_default = case TableColumn -> Maybe (RawSQL ())
colDefault TableColumn
d of
Just RawSQL ()
v -> RawSQL ()
"SET DEFAULT" forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
v
Maybe (RawSQL ())
Nothing -> RawSQL ()
"DROP DEFAULT"
cname :: Text
cname = RawSQL () -> Text
unRawSQL forall a b. (a -> b) -> a -> b
$ TableColumn -> RawSQL ()
colName TableColumn
d
errorMsg :: Text -> Text -> (TableColumn -> Text) -> Text
errorMsg Text
ident Text
attr TableColumn -> Text
f =
Text
"Column '" forall a. Semigroup a => a -> a -> a
<> Text
ident forall a. Semigroup a => a -> a -> a
<> Text
"' differs in"
forall m. (IsString m, Monoid m) => m -> m -> m
<+> Text
attr forall m. (IsString m, Monoid m) => m -> m -> m
<+> Text
"(table:" forall m. (IsString m, Monoid m) => m -> m -> m
<+> TableColumn -> Text
f TableColumn
c forall a. Semigroup a => a -> a -> a
<> Text
", definition:" forall m. (IsString m, Monoid m) => m -> m -> m
<+> TableColumn -> Text
f TableColumn
d forall a. Semigroup a => a -> a -> a
<> Text
")."
sqlHint :: RawSQL () -> Text
sqlHint RawSQL ()
sql =
Text
"(HINT: SQL for making the change is: ALTER TABLE"
forall m. (IsString m, Monoid m) => m -> m -> m
<+> Table -> Text
tblNameText Table
table forall m. (IsString m, Monoid m) => m -> m -> m
<+> Text
"ALTER COLUMN" forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL () -> Text
unRawSQL (TableColumn -> RawSQL ()
colName TableColumn
d)
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL () -> Text
unRawSQL RawSQL ()
sql forall a. Semigroup a => a -> a -> a
<> Text
")"
checkPrimaryKey :: Maybe PrimaryKey -> Maybe (PrimaryKey, RawSQL ())
-> ValidationResult
checkPrimaryKey :: Maybe PrimaryKey
-> Maybe (PrimaryKey, RawSQL ()) -> ValidationResult
checkPrimaryKey Maybe PrimaryKey
mdef Maybe (PrimaryKey, RawSQL ())
mpk = forall a. Monoid a => [a] -> a
mconcat [
forall t. (Eq t, Show t) => Text -> [t] -> [t] -> ValidationResult
checkEquality Text
"PRIMARY KEY" [PrimaryKey]
def (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(PrimaryKey, RawSQL ())]
pk)
, forall t.
Show t =>
(t -> RawSQL ()) -> [(t, RawSQL ())] -> ValidationResult
checkNames (forall a b. a -> b -> a
const (RawSQL () -> RawSQL ()
pkName RawSQL ()
tblName)) [(PrimaryKey, RawSQL ())]
pk
, if (ExtrasOptions -> Bool
eoEnforcePKs ExtrasOptions
options)
then RawSQL ()
-> Maybe PrimaryKey
-> Maybe (PrimaryKey, RawSQL ())
-> ValidationResult
checkPKPresence RawSQL ()
tblName Maybe PrimaryKey
mdef Maybe (PrimaryKey, RawSQL ())
mpk
else forall a. Monoid a => a
mempty
]
where
def :: [PrimaryKey]
def = forall a. Maybe a -> [a]
maybeToList Maybe PrimaryKey
mdef
pk :: [(PrimaryKey, RawSQL ())]
pk = forall a. Maybe a -> [a]
maybeToList Maybe (PrimaryKey, RawSQL ())
mpk
checkChecks :: [Check] -> [Check] -> ValidationResult
checkChecks :: [Check] -> [Check] -> ValidationResult
checkChecks [Check]
defs [Check]
checks =
([Text] -> [Text])
-> ([Text] -> [Text]) -> ValidationResult -> ValidationResult
mapValidationResult forall a. a -> a
id forall {a}. IsString a => [a] -> [a]
mapErrs (forall t. (Eq t, Show t) => Text -> [t] -> [t] -> ValidationResult
checkEquality Text
"CHECKs" [Check]
defs [Check]
checks)
where
mapErrs :: [a] -> [a]
mapErrs [] = []
mapErrs [a]
errmsgs = [a]
errmsgs forall a. Semigroup a => a -> a -> a
<>
[ a
" (HINT: If checks are equal modulo number of \
\ parentheses/whitespaces used in conditions, \
\ just copy and paste expected output into source code)"
]
checkIndexes :: [TableIndex] -> [(TableIndex, RawSQL ())]
-> ValidationResult
checkIndexes :: [TableIndex] -> [(TableIndex, RawSQL ())] -> ValidationResult
checkIndexes [TableIndex]
defs [(TableIndex, RawSQL ())]
allIndexes = forall a. Monoid a => [a] -> a
mconcat
forall a b. (a -> b) -> a -> b
$ forall t. (Eq t, Show t) => Text -> [t] -> [t] -> ValidationResult
checkEquality Text
"INDEXes" [TableIndex]
defs (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(TableIndex, RawSQL ())]
indexes)
forall a. a -> [a] -> [a]
: forall t.
Show t =>
(t -> RawSQL ()) -> [(t, RawSQL ())] -> ValidationResult
checkNames (RawSQL () -> TableIndex -> RawSQL ()
indexName RawSQL ()
tblName) [(TableIndex, RawSQL ())]
indexes
forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Show a => (a, RawSQL ()) -> ValidationResult
localIndexInfo [(TableIndex, RawSQL ())]
localIndexes
where
localIndexInfo :: (a, RawSQL ()) -> ValidationResult
localIndexInfo (a
index, RawSQL ()
name) = Text -> ValidationResult
validationInfo forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
[ Text
"Found a local index '"
, RawSQL () -> Text
unRawSQL RawSQL ()
name
, Text
"': "
, String -> Text
T.pack (forall a. Show a => a -> String
show a
index)
]
([(TableIndex, RawSQL ())]
localIndexes, [(TableIndex, RawSQL ())]
indexes) = (forall a. (a -> Bool) -> [a] -> ([a], [a])
`partition` [(TableIndex, RawSQL ())]
allIndexes) forall a b. (a -> b) -> a -> b
$ \(TableIndex
_, RawSQL ()
name) ->
Text
"local_" Text -> Text -> Bool
`T.isPrefixOf` RawSQL () -> Text
unRawSQL RawSQL ()
name
checkForeignKeys :: [ForeignKey] -> [(ForeignKey, RawSQL ())]
-> ValidationResult
checkForeignKeys :: [ForeignKey] -> [(ForeignKey, RawSQL ())] -> ValidationResult
checkForeignKeys [ForeignKey]
defs [(ForeignKey, RawSQL ())]
fkeys = forall a. Monoid a => [a] -> a
mconcat [
forall t. (Eq t, Show t) => Text -> [t] -> [t] -> ValidationResult
checkEquality Text
"FOREIGN KEYs" [ForeignKey]
defs (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(ForeignKey, RawSQL ())]
fkeys)
, forall t.
Show t =>
(t -> RawSQL ()) -> [(t, RawSQL ())] -> ValidationResult
checkNames (RawSQL () -> ForeignKey -> RawSQL ()
fkName RawSQL ()
tblName) [(ForeignKey, RawSQL ())]
fkeys
]
checkTriggers :: [Trigger] -> [(Trigger, RawSQL ())] -> ValidationResult
checkTriggers :: [Trigger] -> [(Trigger, RawSQL ())] -> ValidationResult
checkTriggers [Trigger]
defs [(Trigger, RawSQL ())]
triggers =
([Text] -> [Text])
-> ([Text] -> [Text]) -> ValidationResult -> ValidationResult
mapValidationResult forall a. a -> a
id forall {a}. IsString a => [a] -> [a]
mapErrs forall a b. (a -> b) -> a -> b
$ forall t. (Eq t, Show t) => Text -> [t] -> [t] -> ValidationResult
checkEquality Text
"TRIGGERs" [(Trigger, RawSQL ())]
defs' [(Trigger, RawSQL ())]
triggers
where
defs' :: [(Trigger, RawSQL ())]
defs' = forall a b. (a -> b) -> [a] -> [b]
map (\Trigger
t -> (Trigger
t, RawSQL () -> RawSQL ()
triggerFunctionMakeName forall a b. (a -> b) -> a -> b
$ Trigger -> RawSQL ()
triggerName Trigger
t)) [Trigger]
defs
mapErrs :: [a] -> [a]
mapErrs [] = []
mapErrs [a]
errmsgs = [a]
errmsgs forall a. Semigroup a => a -> a -> a
<>
[ a
"(HINT: If WHEN clauses are equal modulo number of parentheses, whitespace, \
\case of variables or type casts used in conditions, just copy and paste \
\expected output into source code.)"
]
checkDBConsistency
:: forall m. (MonadIO m, MonadDB m, MonadLog m, MonadMask m)
=> ExtrasOptions -> [Domain] -> TablesWithVersions -> [Migration m]
-> m ()
checkDBConsistency :: forall (m :: * -> *).
(MonadIO m, MonadDB m, MonadLog m, MonadMask m) =>
ExtrasOptions
-> [Domain] -> TablesWithVersions -> [Migration m] -> m ()
checkDBConsistency ExtrasOptions
options [Domain]
domains TablesWithVersions
tablesWithVersions [Migration m]
migrations = do
Bool
autoTransaction <- TransactionSettings -> Bool
tsAutoTransaction forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadDB m => m TransactionSettings
getTransactionSettings
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
autoTransaction forall a b. (a -> b) -> a -> b
$ do
forall a. HasCallStack => String -> a
error String
"checkDBConsistency: tsAutoTransaction setting needs to be True"
m ()
validateMigrations
m ()
validateDropTableMigrations
[(Text, Int32)]
dbTablesWithVersions <- forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
m [(Text, Int32)]
getDBTableVersions
if TablesWithVersions -> Bool
noTablesPresent TablesWithVersions
tablesWithVersions
then do
m ()
createDBSchema
m ()
initializeDB
else do
[(RawSQL (), Int32, Int32)] -> m ()
validateMigrationsAgainstDB [ (Table -> RawSQL ()
tblName Table
table, Table -> Int32
tblVersion Table
table, Int32
actualVer)
| (Table
table, Int32
actualVer) <- TablesWithVersions
tablesWithVersions ]
[(Text, Int32)] -> m ()
validateDropTableMigrationsAgainstDB [(Text, Int32)]
dbTablesWithVersions
[(Text, Int32)] -> m ()
runMigrations [(Text, Int32)]
dbTablesWithVersions
where
tables :: [Table]
tables = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst TablesWithVersions
tablesWithVersions
errorInvalidMigrations :: HasCallStack => [RawSQL ()] -> a
errorInvalidMigrations :: forall a. HasCallStack => [RawSQL ()] -> a
errorInvalidMigrations [RawSQL ()]
tblNames =
forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"checkDBConsistency: invalid migrations for tables"
forall m. (IsString m, Monoid m) => m -> m -> m
<+> (forall a. [a] -> [[a]] -> [a]
L.intercalate String
", " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSQL () -> Text
unRawSQL) [RawSQL ()]
tblNames)
checkMigrationsListValidity :: Table -> [Int32] -> [Int32] -> m ()
checkMigrationsListValidity :: Table -> [Int32] -> [Int32] -> m ()
checkMigrationsListValidity Table
table [Int32]
presentMigrationVersions
[Int32]
expectedMigrationVersions = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Int32]
presentMigrationVersions forall a. Eq a => a -> a -> Bool
/= [Int32]
expectedMigrationVersions) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) a. (MonadLog m, ToJSON a) => Text -> a -> m ()
logAttention Text
"Migrations are invalid" forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [
Key
"table" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Table -> Text
tblNameText Table
table
, Key
"migration_versions" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Int32]
presentMigrationVersions
, Key
"expected_migration_versions" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Int32]
expectedMigrationVersions
]
forall a. HasCallStack => [RawSQL ()] -> a
errorInvalidMigrations [Table -> RawSQL ()
tblName forall a b. (a -> b) -> a -> b
$ Table
table]
validateMigrations :: m ()
validateMigrations :: m ()
validateMigrations = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Table]
tables forall a b. (a -> b) -> a -> b
$ \Table
table -> do
let presentMigrationVersions :: [Int32]
presentMigrationVersions
= [ Int32
mgrFrom | Migration{Int32
RawSQL ()
MigrationAction m
mgrAction :: forall (m :: * -> *). Migration m -> MigrationAction m
mgrFrom :: forall (m :: * -> *). Migration m -> Int32
mgrAction :: MigrationAction m
mgrTableName :: RawSQL ()
mgrFrom :: Int32
mgrTableName :: forall (m :: * -> *). Migration m -> RawSQL ()
..} <- [Migration m]
migrations
, RawSQL ()
mgrTableName forall a. Eq a => a -> a -> Bool
== Table -> RawSQL ()
tblName Table
table ]
expectedMigrationVersions :: [Int32]
expectedMigrationVersions
= forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int32]
presentMigrationVersions) forall a b. (a -> b) -> a -> b
$
forall a. [a] -> [a]
reverse [Int32
0 .. Table -> Int32
tblVersion Table
table forall a. Num a => a -> a -> a
- Int32
1]
Table -> [Int32] -> [Int32] -> m ()
checkMigrationsListValidity Table
table [Int32]
presentMigrationVersions
[Int32]
expectedMigrationVersions
validateDropTableMigrations :: m ()
validateDropTableMigrations :: m ()
validateDropTableMigrations = do
let droppedTableNames :: [RawSQL ()]
droppedTableNames =
[ forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName forall a b. (a -> b) -> a -> b
$ Migration m
mgr | Migration m
mgr <- [Migration m]
migrations
, forall (m :: * -> *). Migration m -> Bool
isDropTableMigration Migration m
mgr ]
tableNames :: [RawSQL ()]
tableNames =
[ Table -> RawSQL ()
tblName Table
tbl | Table
tbl <- [Table]
tables ]
let intersection :: [RawSQL ()]
intersection = forall a. Eq a => [a] -> [a] -> [a]
L.intersect [RawSQL ()]
droppedTableNames [RawSQL ()]
tableNames
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ [RawSQL ()]
intersection) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) a. (MonadLog m, ToJSON a) => Text -> a -> m ()
logAttention (Text
"The intersection between tables "
forall a. Semigroup a => a -> a -> a
<> Text
"and dropped tables is not empty")
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object
[ Key
"intersection" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a b. (a -> b) -> [a] -> [b]
map RawSQL () -> Text
unRawSQL [RawSQL ()]
intersection ]
forall a. HasCallStack => [RawSQL ()] -> a
errorInvalidMigrations [ Table -> RawSQL ()
tblName Table
tbl
| Table
tbl <- [Table]
tables
, Table -> RawSQL ()
tblName Table
tbl forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [RawSQL ()]
intersection ]
let migrationsByTable :: [[Migration m]]
migrationsByTable = forall a. (a -> a -> Bool) -> [a] -> [[a]]
L.groupBy (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName)
[Migration m]
migrations
dropMigrationLists :: [[Migration m]]
dropMigrationLists = [ [Migration m]
mgrs | [Migration m]
mgrs <- [[Migration m]]
migrationsByTable
, forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall (m :: * -> *). Migration m -> Bool
isDropTableMigration [Migration m]
mgrs ]
invalidMigrationLists :: [[Migration m]]
invalidMigrationLists =
[ [Migration m]
mgrs | [Migration m]
mgrs <- [[Migration m]]
dropMigrationLists
, (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Migration m -> Bool
isDropTableMigration forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
last forall a b. (a -> b) -> a -> b
$ [Migration m]
mgrs) Bool -> Bool -> Bool
||
(forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter forall (m :: * -> *). Migration m -> Bool
isDropTableMigration forall a b. (a -> b) -> a -> b
$ [Migration m]
mgrs) forall a. Ord a => a -> a -> Bool
> Int
1 ]
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ [[Migration m]]
invalidMigrationLists) forall a b. (a -> b) -> a -> b
$ do
let tablesWithInvalidMigrationLists :: [RawSQL ()]
tablesWithInvalidMigrationLists =
[ forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName Migration m
mgr | [Migration m]
mgrs <- [[Migration m]]
invalidMigrationLists
, let mgr :: Migration m
mgr = forall a. [a] -> a
head [Migration m]
mgrs ]
forall (m :: * -> *) a. (MonadLog m, ToJSON a) => Text -> a -> m ()
logAttention (Text
"Migration lists for some tables contain "
forall a. Semigroup a => a -> a -> a
<> Text
"either multiple drop table migrations or "
forall a. Semigroup a => a -> a -> a
<> Text
"a drop table migration in non-tail position.")
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [ Key
"tables" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.=
[ RawSQL () -> Text
unRawSQL RawSQL ()
tblName
| RawSQL ()
tblName <- [RawSQL ()]
tablesWithInvalidMigrationLists ] ]
forall a. HasCallStack => [RawSQL ()] -> a
errorInvalidMigrations [RawSQL ()]
tablesWithInvalidMigrationLists
createDBSchema :: m ()
createDBSchema :: m ()
createDBSchema = do
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ Text
"Creating domains..."
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). MonadDB m => Domain -> m ()
createDomain [Domain]
domains
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ Text
"Creating tables..."
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *). MonadDB m => Bool -> Table -> m ()
createTable Bool
False) [Table]
tables
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ Text
"Creating table constraints..."
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). MonadDB m => Table -> m ()
createTableConstraints [Table]
tables
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ Text
"Done."
initializeDB :: m ()
initializeDB :: m ()
initializeDB = do
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ Text
"Running initial setup for tables..."
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Table]
tables forall a b. (a -> b) -> a -> b
$ \Table
t -> case Table -> Maybe TableInitialSetup
tblInitialSetup Table
t of
Maybe TableInitialSetup
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just TableInitialSetup
tis -> do
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ forall a b. (a -> b) -> a -> b
$ Text
"Initializing" forall m. (IsString m, Monoid m) => m -> m -> m
<+> Table -> Text
tblNameText Table
t forall a. Semigroup a => a -> a -> a
<> Text
"..."
TableInitialSetup
-> forall (m :: * -> *). (MonadDB m, MonadThrow m) => m ()
initialSetup TableInitialSetup
tis
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ Text
"Done."
validateMigrationsAgainstDB :: [(RawSQL (), Int32, Int32)] -> m ()
validateMigrationsAgainstDB :: [(RawSQL (), Int32, Int32)] -> m ()
validateMigrationsAgainstDB [(RawSQL (), Int32, Int32)]
tablesWithVersions_
= forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(RawSQL (), Int32, Int32)]
tablesWithVersions_ forall a b. (a -> b) -> a -> b
$ \(RawSQL ()
tableName, Int32
expectedVer, Int32
actualVer) ->
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int32
expectedVer forall a. Eq a => a -> a -> Bool
/= Int32
actualVer) forall a b. (a -> b) -> a -> b
$
case [ Migration m
m | m :: Migration m
m@Migration{Int32
RawSQL ()
MigrationAction m
mgrAction :: MigrationAction m
mgrFrom :: Int32
mgrTableName :: RawSQL ()
mgrAction :: forall (m :: * -> *). Migration m -> MigrationAction m
mgrFrom :: forall (m :: * -> *). Migration m -> Int32
mgrTableName :: forall (m :: * -> *). Migration m -> RawSQL ()
..} <- [Migration m]
migrations
, RawSQL ()
mgrTableName forall a. Eq a => a -> a -> Bool
== RawSQL ()
tableName ] of
[] ->
forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"checkDBConsistency: no migrations found for table '"
forall a. [a] -> [a] -> [a]
++ (Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSQL () -> Text
unRawSQL forall a b. (a -> b) -> a -> b
$ RawSQL ()
tableName) forall a. [a] -> [a] -> [a]
++ String
"', cannot migrate "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int32
actualVer forall a. [a] -> [a] -> [a]
++ String
" -> " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int32
expectedVer
(Migration m
m:[Migration m]
_) | forall (m :: * -> *). Migration m -> Int32
mgrFrom Migration m
m forall a. Ord a => a -> a -> Bool
> Int32
actualVer ->
forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"checkDBConsistency: earliest migration for table '"
forall a. [a] -> [a] -> [a]
++ (Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSQL () -> Text
unRawSQL forall a b. (a -> b) -> a -> b
$ RawSQL ()
tableName) forall a. [a] -> [a] -> [a]
++ String
"' is from version "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (m :: * -> *). Migration m -> Int32
mgrFrom Migration m
m) forall a. [a] -> [a] -> [a]
++ String
", cannot migrate "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int32
actualVer forall a. [a] -> [a] -> [a]
++ String
" -> " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int32
expectedVer
| Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
validateDropTableMigrationsAgainstDB :: [(Text, Int32)] -> m ()
validateDropTableMigrationsAgainstDB :: [(Text, Int32)] -> m ()
validateDropTableMigrationsAgainstDB [(Text, Int32)]
dbTablesWithVersions = do
let dbTablesToDropWithVersions :: [(RawSQL (), Int32, Int32)]
dbTablesToDropWithVersions =
[ (RawSQL ()
tblName, forall (m :: * -> *). Migration m -> Int32
mgrFrom Migration m
mgr, forall a. HasCallStack => Maybe a -> a
fromJust Maybe Int32
mver)
| Migration m
mgr <- [Migration m]
migrations
, forall (m :: * -> *). Migration m -> Bool
isDropTableMigration Migration m
mgr
, let tblName :: RawSQL ()
tblName = forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName Migration m
mgr
, let mver :: Maybe Int32
mver = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (RawSQL () -> Text
unRawSQL RawSQL ()
tblName) forall a b. (a -> b) -> a -> b
$ [(Text, Int32)]
dbTablesWithVersions
, forall a. Maybe a -> Bool
isJust Maybe Int32
mver ]
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(RawSQL (), Int32, Int32)]
dbTablesToDropWithVersions forall a b. (a -> b) -> a -> b
$ \(RawSQL ()
tblName, Int32
fromVer, Int32
ver) ->
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int32
fromVer forall a. Eq a => a -> a -> Bool
/= Int32
ver) forall a b. (a -> b) -> a -> b
$
[(RawSQL (), Int32, Int32)] -> m ()
validateMigrationsAgainstDB [(RawSQL ()
tblName, Int32
fromVer, Int32
ver)]
findMigrationsToRun :: [(Text, Int32)] -> [Migration m]
findMigrationsToRun :: [(Text, Int32)] -> [Migration m]
findMigrationsToRun [(Text, Int32)]
dbTablesWithVersions =
let tableNamesToDrop :: [RawSQL ()]
tableNamesToDrop = [ forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName Migration m
mgr | Migration m
mgr <- [Migration m]
migrations
, forall (m :: * -> *). Migration m -> Bool
isDropTableMigration Migration m
mgr ]
droppedEventually :: Migration m -> Bool
droppedEventually :: Migration m -> Bool
droppedEventually Migration m
mgr = forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName Migration m
mgr forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [RawSQL ()]
tableNamesToDrop
lookupVer :: Migration m -> Maybe Int32
lookupVer :: Migration m -> Maybe Int32
lookupVer Migration m
mgr = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (RawSQL () -> Text
unRawSQL forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName Migration m
mgr)
[(Text, Int32)]
dbTablesWithVersions
tableDoesNotExist :: Migration m -> Bool
tableDoesNotExist = forall a. Maybe a -> Bool
isNothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. Migration m -> Maybe Int32
lookupVer
migrationsToRun' :: [Migration m]
migrationsToRun' = forall a. (a -> Bool) -> [a] -> [a]
dropWhile
(\Migration m
mgr ->
case Migration m -> Maybe Int32
lookupVer Migration m
mgr of
Maybe Int32
Nothing -> Bool -> Bool
not forall a b. (a -> b) -> a -> b
$
(forall (m :: * -> *). Migration m -> Int32
mgrFrom Migration m
mgr forall a. Eq a => a -> a -> Bool
== Int32
0) Bool -> Bool -> Bool
&&
(Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Migration m -> Bool
droppedEventually forall a b. (a -> b) -> a -> b
$ Migration m
mgr)
Just Int32
ver -> Bool -> Bool
not forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *). Migration m -> Int32
mgrFrom Migration m
mgr forall a. Ord a => a -> a -> Bool
>= Int32
ver)
[Migration m]
migrations
l :: Int
l = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Migration m]
migrationsToRun'
initialMigrations :: [Migration m]
initialMigrations = forall a. Int -> [a] -> [a]
drop Int
l forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [Migration m]
migrations
additionalMigrations' :: [Migration m]
additionalMigrations' = forall a. (a -> Bool) -> [a] -> [a]
takeWhile
(\Migration m
mgr -> Migration m -> Bool
droppedEventually Migration m
mgr Bool -> Bool -> Bool
&& Migration m -> Bool
tableDoesNotExist Migration m
mgr)
[Migration m]
initialMigrations
additionalMigrations :: [Migration m]
additionalMigrations =
let ret :: [Migration m]
ret = forall a. [a] -> [a]
reverse [Migration m]
additionalMigrations'
grps :: [[Migration m]]
grps = forall a. (a -> a -> Bool) -> [a] -> [[a]]
L.groupBy (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName) [Migration m]
ret
in if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => a -> a -> Bool
(/=) Int32
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Migration m -> Int32
mgrFrom forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head) [[Migration m]]
grps
then []
else [Migration m]
ret
migrationsToRun :: [Migration m]
migrationsToRun = if Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ [Migration m]
migrationsToRun'
then [Migration m]
additionalMigrations forall a. [a] -> [a] -> [a]
++ [Migration m]
migrationsToRun'
else []
in [Migration m]
migrationsToRun
runMigration :: (Migration m) -> m ()
runMigration :: Migration m -> m ()
runMigration Migration{Int32
RawSQL ()
MigrationAction m
mgrAction :: MigrationAction m
mgrFrom :: Int32
mgrTableName :: RawSQL ()
mgrAction :: forall (m :: * -> *). Migration m -> MigrationAction m
mgrFrom :: forall (m :: * -> *). Migration m -> Int32
mgrTableName :: forall (m :: * -> *). Migration m -> RawSQL ()
..} = do
case MigrationAction m
mgrAction of
StandardMigration m ()
mgrDo -> do
m ()
logMigration
m ()
mgrDo
m ()
updateTableVersion
DropTableMigration DropTableMode
mgrDropTableMode -> do
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ forall a b. (a -> b) -> a -> b
$ RawSQL () -> Text
arrListTable RawSQL ()
mgrTableName forall a. Semigroup a => a -> a -> a
<> Text
"drop table"
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ forall a b. (a -> b) -> a -> b
$ RawSQL () -> DropTableMode -> RawSQL ()
sqlDropTable RawSQL ()
mgrTableName
DropTableMode
mgrDropTableMode
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ forall a b. (a -> b) -> a -> b
$ SQL -> State SqlDelete () -> SqlDelete
sqlDelete SQL
"table_versions" forall a b. (a -> b) -> a -> b
$ do
forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"name" (Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSQL () -> Text
unRawSQL forall a b. (a -> b) -> a -> b
$ RawSQL ()
mgrTableName)
CreateIndexConcurrentlyMigration RawSQL ()
tname TableIndex
idx -> do
m ()
logMigration
forall (m :: * -> *) a c b. MonadMask m => m a -> m c -> m b -> m b
bracket_ (forall (m :: * -> *). MonadDB m => SQL -> m ()
runSQL_ SQL
"COMMIT") (forall (m :: * -> *). MonadDB m => SQL -> m ()
runSQL_ SQL
"BEGIN") forall a b. (a -> b) -> a -> b
$ do
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ forall a b. (a -> b) -> a -> b
$ RawSQL ()
"DROP INDEX CONCURRENTLY IF EXISTS" forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL () -> TableIndex -> RawSQL ()
indexName RawSQL ()
tname TableIndex
idx
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ (RawSQL () -> TableIndex -> RawSQL ()
sqlCreateIndexConcurrently RawSQL ()
tname TableIndex
idx)
m ()
updateTableVersion
DropIndexConcurrentlyMigration RawSQL ()
tname TableIndex
idx -> do
m ()
logMigration
forall (m :: * -> *) a c b. MonadMask m => m a -> m c -> m b -> m b
bracket_ (forall (m :: * -> *). MonadDB m => SQL -> m ()
runSQL_ SQL
"COMMIT") (forall (m :: * -> *). MonadDB m => SQL -> m ()
runSQL_ SQL
"BEGIN") forall a b. (a -> b) -> a -> b
$ do
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ (RawSQL () -> TableIndex -> RawSQL ()
sqlDropIndexConcurrently RawSQL ()
tname TableIndex
idx)
m ()
updateTableVersion
ModifyColumnMigration RawSQL ()
tableName SQL
cursorSql [t] -> m ()
updateSql Int
batchSize -> do
m ()
logMigration
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
batchSize forall a. Ord a => a -> a -> Bool
< Int
1000) forall a b. (a -> b) -> a -> b
$ do
forall a. HasCallStack => String -> a
error String
"Batch size cannot be less than 1000"
forall (m :: * -> *) r.
(MonadDB m, MonadMask m) =>
CursorName SQL
-> Scroll -> Hold -> SQL -> (Cursor SQL -> m r) -> m r
withCursorSQL CursorName SQL
"migration_cursor" Scroll
NoScroll Hold
Hold SQL
cursorSql forall a b. (a -> b) -> a -> b
$ \Cursor SQL
cursor -> do
Int
vacuumThreshold <- forall a. Ord a => a -> a -> a
max Int
1000 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Integral a => a -> a -> a
`div` Int32
20) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MonadDB m => RawSQL () -> m Int32
getRowEstimate RawSQL ()
tableName
let cursorLoop :: Int -> m ()
cursorLoop Int
processed = do
forall sql (m :: * -> *).
(IsSQL sql, IsString sql, Monoid sql, MonadDB m) =>
Cursor sql -> CursorDirection -> m ()
cursorFetch_ Cursor SQL
cursor (Int -> CursorDirection
CD_Forward Int
batchSize)
[t]
primaryKeys <- forall (m :: * -> *) row t.
(MonadDB m, FromRow row) =>
(row -> t) -> m [t]
fetchMany forall a. a -> a
id
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [t]
primaryKeys) forall a b. (a -> b) -> a -> b
$ do
[t] -> m ()
updateSql [t]
primaryKeys
if Int
processed forall a. Num a => a -> a -> a
+ Int
batchSize forall a. Ord a => a -> a -> Bool
>= Int
vacuumThreshold
then do
forall (m :: * -> *) a c b. MonadMask m => m a -> m c -> m b -> m b
bracket_ (forall (m :: * -> *). MonadDB m => SQL -> m ()
runSQL_ SQL
"COMMIT")
(forall (m :: * -> *). MonadDB m => SQL -> m ()
runSQL_ SQL
"BEGIN")
(forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ forall a b. (a -> b) -> a -> b
$ RawSQL ()
"VACUUM" forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
tableName)
Int -> m ()
cursorLoop Int
0
else do
forall (m :: * -> *). MonadDB m => m ()
commit
Int -> m ()
cursorLoop (Int
processed forall a. Num a => a -> a -> a
+ Int
batchSize)
Int -> m ()
cursorLoop Int
0
m ()
updateTableVersion
where
logMigration :: m ()
logMigration = do
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ forall a b. (a -> b) -> a -> b
$ RawSQL () -> Text
arrListTable RawSQL ()
mgrTableName
forall a. Semigroup a => a -> a -> a
<> forall a. TextShow a => a -> Text
showt Int32
mgrFrom forall m. (IsString m, Monoid m) => m -> m -> m
<+> Text
"->" forall m. (IsString m, Monoid m) => m -> m -> m
<+> forall a. TextShow a => a -> Text
showt (forall a. Enum a => a -> a
succ Int32
mgrFrom)
updateTableVersion :: m ()
updateTableVersion = do
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ forall a b. (a -> b) -> a -> b
$ SQL -> State SqlUpdate () -> SqlUpdate
sqlUpdate SQL
"table_versions" forall a b. (a -> b) -> a -> b
$ do
forall v (m :: * -> *) a.
(MonadState v m, SqlSet v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlSet SQL
"version" (forall a. Enum a => a -> a
succ Int32
mgrFrom)
forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"name" (Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSQL () -> Text
unRawSQL forall a b. (a -> b) -> a -> b
$ RawSQL ()
mgrTableName)
getRowEstimate :: MonadDB m => RawSQL () -> m Int32
getRowEstimate :: MonadDB m => RawSQL () -> m Int32
getRowEstimate RawSQL ()
tableName = do
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_class" forall a b. (a -> b) -> a -> b
$ do
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"reltuples::integer"
forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"relname" forall a b. (a -> b) -> a -> b
$ RawSQL () -> Text
unRawSQL RawSQL ()
tableName
forall (m :: * -> *) row t.
(MonadDB m, MonadThrow m, FromRow row) =>
(row -> t) -> m t
fetchOne forall a. Identity a -> a
runIdentity
runMigrations :: [(Text, Int32)] -> m ()
runMigrations :: [(Text, Int32)] -> m ()
runMigrations [(Text, Int32)]
dbTablesWithVersions = do
let migrationsToRun :: [Migration m]
migrationsToRun = [(Text, Int32)] -> [Migration m]
findMigrationsToRun [(Text, Int32)]
dbTablesWithVersions
[Migration m] -> [(Text, Int32)] -> m ()
validateMigrationsToRun [Migration m]
migrationsToRun [(Text, Int32)]
dbTablesWithVersions
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ [Migration m]
migrationsToRun) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ Text
"Running migrations..."
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Migration m]
migrationsToRun forall a b. (a -> b) -> a -> b
$ \Migration m
mgr -> forall a. (a -> a) -> a
fix forall a b. (a -> b) -> a -> b
$ \m ()
loop -> do
let restartMigration :: String -> m ()
restartMigration String
query = do
forall (m :: * -> *) a. (MonadLog m, ToJSON a) => Text -> a -> m ()
logAttention Text
"Failed to acquire a lock" forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [Key
"query" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String
query]
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ Text
"Restarting the migration shortly..."
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
1000000
m ()
loop
forall (m :: * -> *) e b a.
(MonadCatch m, Exception e) =>
(e -> Maybe b) -> (b -> m a) -> m a -> m a
handleJust DBException -> Maybe String
lockNotAvailable String -> m ()
restartMigration forall a b. (a -> b) -> a -> b
$ do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (ExtrasOptions -> Maybe Int
eoLockTimeoutMs ExtrasOptions
options) forall a b. (a -> b) -> a -> b
$ \Int
lockTimeout -> do
forall (m :: * -> *). MonadDB m => SQL -> m ()
runSQL_ forall a b. (a -> b) -> a -> b
$ SQL
"SET LOCAL lock_timeout TO" forall m. (IsString m, Monoid m) => m -> m -> m
<+> Int -> SQL
intToSQL Int
lockTimeout
Migration m -> m ()
runMigration Migration m
mgr forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
`onException` forall (m :: * -> *). MonadDB m => m ()
rollback
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ forall a b. (a -> b) -> a -> b
$ Text
"Committing migration changes..."
forall (m :: * -> *). MonadDB m => m ()
commit
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ Text
"Running migrations... done."
where
intToSQL :: Int -> SQL
intToSQL :: Int -> SQL
intToSQL = forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show
lockNotAvailable :: DBException -> Maybe String
lockNotAvailable :: DBException -> Maybe String
lockNotAvailable DBException{e
sql
dbeQueryContext :: ()
dbeError :: ()
dbeError :: e
dbeQueryContext :: sql
..}
| Just DetailedQueryError{String
Maybe Int
Maybe String
ErrorCode
qeSeverity :: DetailedQueryError -> String
qeErrorCode :: DetailedQueryError -> ErrorCode
qeMessagePrimary :: DetailedQueryError -> String
qeMessageDetail :: DetailedQueryError -> Maybe String
qeMessageHint :: DetailedQueryError -> Maybe String
qeStatementPosition :: DetailedQueryError -> Maybe Int
qeInternalPosition :: DetailedQueryError -> Maybe Int
qeInternalQuery :: DetailedQueryError -> Maybe String
qeContext :: DetailedQueryError -> Maybe String
qeSourceFile :: DetailedQueryError -> Maybe String
qeSourceLine :: DetailedQueryError -> Maybe Int
qeSourceFunction :: DetailedQueryError -> Maybe String
qeSourceFunction :: Maybe String
qeSourceLine :: Maybe Int
qeSourceFile :: Maybe String
qeContext :: Maybe String
qeInternalQuery :: Maybe String
qeInternalPosition :: Maybe Int
qeStatementPosition :: Maybe Int
qeMessageHint :: Maybe String
qeMessageDetail :: Maybe String
qeMessagePrimary :: String
qeErrorCode :: ErrorCode
qeSeverity :: String
..} <- forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
dbeError
, ErrorCode
qeErrorCode forall a. Eq a => a -> a -> Bool
== ErrorCode
LockNotAvailable = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show sql
dbeQueryContext
| Bool
otherwise = forall a. Maybe a
Nothing
validateMigrationsToRun :: [Migration m] -> [(Text, Int32)] -> m ()
validateMigrationsToRun :: [Migration m] -> [(Text, Int32)] -> m ()
validateMigrationsToRun [Migration m]
migrationsToRun [(Text, Int32)]
dbTablesWithVersions = do
let migrationsToRunGrouped :: [[Migration m]]
migrationsToRunGrouped :: [[Migration m]]
migrationsToRunGrouped =
forall a. (a -> a -> Bool) -> [a] -> [[a]]
L.groupBy (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a. (a -> a -> Ordering) -> [a] -> [a]
L.sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName) forall a b. (a -> b) -> a -> b
$
[Migration m]
migrationsToRun
loc_common :: String
loc_common = String
"Database.PostgreSQL.PQTypes.Checks."
forall a. [a] -> [a] -> [a]
++ String
"checkDBConsistency.validateMigrationsToRun"
lookupDBTableVer :: [Migration m] -> Maybe Int32
lookupDBTableVer :: [Migration m] -> Maybe Int32
lookupDBTableVer [Migration m]
mgrGroup =
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (RawSQL () -> Text
unRawSQL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. String -> [a] -> a
headExc String
head_err
forall a b. (a -> b) -> a -> b
$ [Migration m]
mgrGroup) [(Text, Int32)]
dbTablesWithVersions
where
head_err :: String
head_err = String
loc_common forall a. [a] -> [a] -> [a]
++ String
".lookupDBTableVer: broken invariant"
groupsWithWrongDBTableVersions :: [([Migration m], Int32)]
groupsWithWrongDBTableVersions :: [([Migration m], Int32)]
groupsWithWrongDBTableVersions =
[ ([Migration m]
mgrGroup, Int32
dbTableVer)
| [Migration m]
mgrGroup <- [[Migration m]]
migrationsToRunGrouped
, let dbTableVer :: Int32
dbTableVer = forall a. a -> Maybe a -> a
fromMaybe Int32
0 forall a b. (a -> b) -> a -> b
$ [Migration m] -> Maybe Int32
lookupDBTableVer [Migration m]
mgrGroup
, Int32
dbTableVer forall a. Eq a => a -> a -> Bool
/= (forall (m :: * -> *). Migration m -> Int32
mgrFrom forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. String -> [a] -> a
headExc String
head_err forall a b. (a -> b) -> a -> b
$ [Migration m]
mgrGroup)
]
where
head_err :: String
head_err = String
loc_common
forall a. [a] -> [a] -> [a]
++ String
".groupsWithWrongDBTableVersions: broken invariant"
mgrGroupsNotInDB :: [[Migration m]]
mgrGroupsNotInDB :: [[Migration m]]
mgrGroupsNotInDB =
[ [Migration m]
mgrGroup
| [Migration m]
mgrGroup <- [[Migration m]]
migrationsToRunGrouped
, forall a. Maybe a -> Bool
isNothing forall a b. (a -> b) -> a -> b
$ [Migration m] -> Maybe Int32
lookupDBTableVer [Migration m]
mgrGroup
]
groupsStartingWithDropTable :: [[Migration m]]
groupsStartingWithDropTable :: [[Migration m]]
groupsStartingWithDropTable =
[ [Migration m]
mgrGroup
| [Migration m]
mgrGroup <- [[Migration m]]
mgrGroupsNotInDB
, forall (m :: * -> *). Migration m -> Bool
isDropTableMigration forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. String -> [a] -> a
headExc String
head_err forall a b. (a -> b) -> a -> b
$ [Migration m]
mgrGroup
]
where
head_err :: String
head_err = String
loc_common
forall a. [a] -> [a] -> [a]
++ String
".groupsStartingWithDropTable: broken invariant"
groupsNotStartingWithCreateTable :: [[Migration m]]
groupsNotStartingWithCreateTable :: [[Migration m]]
groupsNotStartingWithCreateTable =
[ [Migration m]
mgrGroup
| [Migration m]
mgrGroup <- [[Migration m]]
mgrGroupsNotInDB
, forall (m :: * -> *). Migration m -> Int32
mgrFrom (forall a. String -> [a] -> a
headExc String
head_err [Migration m]
mgrGroup) forall a. Eq a => a -> a -> Bool
/= Int32
0
]
where
head_err :: String
head_err = String
loc_common
forall a. [a] -> [a] -> [a]
++ String
".groupsNotStartingWithCreateTable: broken invariant"
tblNames :: [[Migration m]] -> [RawSQL ()]
tblNames :: [[Migration m]] -> [RawSQL ()]
tblNames [[Migration m]]
grps =
[ forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. String -> [a] -> a
headExc String
head_err forall a b. (a -> b) -> a -> b
$ [Migration m]
grp | [Migration m]
grp <- [[Migration m]]
grps ]
where
head_err :: String
head_err = String
loc_common forall a. [a] -> [a] -> [a]
++ String
".tblNames: broken invariant"
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ [([Migration m], Int32)]
groupsWithWrongDBTableVersions) forall a b. (a -> b) -> a -> b
$ do
let tnms :: [RawSQL ()]
tnms = [[Migration m]] -> [RawSQL ()]
tblNames forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ [([Migration m], Int32)]
groupsWithWrongDBTableVersions
forall (m :: * -> *) a. (MonadLog m, ToJSON a) => Text -> a -> m ()
logAttention
(Text
"There are migration chains selected for execution "
forall a. Semigroup a => a -> a -> a
<> Text
"that expect a different starting table version number "
forall a. Semigroup a => a -> a -> a
<> Text
"from the one in the database. "
forall a. Semigroup a => a -> a -> a
<> Text
"This likely means that the order of migrations is wrong.")
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [ Key
"tables" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a b. (a -> b) -> [a] -> [b]
map RawSQL () -> Text
unRawSQL [RawSQL ()]
tnms ]
forall a. HasCallStack => [RawSQL ()] -> a
errorInvalidMigrations [RawSQL ()]
tnms
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ [[Migration m]]
groupsStartingWithDropTable) forall a b. (a -> b) -> a -> b
$ do
let tnms :: [RawSQL ()]
tnms = [[Migration m]] -> [RawSQL ()]
tblNames [[Migration m]]
groupsStartingWithDropTable
forall (m :: * -> *) a. (MonadLog m, ToJSON a) => Text -> a -> m ()
logAttention Text
"There are drop table migrations for non-existing tables."
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [ Key
"tables" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a b. (a -> b) -> [a] -> [b]
map RawSQL () -> Text
unRawSQL [RawSQL ()]
tnms ]
forall a. HasCallStack => [RawSQL ()] -> a
errorInvalidMigrations [RawSQL ()]
tnms
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ [[Migration m]]
groupsNotStartingWithCreateTable) forall a b. (a -> b) -> a -> b
$ do
let tnms :: [RawSQL ()]
tnms = [[Migration m]] -> [RawSQL ()]
tblNames [[Migration m]]
groupsNotStartingWithCreateTable
forall (m :: * -> *) a. (MonadLog m, ToJSON a) => Text -> a -> m ()
logAttention
(Text
"Some tables haven't been created yet, but" forall a. Semigroup a => a -> a -> a
<>
Text
"their migration lists don't start with a create table migration.")
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [ Key
"tables" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a b. (a -> b) -> [a] -> [b]
map RawSQL () -> Text
unRawSQL [RawSQL ()]
tnms ]
forall a. HasCallStack => [RawSQL ()] -> a
errorInvalidMigrations [RawSQL ()]
tnms
type TablesWithVersions = [(Table, Int32)]
getTableVersions :: (MonadDB m, MonadThrow m) => [Table] -> m TablesWithVersions
getTableVersions :: forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
[Table] -> m TablesWithVersions
getTableVersions [Table]
tbls =
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
[ (\Maybe Int32
mver -> (Table
tbl, forall a. a -> Maybe a -> a
fromMaybe Int32
0 Maybe Int32
mver)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
String -> m (Maybe Int32)
checkTableVersion (Table -> String
tblNameString Table
tbl)
| Table
tbl <- [Table]
tbls ]
noTablesPresent :: TablesWithVersions -> Bool
noTablesPresent :: TablesWithVersions -> Bool
noTablesPresent = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Eq a => a -> a -> Bool
(==) Int32
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
getDBTableVersions :: (MonadDB m, MonadThrow m) => m [(Text, Int32)]
getDBTableVersions :: forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
m [(Text, Int32)]
getDBTableVersions = do
[Text]
dbTableNames <- forall (m :: * -> *). MonadDB m => m [Text]
getDBTableNames
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
[ (\Maybe Int32
mver -> (Text
name, forall a. a -> Maybe a -> a
fromMaybe Int32
0 Maybe Int32
mver)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
String -> m (Maybe Int32)
checkTableVersion (Text -> String
T.unpack Text
name)
| Text
name <- [Text]
dbTableNames ]
checkTableVersion :: (MonadDB m, MonadThrow m) => String -> m (Maybe Int32)
checkTableVersion :: forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
String -> m (Maybe Int32)
checkTableVersion String
tblName = do
Bool
doesExist <- forall sql (m :: * -> *).
(IsSQL sql, MonadDB m, MonadThrow m) =>
sql -> m Bool
runQuery01 forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_class c" forall a b. (a -> b) -> a -> b
$ do
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"TRUE"
forall v (m :: * -> *).
(MonadState v m, SqlFrom v) =>
SQL -> SQL -> m ()
sqlLeftJoinOn SQL
"pg_catalog.pg_namespace n" SQL
"n.oid = c.relnamespace"
forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"c.relname" forall a b. (a -> b) -> a -> b
$ String
tblName
forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere SQL
"pg_catalog.pg_table_is_visible(c.oid)"
if Bool
doesExist
then do
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ forall a b. (a -> b) -> a -> b
$ SQL
"SELECT version FROM table_versions WHERE name ="
forall t. (Show t, ToSQL t) => SQL -> t -> SQL
<?> String
tblName
Maybe Int32
mver <- forall (m :: * -> *) row t.
(MonadDB m, MonadThrow m, FromRow row) =>
(row -> t) -> m (Maybe t)
fetchMaybe forall a. Identity a -> a
runIdentity
case Maybe Int32
mver of
Just Int32
ver -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Int32
ver
Maybe Int32
Nothing -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"checkTableVersion: table '"
forall a. [a] -> [a] -> [a]
++ String
tblName
forall a. [a] -> [a] -> [a]
++ String
"' is present in the database, "
forall a. [a] -> [a] -> [a]
++ String
"but there is no corresponding version info in 'table_versions'."
else do
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
sqlGetTableID :: Table -> SQL
sqlGetTableID :: Table -> SQL
sqlGetTableID Table
table = SQL -> SQL
parenthesize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Sqlable a => a -> SQL
toSQLCommand forall a b. (a -> b) -> a -> b
$
SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_class c" forall a b. (a -> b) -> a -> b
$ do
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"c.oid"
forall v (m :: * -> *).
(MonadState v m, SqlFrom v) =>
SQL -> SQL -> m ()
sqlLeftJoinOn SQL
"pg_catalog.pg_namespace n" SQL
"n.oid = c.relnamespace"
forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"c.relname" forall a b. (a -> b) -> a -> b
$ Table -> String
tblNameString Table
table
forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere SQL
"pg_catalog.pg_table_is_visible(c.oid)"
sqlGetPrimaryKey
:: (MonadDB m, MonadThrow m)
=> Table -> m (Maybe (PrimaryKey, RawSQL ()))
sqlGetPrimaryKey :: forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
Table -> m (Maybe (PrimaryKey, RawSQL ()))
sqlGetPrimaryKey Table
table = do
(Maybe [Int16]
mColumnNumbers :: Maybe [Int16]) <- do
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_constraint" forall a b. (a -> b) -> a -> b
$ do
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"conkey"
forall v (m :: * -> *) sql.
(MonadState v m, SqlWhere v, Sqlable sql) =>
SQL -> sql -> m ()
sqlWhereEqSql SQL
"conrelid" (Table -> SQL
sqlGetTableID Table
table)
forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"contype" Char
'p'
forall (m :: * -> *) row t.
(MonadDB m, MonadThrow m, FromRow row) =>
(row -> t) -> m (Maybe t)
fetchMaybe forall a b. (a -> b) -> a -> b
$ forall a. Array1 a -> [a]
unArray1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Identity a -> a
runIdentity
case Maybe [Int16]
mColumnNumbers of
Maybe [Int16]
Nothing -> do forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just [Int16]
columnNumbers -> do
[String]
columnNames <- do
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int16]
columnNumbers forall a b. (a -> b) -> a -> b
$ \Int16
k -> do
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pk_columns" forall a b. (a -> b) -> a -> b
$ do
forall v (m :: * -> *) s.
(MonadState v m, SqlWith v, Sqlable s) =>
SQL -> s -> m ()
sqlWith SQL
"key_series" forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_constraint as c2" forall a b. (a -> b) -> a -> b
$ do
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"unnest(c2.conkey) as k"
forall v (m :: * -> *) sql.
(MonadState v m, SqlWhere v, Sqlable sql) =>
SQL -> sql -> m ()
sqlWhereEqSql SQL
"c2.conrelid" forall a b. (a -> b) -> a -> b
$ Table -> SQL
sqlGetTableID Table
table
forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"c2.contype" Char
'p'
forall v (m :: * -> *) s.
(MonadState v m, SqlWith v, Sqlable s) =>
SQL -> s -> m ()
sqlWith SQL
"pk_columns" forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"key_series" forall a b. (a -> b) -> a -> b
$ do
forall v (m :: * -> *).
(MonadState v m, SqlFrom v) =>
SQL -> SQL -> m ()
sqlJoinOn SQL
"pg_catalog.pg_attribute as a" SQL
"a.attnum = key_series.k"
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"a.attname::text as column_name"
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"key_series.k as column_order"
forall v (m :: * -> *) sql.
(MonadState v m, SqlWhere v, Sqlable sql) =>
SQL -> sql -> m ()
sqlWhereEqSql SQL
"a.attrelid" forall a b. (a -> b) -> a -> b
$ Table -> SQL
sqlGetTableID Table
table
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"pk_columns.column_name"
forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"pk_columns.column_order" Int16
k
forall (m :: * -> *) row t.
(MonadDB m, MonadThrow m, FromRow row) =>
(row -> t) -> m t
fetchOne (\(Identity String
t) -> String
t :: String)
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_constraint as c" forall a b. (a -> b) -> a -> b
$ do
forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"c.contype" Char
'p'
forall v (m :: * -> *) sql.
(MonadState v m, SqlWhere v, Sqlable sql) =>
SQL -> sql -> m ()
sqlWhereEqSql SQL
"c.conrelid" forall a b. (a -> b) -> a -> b
$ Table -> SQL
sqlGetTableID Table
table
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"c.conname::text"
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
Data.String.fromString
(String
"array['" forall a. Semigroup a => a -> a -> a
<> (forall m. Monoid m => m -> [m] -> m
mintercalate String
"', '" [String]
columnNames) forall a. Semigroup a => a -> a -> a
<> String
"']::text[]")
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) row t.
(MonadDB m, MonadThrow m, FromRow row) =>
(row -> t) -> m (Maybe t)
fetchMaybe (String, Array1 String) -> Maybe (PrimaryKey, RawSQL ())
fetchPrimaryKey
fetchPrimaryKey :: (String, Array1 String) -> Maybe (PrimaryKey, RawSQL ())
fetchPrimaryKey :: (String, Array1 String) -> Maybe (PrimaryKey, RawSQL ())
fetchPrimaryKey (String
name, Array1 [String]
columns) = (, forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL String
name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([RawSQL ()] -> Maybe PrimaryKey
pkOnColumns forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL [String]
columns)
sqlGetChecks :: Table -> SQL
sqlGetChecks :: Table -> SQL
sqlGetChecks Table
table = forall a. Sqlable a => a -> SQL
toSQLCommand forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_constraint c" forall a b. (a -> b) -> a -> b
$ do
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"c.conname::text"
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"regexp_replace(pg_get_constraintdef(c.oid, true), \
\'CHECK \\((.*)\\)', '\\1') AS body"
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"c.convalidated"
forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"c.contype" Char
'c'
forall v (m :: * -> *) sql.
(MonadState v m, SqlWhere v, Sqlable sql) =>
SQL -> sql -> m ()
sqlWhereEqSql SQL
"c.conrelid" forall a b. (a -> b) -> a -> b
$ Table -> SQL
sqlGetTableID Table
table
fetchTableCheck :: (String, String, Bool) -> Check
fetchTableCheck :: (String, String, Bool) -> Check
fetchTableCheck (String
name, String
condition, Bool
validated) = Check {
chkName :: RawSQL ()
chkName = forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL String
name
, chkCondition :: RawSQL ()
chkCondition = forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL String
condition
, chkValidated :: Bool
chkValidated = Bool
validated
}
sqlGetIndexes :: Table -> SQL
sqlGetIndexes :: Table -> SQL
sqlGetIndexes Table
table = forall a. Sqlable a => a -> SQL
toSQLCommand forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_class c" forall a b. (a -> b) -> a -> b
$ do
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"c.relname::text"
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult forall a b. (a -> b) -> a -> b
$ SQL
"ARRAY(" forall a. Semigroup a => a -> a -> a
<> forall m. (IsString m, Monoid m) => m -> m -> m
selectCoordinates SQL
"0" SQL
"i.indnkeyatts" forall a. Semigroup a => a -> a -> a
<> SQL
")"
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult forall a b. (a -> b) -> a -> b
$ SQL
"ARRAY(" forall a. Semigroup a => a -> a -> a
<> forall m. (IsString m, Monoid m) => m -> m -> m
selectCoordinates SQL
"i.indnkeyatts" SQL
"i.indnatts" forall a. Semigroup a => a -> a -> a
<> SQL
")"
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"am.amname::text"
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"i.indisunique"
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"i.indisvalid"
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"pg_catalog.pg_get_expr(i.indpred, i.indrelid, true)"
forall v (m :: * -> *).
(MonadState v m, SqlFrom v) =>
SQL -> SQL -> m ()
sqlJoinOn SQL
"pg_catalog.pg_index i" SQL
"c.oid = i.indexrelid"
forall v (m :: * -> *).
(MonadState v m, SqlFrom v) =>
SQL -> SQL -> m ()
sqlJoinOn SQL
"pg_catalog.pg_am am" SQL
"c.relam = am.oid"
forall v (m :: * -> *).
(MonadState v m, SqlFrom v) =>
SQL -> SQL -> m ()
sqlLeftJoinOn SQL
"pg_catalog.pg_constraint r"
SQL
"r.conrelid = i.indrelid AND r.conindid = i.indexrelid"
forall v (m :: * -> *) sql.
(MonadState v m, SqlWhere v, Sqlable sql) =>
SQL -> sql -> m ()
sqlWhereEqSql SQL
"i.indrelid" forall a b. (a -> b) -> a -> b
$ Table -> SQL
sqlGetTableID Table
table
forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhereIsNULL SQL
"r.contype"
where
selectCoordinates :: m -> m -> m
selectCoordinates m
start m
end = forall m. (IsString m, Monoid m) => [m] -> m
smconcat [
m
"WITH RECURSIVE coordinates(k, name) AS ("
, m
" VALUES (" forall a. Semigroup a => a -> a -> a
<> m
start forall a. Semigroup a => a -> a -> a
<> m
"::integer, NULL)"
, m
" UNION ALL"
, m
" SELECT k+1, pg_catalog.pg_get_indexdef(i.indexrelid, k+1, true)"
, m
" FROM coordinates"
, m
" WHERE k < " forall a. Semigroup a => a -> a -> a
<> m
end
, m
")"
, m
"SELECT name FROM coordinates WHERE name IS NOT NULL"
]
fetchTableIndex
:: (String, Array1 String, Array1 String, String, Bool, Bool, Maybe String)
-> (TableIndex, RawSQL ())
fetchTableIndex :: (String, Array1 String, Array1 String, String, Bool, Bool,
Maybe String)
-> (TableIndex, RawSQL ())
fetchTableIndex (String
name, Array1 [String]
keyColumns, Array1 [String]
includeColumns, String
method, Bool
unique, Bool
valid, Maybe String
mconstraint) =
(TableIndex
{ idxColumns :: [IndexColumn]
idxColumns = forall a b. (a -> b) -> [a] -> [b]
map (RawSQL () -> IndexColumn
indexColumn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL) [String]
keyColumns
, idxInclude :: [RawSQL ()]
idxInclude = forall a b. (a -> b) -> [a] -> [b]
map forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL [String]
includeColumns
, idxMethod :: IndexMethod
idxMethod = forall a. Read a => String -> a
read String
method
, idxUnique :: Bool
idxUnique = Bool
unique
, idxValid :: Bool
idxValid = Bool
valid
, idxWhere :: Maybe (RawSQL ())
idxWhere = forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` Maybe String
mconstraint
}
, forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL String
name)
sqlGetForeignKeys :: Table -> SQL
sqlGetForeignKeys :: Table -> SQL
sqlGetForeignKeys Table
table = forall a. Sqlable a => a -> SQL
toSQLCommand
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_constraint r" forall a b. (a -> b) -> a -> b
$ do
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"r.conname::text"
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult forall a b. (a -> b) -> a -> b
$
SQL
"ARRAY(SELECT a.attname::text FROM pg_catalog.pg_attribute a JOIN ("
forall a. Semigroup a => a -> a -> a
<> RawSQL () -> SQL
unnestWithOrdinality RawSQL ()
"r.conkey"
forall a. Semigroup a => a -> a -> a
<> SQL
") conkeys ON (a.attnum = conkeys.item) \
\WHERE a.attrelid = r.conrelid \
\ORDER BY conkeys.n)"
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"c.relname::text"
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult forall a b. (a -> b) -> a -> b
$ SQL
"ARRAY(SELECT a.attname::text \
\FROM pg_catalog.pg_attribute a JOIN ("
forall a. Semigroup a => a -> a -> a
<> RawSQL () -> SQL
unnestWithOrdinality RawSQL ()
"r.confkey"
forall a. Semigroup a => a -> a -> a
<> SQL
") confkeys ON (a.attnum = confkeys.item) \
\WHERE a.attrelid = r.confrelid \
\ORDER BY confkeys.n)"
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"r.confupdtype"
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"r.confdeltype"
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"r.condeferrable"
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"r.condeferred"
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"r.convalidated"
forall v (m :: * -> *).
(MonadState v m, SqlFrom v) =>
SQL -> SQL -> m ()
sqlJoinOn SQL
"pg_catalog.pg_class c" SQL
"c.oid = r.confrelid"
forall v (m :: * -> *) sql.
(MonadState v m, SqlWhere v, Sqlable sql) =>
SQL -> sql -> m ()
sqlWhereEqSql SQL
"r.conrelid" forall a b. (a -> b) -> a -> b
$ Table -> SQL
sqlGetTableID Table
table
forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"r.contype" Char
'f'
where
unnestWithOrdinality :: RawSQL () -> SQL
unnestWithOrdinality :: RawSQL () -> SQL
unnestWithOrdinality RawSQL ()
arr =
SQL
"SELECT n, " forall a. Semigroup a => a -> a -> a
<> RawSQL () -> SQL
raw RawSQL ()
arr
forall a. Semigroup a => a -> a -> a
<> SQL
"[n] AS item FROM generate_subscripts(" forall a. Semigroup a => a -> a -> a
<> RawSQL () -> SQL
raw RawSQL ()
arr forall a. Semigroup a => a -> a -> a
<> SQL
", 1) AS n"
fetchForeignKey ::
(String, Array1 String, String, Array1 String, Char, Char, Bool, Bool, Bool)
-> (ForeignKey, RawSQL ())
fetchForeignKey :: (String, Array1 String, String, Array1 String, Char, Char, Bool,
Bool, Bool)
-> (ForeignKey, RawSQL ())
fetchForeignKey
( String
name, Array1 [String]
columns, String
reftable, Array1 [String]
refcolumns
, Char
on_update, Char
on_delete, Bool
deferrable, Bool
deferred, Bool
validated ) = (ForeignKey {
fkColumns :: [RawSQL ()]
fkColumns = forall a b. (a -> b) -> [a] -> [b]
map forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL [String]
columns
, fkRefTable :: RawSQL ()
fkRefTable = forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL String
reftable
, fkRefColumns :: [RawSQL ()]
fkRefColumns = forall a b. (a -> b) -> [a] -> [b]
map forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL [String]
refcolumns
, fkOnUpdate :: ForeignKeyAction
fkOnUpdate = Char -> ForeignKeyAction
charToForeignKeyAction Char
on_update
, fkOnDelete :: ForeignKeyAction
fkOnDelete = Char -> ForeignKeyAction
charToForeignKeyAction Char
on_delete
, fkDeferrable :: Bool
fkDeferrable = Bool
deferrable
, fkDeferred :: Bool
fkDeferred = Bool
deferred
, fkValidated :: Bool
fkValidated = Bool
validated
}, forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL String
name)
where
charToForeignKeyAction :: Char -> ForeignKeyAction
charToForeignKeyAction Char
c = case Char
c of
Char
'a' -> ForeignKeyAction
ForeignKeyNoAction
Char
'r' -> ForeignKeyAction
ForeignKeyRestrict
Char
'c' -> ForeignKeyAction
ForeignKeyCascade
Char
'n' -> ForeignKeyAction
ForeignKeySetNull
Char
'd' -> ForeignKeyAction
ForeignKeySetDefault
Char
_ -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"fetchForeignKey: invalid foreign key action code: "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Char
c