module Database.PostgreSQL.PQTypes.Checks (
checkDatabase
, checkDatabaseAllowUnknownObjects
, createTable
, createDomain
, ExtrasOptions(..)
, defaultExtrasOptions
, migrateDatabase
) where
import Control.Arrow ((&&&))
import Control.Applicative ((<$>))
import Control.Monad.Catch
import Control.Monad.Reader
import Data.Int
import Data.Function (on)
import Data.Maybe
import Data.Monoid
import Data.Monoid.Utils
import Data.Ord (comparing)
import qualified Data.String
import Data.Text (Text)
import Database.PostgreSQL.PQTypes
import GHC.Stack (HasCallStack)
import Log
import Prelude
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 :: String -> [a] -> a
headExc String
s [] = String -> a
forall a. HasCallStack => String -> a
error String
s
headExc String
_ (a
x:[a]
_) = a
x
migrateDatabase
:: (MonadDB m, MonadLog m, MonadMask m)
=> ExtrasOptions
-> [Extension]
-> [CompositeType]
-> [Domain]
-> [Table]
-> [Migration m]
-> m ()
migrateDatabase :: ExtrasOptions
-> [Extension]
-> [CompositeType]
-> [Domain]
-> [Table]
-> [Migration m]
-> m ()
migrateDatabase ExtrasOptions
options
[Extension]
extensions [CompositeType]
composites [Domain]
domains [Table]
tables [Migration m]
migrations = do
m ()
forall (m :: * -> *). (MonadDB m, MonadLog m, MonadThrow m) => m ()
setDBTimeZoneToUTC
(Extension -> m ()) -> [Extension] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Extension -> m ()
forall (m :: * -> *).
(MonadDB m, MonadLog m, MonadThrow m) =>
Extension -> m ()
checkExtension [Extension]
extensions
TablesWithVersions
tablesWithVersions <- [Table] -> m TablesWithVersions
forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
[Table] -> m TablesWithVersions
getTableVersions (Table
tableVersions Table -> [Table] -> [Table]
forall a. a -> [a] -> [a]
: [Table]
tables)
ExtrasOptions
-> [Domain] -> TablesWithVersions -> [Migration m] -> m ()
forall (m :: * -> *).
(MonadDB m, MonadLog m, MonadMask m) =>
ExtrasOptions
-> [Domain] -> TablesWithVersions -> [Migration m] -> m ()
checkDBConsistency ExtrasOptions
options [Domain]
domains TablesWithVersions
tablesWithVersions [Migration m]
migrations
ValidationResult -> m ()
forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck (ValidationResult -> m ()) -> m ValidationResult -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TablesWithVersions
-> CompositesCreationMode
-> ObjectsValidationMode
-> [CompositeType]
-> m ValidationResult
forall (m :: * -> *).
MonadDB m =>
TablesWithVersions
-> CompositesCreationMode
-> ObjectsValidationMode
-> [CompositeType]
-> m ValidationResult
checkCompositesStructure TablesWithVersions
tablesWithVersions
CompositesCreationMode
CreateCompositesIfDatabaseEmpty
ObjectsValidationMode
DontAllowUnknownObjects
[CompositeType]
composites
ValidationResult -> m ()
forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck (ValidationResult -> m ()) -> m ValidationResult -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Domain] -> m ValidationResult
forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
[Domain] -> m ValidationResult
checkDomainsStructure [Domain]
domains
ValidationResult -> m ()
forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck (ValidationResult -> m ()) -> m ValidationResult -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExtrasOptions -> TablesWithVersions -> m ValidationResult
forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
ExtrasOptions -> TablesWithVersions -> m ValidationResult
checkDBStructure ExtrasOptions
options TablesWithVersions
tablesWithVersions
ValidationResult -> m ()
forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck (ValidationResult -> m ()) -> m ValidationResult -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Migration m] -> m ValidationResult
forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
[Migration m] -> m ValidationResult
checkTablesWereDropped [Migration m]
migrations
ValidationResult -> m ()
forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck (ValidationResult -> m ()) -> m ValidationResult -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Table] -> m ValidationResult
forall (m :: * -> *).
(MonadDB m, MonadLog m) =>
[Table] -> m ValidationResult
checkUnknownTables [Table]
tables
ValidationResult -> m ()
forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck (ValidationResult -> m ()) -> m ValidationResult -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Table] -> m ValidationResult
forall (m :: * -> *).
(MonadDB m, MonadLog m) =>
[Table] -> m ValidationResult
checkExistenceOfVersionsForTables (Table
tableVersions Table -> [Table] -> [Table]
forall a. a -> [a] -> [a]
: [Table]
tables)
m ()
forall (m :: * -> *). MonadDB m => m ()
commit
checkDatabase
:: forall m . (MonadDB m, MonadLog m, MonadThrow m)
=> ExtrasOptions -> [CompositeType] -> [Domain] -> [Table] -> m ()
checkDatabase :: ExtrasOptions -> [CompositeType] -> [Domain] -> [Table] -> m ()
checkDatabase ExtrasOptions
options = ExtrasOptions
-> ObjectsValidationMode
-> [CompositeType]
-> [Domain]
-> [Table]
-> m ()
forall (m :: * -> *).
(MonadDB m, MonadLog m, MonadThrow m) =>
ExtrasOptions
-> ObjectsValidationMode
-> [CompositeType]
-> [Domain]
-> [Table]
-> m ()
checkDatabase_ ExtrasOptions
options ObjectsValidationMode
DontAllowUnknownObjects
checkDatabaseAllowUnknownObjects
:: forall m . (MonadDB m, MonadLog m, MonadThrow m)
=> ExtrasOptions -> [CompositeType] -> [Domain] -> [Table] -> m ()
checkDatabaseAllowUnknownObjects :: ExtrasOptions -> [CompositeType] -> [Domain] -> [Table] -> m ()
checkDatabaseAllowUnknownObjects ExtrasOptions
options = ExtrasOptions
-> ObjectsValidationMode
-> [CompositeType]
-> [Domain]
-> [Table]
-> m ()
forall (m :: * -> *).
(MonadDB m, MonadLog m, MonadThrow m) =>
ExtrasOptions
-> ObjectsValidationMode
-> [CompositeType]
-> [Domain]
-> [Table]
-> m ()
checkDatabase_ ExtrasOptions
options ObjectsValidationMode
AllowUnknownObjects
data ObjectsValidationMode = AllowUnknownObjects | DontAllowUnknownObjects
deriving ObjectsValidationMode -> ObjectsValidationMode -> Bool
(ObjectsValidationMode -> ObjectsValidationMode -> Bool)
-> (ObjectsValidationMode -> ObjectsValidationMode -> Bool)
-> Eq ObjectsValidationMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ObjectsValidationMode -> ObjectsValidationMode -> Bool
$c/= :: ObjectsValidationMode -> ObjectsValidationMode -> Bool
== :: ObjectsValidationMode -> ObjectsValidationMode -> Bool
$c== :: ObjectsValidationMode -> ObjectsValidationMode -> Bool
Eq
checkDatabase_
:: forall m . (MonadDB m, MonadLog m, MonadThrow m)
=> ExtrasOptions
-> ObjectsValidationMode
-> [CompositeType]
-> [Domain]
-> [Table]
-> m ()
checkDatabase_ :: ExtrasOptions
-> ObjectsValidationMode
-> [CompositeType]
-> [Domain]
-> [Table]
-> m ()
checkDatabase_ ExtrasOptions
options ObjectsValidationMode
ovm [CompositeType]
composites [Domain]
domains [Table]
tables = do
TablesWithVersions
tablesWithVersions <- [Table] -> m TablesWithVersions
forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
[Table] -> m TablesWithVersions
getTableVersions (Table
tableVersions Table -> [Table] -> [Table]
forall a. a -> [a] -> [a]
: [Table]
tables)
ValidationResult -> m ()
forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck (ValidationResult -> m ()) -> ValidationResult -> m ()
forall a b. (a -> b) -> a -> b
$ TablesWithVersions -> ValidationResult
checkVersions TablesWithVersions
tablesWithVersions
ValidationResult -> m ()
forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck (ValidationResult -> m ()) -> m ValidationResult -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TablesWithVersions
-> CompositesCreationMode
-> ObjectsValidationMode
-> [CompositeType]
-> m ValidationResult
forall (m :: * -> *).
MonadDB m =>
TablesWithVersions
-> CompositesCreationMode
-> ObjectsValidationMode
-> [CompositeType]
-> m ValidationResult
checkCompositesStructure TablesWithVersions
tablesWithVersions CompositesCreationMode
DontCreateComposites ObjectsValidationMode
ovm [CompositeType]
composites
ValidationResult -> m ()
forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck (ValidationResult -> m ()) -> m ValidationResult -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Domain] -> m ValidationResult
forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
[Domain] -> m ValidationResult
checkDomainsStructure [Domain]
domains
ValidationResult -> m ()
forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck (ValidationResult -> m ()) -> m ValidationResult -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExtrasOptions -> TablesWithVersions -> m ValidationResult
forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
ExtrasOptions -> TablesWithVersions -> m ValidationResult
checkDBStructure ExtrasOptions
options TablesWithVersions
tablesWithVersions
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ObjectsValidationMode
ovm ObjectsValidationMode -> ObjectsValidationMode -> Bool
forall a. Eq a => a -> a -> Bool
== ObjectsValidationMode
DontAllowUnknownObjects) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
ValidationResult -> m ()
forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck (ValidationResult -> m ()) -> m ValidationResult -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Table] -> m ValidationResult
forall (m :: * -> *).
(MonadDB m, MonadLog m) =>
[Table] -> m ValidationResult
checkUnknownTables [Table]
tables
ValidationResult -> m ()
forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck (ValidationResult -> m ()) -> m ValidationResult -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Table] -> m ValidationResult
forall (m :: * -> *).
(MonadDB m, MonadLog m) =>
[Table] -> m ValidationResult
checkExistenceOfVersionsForTables (Table
tableVersions Table -> [Table] -> [Table]
forall a. a -> [a] -> [a]
: [Table]
tables)
ValidationResult -> m ()
forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck (ValidationResult -> m ()) -> m ValidationResult -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Table] -> m ValidationResult
checkInitialSetups [Table]
tables
where
checkVersions :: TablesWithVersions -> ValidationResult
checkVersions :: TablesWithVersions -> ValidationResult
checkVersions TablesWithVersions
vs = [ValidationResult] -> ValidationResult
forall a. Monoid a => [a] -> a
mconcat ([ValidationResult] -> ValidationResult)
-> (TablesWithVersions -> [ValidationResult])
-> TablesWithVersions
-> ValidationResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Table, Int32) -> ValidationResult)
-> TablesWithVersions -> [ValidationResult]
forall a b. (a -> b) -> [a] -> [b]
map (Table, Int32) -> ValidationResult
checkVersion (TablesWithVersions -> ValidationResult)
-> TablesWithVersions -> ValidationResult
forall a b. (a -> b) -> a -> b
$ TablesWithVersions
vs
checkVersion :: (Table, Int32) -> ValidationResult
checkVersion :: (Table, Int32) -> ValidationResult
checkVersion (t :: Table
t@Table{Int32
[Int32]
[Check]
[ForeignKey]
[TableIndex]
[TableColumn]
Maybe PrimaryKey
Maybe TableInitialSetup
RawSQL ()
tblInitialSetup :: Table -> Maybe TableInitialSetup
tblIndexes :: Table -> [TableIndex]
tblForeignKeys :: Table -> [ForeignKey]
tblChecks :: Table -> [Check]
tblPrimaryKey :: Table -> Maybe PrimaryKey
tblColumns :: Table -> [TableColumn]
tblAcceptedDbVersions :: Table -> [Int32]
tblVersion :: Table -> Int32
tblName :: Table -> RawSQL ()
tblInitialSetup :: Maybe TableInitialSetup
tblIndexes :: [TableIndex]
tblForeignKeys :: [ForeignKey]
tblChecks :: [Check]
tblPrimaryKey :: Maybe PrimaryKey
tblColumns :: [TableColumn]
tblAcceptedDbVersions :: [Int32]
tblVersion :: Int32
tblName :: RawSQL ()
..}, Int32
v)
| Int32
tblVersion Int32 -> [Int32] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int32]
tblAcceptedDbVersions
= Text -> ValidationResult
validationError (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$
Text
"Table '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Table -> Text
tblNameText Table
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
Text
"' has its current table version in accepted db versions"
| Int32
tblVersion Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
== Int32
v Bool -> Bool -> Bool
|| Int32
v Int32 -> [Int32] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int32]
tblAcceptedDbVersions
= ValidationResult
forall a. Monoid a => a
mempty
| Int32
v Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
== Int32
0 = Text -> ValidationResult
validationError (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$
Text
"Table '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Table -> Text
tblNameText Table
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' must be created"
| Bool
otherwise = Text -> ValidationResult
validationError (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$
Text
"Table '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Table -> Text
tblNameText Table
t
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' must be migrated" Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> Int32 -> Text
forall a. TextShow a => a -> Text
showt Int32
v Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> Text
"->"
Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> Int32 -> Text
forall a. TextShow a => a -> Text
showt Int32
tblVersion
checkInitialSetups :: [Table] -> m ValidationResult
checkInitialSetups :: [Table] -> m ValidationResult
checkInitialSetups [Table]
tbls =
([ValidationResult] -> ValidationResult)
-> m [ValidationResult] -> m ValidationResult
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [ValidationResult] -> ValidationResult
forall a. Monoid a => [a] -> a
mconcat (m [ValidationResult] -> m ValidationResult)
-> ([Table] -> m [ValidationResult])
-> [Table]
-> m ValidationResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Table -> m ValidationResult) -> [Table] -> m [ValidationResult]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Table -> m ValidationResult
checkInitialSetup' ([Table] -> m ValidationResult) -> [Table] -> m ValidationResult
forall a b. (a -> b) -> a -> b
$ [Table]
tbls
checkInitialSetup' :: Table -> m ValidationResult
checkInitialSetup' :: Table -> m ValidationResult
checkInitialSetup' t :: Table
t@Table{Int32
[Int32]
[Check]
[ForeignKey]
[TableIndex]
[TableColumn]
Maybe PrimaryKey
Maybe TableInitialSetup
RawSQL ()
tblInitialSetup :: Maybe TableInitialSetup
tblIndexes :: [TableIndex]
tblForeignKeys :: [ForeignKey]
tblChecks :: [Check]
tblPrimaryKey :: Maybe PrimaryKey
tblColumns :: [TableColumn]
tblAcceptedDbVersions :: [Int32]
tblVersion :: Int32
tblName :: RawSQL ()
tblInitialSetup :: Table -> Maybe TableInitialSetup
tblIndexes :: Table -> [TableIndex]
tblForeignKeys :: Table -> [ForeignKey]
tblChecks :: Table -> [Check]
tblPrimaryKey :: Table -> Maybe PrimaryKey
tblColumns :: Table -> [TableColumn]
tblAcceptedDbVersions :: Table -> [Int32]
tblVersion :: Table -> Int32
tblName :: Table -> RawSQL ()
..} = case Maybe TableInitialSetup
tblInitialSetup of
Maybe TableInitialSetup
Nothing -> ValidationResult -> m ValidationResult
forall (m :: * -> *) a. Monad m => a -> m a
return ValidationResult
forall a. Monoid a => a
mempty
Just TableInitialSetup
is -> TableInitialSetup
-> forall (m :: * -> *). (MonadDB m, MonadThrow m) => m Bool
checkInitialSetup TableInitialSetup
is m Bool -> (Bool -> m ValidationResult) -> m ValidationResult
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
True -> ValidationResult -> m ValidationResult
forall (m :: * -> *) a. Monad m => a -> m a
return ValidationResult
forall a. Monoid a => a
mempty
Bool
False -> ValidationResult -> m ValidationResult
forall (m :: * -> *) a. Monad m => a -> m a
return (ValidationResult -> m ValidationResult)
-> (Text -> ValidationResult) -> Text -> m ValidationResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ValidationResult
validationError (Text -> m ValidationResult) -> Text -> m ValidationResult
forall a b. (a -> b) -> a -> b
$ Text
"Initial setup for table '"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Table -> Text
tblNameText Table
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' is not valid"
currentCatalog :: (MonadDB m, MonadThrow m) => m (RawSQL ())
currentCatalog :: m (RawSQL ())
currentCatalog = do
SQL -> m ()
forall (m :: * -> *). MonadDB m => SQL -> m ()
runSQL_ SQL
"SELECT current_catalog::text"
String
dbname <- (Identity String -> String) -> m String
forall (m :: * -> *) row t.
(MonadDB m, MonadThrow m, FromRow row) =>
(row -> t) -> m t
fetchOne Identity String -> String
forall a. Identity a -> a
runIdentity
RawSQL () -> m (RawSQL ())
forall (m :: * -> *) a. Monad m => a -> m a
return (RawSQL () -> m (RawSQL ())) -> RawSQL () -> m (RawSQL ())
forall a b. (a -> b) -> a -> b
$ String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL (String -> RawSQL ()) -> String -> RawSQL ()
forall a b. (a -> b) -> a -> b
$ String
"\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dbname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""
checkExtension :: (MonadDB m, MonadLog m, MonadThrow m) => Extension -> m ()
checkExtension :: Extension -> m ()
checkExtension (Extension RawSQL ()
extension) = do
Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Checking for extension '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
txtExtension Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'"
Bool
extensionExists <- SqlSelect -> m Bool
forall sql (m :: * -> *).
(IsSQL sql, MonadDB m, MonadThrow m) =>
sql -> m Bool
runQuery01 (SqlSelect -> m Bool)
-> (State SqlSelect () -> SqlSelect)
-> State SqlSelect ()
-> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_extension" (State SqlSelect () -> m Bool) -> State SqlSelect () -> m Bool
forall a b. (a -> b) -> a -> b
$ do
SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"TRUE"
SQL -> Text -> State SqlSelect ()
forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"extname" (Text -> State SqlSelect ()) -> Text -> State SqlSelect ()
forall a b. (a -> b) -> a -> b
$ RawSQL () -> Text
unRawSQL RawSQL ()
extension
if Bool -> Bool
not Bool
extensionExists
then do
Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Creating extension '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
txtExtension Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'"
SQL -> m ()
forall (m :: * -> *). MonadDB m => SQL -> m ()
runSQL_ (SQL -> m ()) -> SQL -> m ()
forall a b. (a -> b) -> a -> b
$ SQL
"CREATE EXTENSION IF NOT EXISTS" SQL -> SQL -> SQL
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL () -> SQL
raw RawSQL ()
extension
else Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Extension '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
txtExtension Text -> Text -> Text
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 :: m ()
setDBTimeZoneToUTC = do
SQL -> m ()
forall (m :: * -> *). MonadDB m => SQL -> m ()
runSQL_ SQL
"SHOW timezone"
String
timezone :: String <- (Identity String -> String) -> m String
forall (m :: * -> *) row t.
(MonadDB m, MonadThrow m, FromRow row) =>
(row -> t) -> m t
fetchOne Identity String -> String
forall a. Identity a -> a
runIdentity
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
timezone String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"UTC") (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
RawSQL ()
dbname <- m (RawSQL ())
forall (m :: * -> *). (MonadDB m, MonadThrow m) => m (RawSQL ())
currentCatalog
Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Setting '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RawSQL () -> Text
unRawSQL RawSQL ()
dbname
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' database to return timestamps in UTC"
RawSQL () -> m ()
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ (RawSQL () -> m ()) -> RawSQL () -> m ()
forall a b. (a -> b) -> a -> b
$ RawSQL ()
"ALTER DATABASE" RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
dbname RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
"SET TIMEZONE = 'UTC'"
getDBTableNames :: (MonadDB m) => m [Text]
getDBTableNames :: m [Text]
getDBTableNames = do
SqlSelect -> m ()
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ (SqlSelect -> m ()) -> SqlSelect -> m ()
forall a b. (a -> b) -> a -> b
$ SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"information_schema.tables" (State SqlSelect () -> SqlSelect)
-> State SqlSelect () -> SqlSelect
forall a b. (a -> b) -> a -> b
$ do
SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"table_name::text"
SQL -> State SqlSelect ()
forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere SQL
"table_name <> 'table_versions'"
SQL -> State SqlSelect ()
forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere SQL
"table_type = 'BASE TABLE'"
SqlSelect -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlWhere v) =>
SqlSelect -> m ()
sqlWhereExists (SqlSelect -> State SqlSelect ())
-> SqlSelect -> State SqlSelect ()
forall a b. (a -> b) -> a -> b
$ SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"unnest(current_schemas(false)) as cs" (State SqlSelect () -> SqlSelect)
-> State SqlSelect () -> SqlSelect
forall a b. (a -> b) -> a -> b
$ do
SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"TRUE"
SQL -> State SqlSelect ()
forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere SQL
"cs = table_schema"
[Text]
dbTableNames <- (Identity Text -> Text) -> m [Text]
forall (m :: * -> *) row t.
(MonadDB m, FromRow row) =>
(row -> t) -> m [t]
fetchMany Identity Text -> Text
forall a. Identity a -> a
runIdentity
[Text] -> m [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return [Text]
dbTableNames
checkUnknownTables :: (MonadDB m, MonadLog m) => [Table] -> m ValidationResult
checkUnknownTables :: [Table] -> m ValidationResult
checkUnknownTables [Table]
tables = do
[Text]
dbTableNames <- m [Text]
forall (m :: * -> *). MonadDB m => m [Text]
getDBTableNames
let tableNames :: [Text]
tableNames = (Table -> Text) -> [Table] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (RawSQL () -> Text
unRawSQL (RawSQL () -> Text) -> (Table -> RawSQL ()) -> Table -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Table -> RawSQL ()
tblName) [Table]
tables
absent :: [Text]
absent = [Text]
dbTableNames [Text] -> [Text] -> [Text]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ [Text]
tableNames
notPresent :: [Text]
notPresent = [Text]
tableNames [Text] -> [Text] -> [Text]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ [Text]
dbTableNames
if (Bool -> Bool
not (Bool -> Bool) -> ([Text] -> Bool) -> [Text] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Text] -> Bool) -> [Text] -> Bool
forall a b. (a -> b) -> a -> b
$ [Text]
absent) Bool -> Bool -> Bool
|| (Bool -> Bool
not (Bool -> Bool) -> ([Text] -> Bool) -> [Text] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Text] -> Bool) -> [Text] -> Bool
forall a b. (a -> b) -> a -> b
$ [Text]
notPresent)
then do
(Text -> m ()) -> [Text] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ (Text -> m ()) -> (Text -> Text) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
(<+>) Text
"Unknown table:") [Text]
absent
(Text -> m ()) -> [Text] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ (Text -> m ()) -> (Text -> Text) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
(<+>) Text
"Table not present in the database:") [Text]
notPresent
ValidationResult -> m ValidationResult
forall (m :: * -> *) a. Monad m => a -> m a
return (ValidationResult -> m ValidationResult)
-> ValidationResult -> m ValidationResult
forall a b. (a -> b) -> a -> b
$
(Text -> [Text] -> ValidationResult
validateIsNull Text
"Unknown tables:" [Text]
absent) ValidationResult -> ValidationResult -> ValidationResult
forall a. Semigroup a => a -> a -> a
<>
(Text -> [Text] -> ValidationResult
validateIsNull Text
"Tables not present in the database:" [Text]
notPresent)
else ValidationResult -> m ValidationResult
forall (m :: * -> *) a. Monad m => a -> m a
return ValidationResult
forall a. Monoid a => a
mempty
validateIsNull :: Text -> [Text] -> ValidationResult
validateIsNull :: Text -> [Text] -> ValidationResult
validateIsNull Text
_ [] = ValidationResult
forall a. Monoid a => a
mempty
validateIsNull Text
msg [Text]
ts = Text -> ValidationResult
validationError (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$ Text
msg Text -> Text -> Text
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 :: [Table] -> m ValidationResult
checkExistenceOfVersionsForTables [Table]
tables = do
SqlSelect -> m ()
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ (SqlSelect -> m ()) -> SqlSelect -> m ()
forall a b. (a -> b) -> a -> b
$ SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"table_versions" (State SqlSelect () -> SqlSelect)
-> State SqlSelect () -> SqlSelect
forall a b. (a -> b) -> a -> b
$ do
SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"name::text"
([Text]
existingTableNames :: [Text]) <- (Identity Text -> Text) -> m [Text]
forall (m :: * -> *) row t.
(MonadDB m, FromRow row) =>
(row -> t) -> m [t]
fetchMany Identity Text -> Text
forall a. Identity a -> a
runIdentity
let tableNames :: [Text]
tableNames = (Table -> Text) -> [Table] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (RawSQL () -> Text
unRawSQL (RawSQL () -> Text) -> (Table -> RawSQL ()) -> Table -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Table -> RawSQL ()
tblName) [Table]
tables
absent :: [Text]
absent = [Text]
existingTableNames [Text] -> [Text] -> [Text]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ [Text]
tableNames
notPresent :: [Text]
notPresent = [Text]
tableNames [Text] -> [Text] -> [Text]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ [Text]
existingTableNames
if (Bool -> Bool
not (Bool -> Bool) -> ([Text] -> Bool) -> [Text] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Text] -> Bool) -> [Text] -> Bool
forall a b. (a -> b) -> a -> b
$ [Text]
absent) Bool -> Bool -> Bool
|| (Bool -> Bool
not (Bool -> Bool) -> ([Text] -> Bool) -> [Text] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Text] -> Bool) -> [Text] -> Bool
forall a b. (a -> b) -> a -> b
$ [Text]
notPresent)
then do
(Text -> m ()) -> [Text] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ (Text -> m ()) -> (Text -> Text) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
(<+>) Text
"Unknown entry in 'table_versions':") [Text]
absent
(Text -> m ()) -> [Text] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ (Text -> m ()) -> (Text -> Text) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
(<+>) Text
"Table not present in the 'table_versions':")
[Text]
notPresent
ValidationResult -> m ValidationResult
forall (m :: * -> *) a. Monad m => a -> m a
return (ValidationResult -> m ValidationResult)
-> ValidationResult -> m ValidationResult
forall a b. (a -> b) -> a -> b
$
(Text -> [Text] -> ValidationResult
validateIsNull Text
"Unknown entry in table_versions':" [Text]
absent ) ValidationResult -> ValidationResult -> ValidationResult
forall a. Semigroup a => a -> a -> a
<>
(Text -> [Text] -> ValidationResult
validateIsNull Text
"Tables not present in the 'table_versions':" [Text]
notPresent)
else ValidationResult -> m ValidationResult
forall (m :: * -> *) a. Monad m => a -> m a
return ValidationResult
forall a. Monoid a => a
mempty
checkDomainsStructure :: (MonadDB m, MonadThrow m)
=> [Domain] -> m ValidationResult
checkDomainsStructure :: [Domain] -> m ValidationResult
checkDomainsStructure [Domain]
defs = ([ValidationResult] -> ValidationResult)
-> m [ValidationResult] -> m ValidationResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [ValidationResult] -> ValidationResult
forall a. Monoid a => [a] -> a
mconcat (m [ValidationResult] -> m ValidationResult)
-> ((Domain -> m ValidationResult) -> m [ValidationResult])
-> (Domain -> m ValidationResult)
-> m ValidationResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Domain] -> (Domain -> m ValidationResult) -> m [ValidationResult]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Domain]
defs ((Domain -> m ValidationResult) -> m ValidationResult)
-> (Domain -> m ValidationResult) -> m ValidationResult
forall a b. (a -> b) -> a -> b
$ \Domain
def -> do
SqlSelect -> m ()
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ (SqlSelect -> m ())
-> (State SqlSelect () -> SqlSelect) -> State SqlSelect () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_type t1" (State SqlSelect () -> m ()) -> State SqlSelect () -> m ()
forall a b. (a -> b) -> a -> b
$ do
SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"t1.typname::text"
SQL -> State SqlSelect ()
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)"
SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"NOT t1.typnotnull"
SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"t1.typdefault"
SQL -> State SqlSelect ()
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)"
SQL -> State SqlSelect ()
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)"
SQL -> State SqlSelect ()
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)"
SQL -> Text -> State SqlSelect ()
forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"t1.typname" (Text -> State SqlSelect ()) -> Text -> State SqlSelect ()
forall a b. (a -> b) -> a -> b
$ RawSQL () -> Text
unRawSQL (RawSQL () -> Text) -> RawSQL () -> Text
forall a b. (a -> b) -> a -> b
$ Domain -> RawSQL ()
domName Domain
def
Maybe Domain
mdom <- ((String, ColumnType, Bool, Maybe String, Array1 String,
Array1 String, Array1 Bool)
-> Domain)
-> m (Maybe Domain)
forall (m :: * -> *) row t.
(MonadDB m, MonadThrow m, FromRow row) =>
(row -> t) -> m (Maybe t)
fetchMaybe (((String, ColumnType, Bool, Maybe String, Array1 String,
Array1 String, Array1 Bool)
-> Domain)
-> m (Maybe Domain))
-> ((String, ColumnType, Bool, Maybe String, Array1 String,
Array1 String, Array1 Bool)
-> Domain)
-> m (Maybe Domain)
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 :: RawSQL ()
-> ColumnType -> Bool -> Maybe (RawSQL ()) -> Set Check -> Domain
Domain
{ domName :: RawSQL ()
domName = String -> RawSQL ()
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 = String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL (String -> RawSQL ()) -> Maybe String -> Maybe (RawSQL ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
defval
, domChecks :: Set Check
domChecks =
[Check] -> Set Check
mkChecks ([Check] -> Set Check) -> [Check] -> Set Check
forall a b. (a -> b) -> a -> b
$ (String -> String -> Bool -> Check)
-> [String] -> [String] -> [Bool] -> [Check]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3
(\String
cname String
cond Bool
validated ->
Check :: RawSQL () -> RawSQL () -> Bool -> Check
Check
{ chkName :: RawSQL ()
chkName = String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL String
cname
, chkCondition :: RawSQL ()
chkCondition = String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL String
cond
, chkValidated :: Bool
chkValidated = Bool
validated
}) (Array1 String -> [String]
forall a. Array1 a -> [a]
unArray1 Array1 String
cnames) (Array1 String -> [String]
forall a. Array1 a -> [a]
unArray1 Array1 String
conds) (Array1 Bool -> [Bool]
forall a. Array1 a -> [a]
unArray1 Array1 Bool
valids)
}
ValidationResult -> m ValidationResult
forall (m :: * -> *) a. Monad m => a -> m a
return (ValidationResult -> m ValidationResult)
-> ValidationResult -> m ValidationResult
forall a b. (a -> b) -> a -> b
$ case Maybe Domain
mdom of
Just Domain
dom
| Domain
dom Domain -> Domain -> Bool
forall a. Eq a => a -> a -> Bool
/= Domain
def -> Text -> Text -> ValidationResult -> ValidationResult
topMessage Text
"domain" (RawSQL () -> Text
unRawSQL (RawSQL () -> Text) -> RawSQL () -> Text
forall a b. (a -> b) -> a -> b
$ Domain -> RawSQL ()
domName Domain
dom) (ValidationResult -> ValidationResult)
-> ValidationResult -> ValidationResult
forall a b. (a -> b) -> a -> b
$ [ValidationResult] -> ValidationResult
forall a. Monoid a => [a] -> a
mconcat [
Domain
-> Domain -> Text -> (Domain -> RawSQL ()) -> ValidationResult
forall a.
(Eq a, Show a) =>
Domain -> Domain -> Text -> (Domain -> a) -> ValidationResult
compareAttr Domain
dom Domain
def Text
"name" Domain -> RawSQL ()
domName
, Domain
-> Domain -> Text -> (Domain -> ColumnType) -> ValidationResult
forall a.
(Eq a, Show a) =>
Domain -> Domain -> Text -> (Domain -> a) -> ValidationResult
compareAttr Domain
dom Domain
def Text
"type" Domain -> ColumnType
domType
, Domain -> Domain -> Text -> (Domain -> Bool) -> ValidationResult
forall a.
(Eq a, Show a) =>
Domain -> Domain -> Text -> (Domain -> a) -> ValidationResult
compareAttr Domain
dom Domain
def Text
"nullable" Domain -> Bool
domNullable
, Domain
-> Domain
-> Text
-> (Domain -> Maybe (RawSQL ()))
-> ValidationResult
forall a.
(Eq a, Show a) =>
Domain -> Domain -> Text -> (Domain -> a) -> ValidationResult
compareAttr Domain
dom Domain
def Text
"default" Domain -> Maybe (RawSQL ())
domDefault
, Domain
-> Domain -> Text -> (Domain -> Set Check) -> ValidationResult
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 -> ValidationResult
forall a. Monoid a => a
mempty
Maybe Domain
Nothing -> Text -> ValidationResult
validationError (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$ Text
"Domain '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RawSQL () -> Text
unRawSQL (Domain -> RawSQL ()
domName Domain
def)
Text -> Text -> Text
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 :: Domain -> Domain -> Text -> (Domain -> a) -> ValidationResult
compareAttr Domain
dom Domain
def Text
attrname Domain -> a
attr
| Domain -> a
attr Domain
dom a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== Domain -> a
attr Domain
def = ValidationResult
forall a. Monoid a => a
mempty
| Bool
otherwise = Text -> ValidationResult
validationError (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$
Text
"Attribute '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
attrname
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' does not match (database:" Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> String -> Text
T.pack (a -> String
forall a. Show a => a -> String
show (a -> String) -> a -> String
forall a b. (a -> b) -> a -> b
$ Domain -> a
attr Domain
dom)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", definition:" Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> String -> Text
T.pack (a -> String
forall a. Show a => a -> String
show (a -> String) -> a -> String
forall a b. (a -> b) -> a -> b
$ Domain -> a
attr Domain
def) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
checkTablesWereDropped :: (MonadDB m, MonadThrow m) =>
[Migration m] -> m ValidationResult
checkTablesWereDropped :: [Migration m] -> m ValidationResult
checkTablesWereDropped [Migration m]
mgrs = do
let droppedTableNames :: [RawSQL ()]
droppedTableNames = [ Migration m -> RawSQL ()
forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName Migration m
mgr
| Migration m
mgr <- [Migration m]
mgrs, Migration m -> Bool
forall (m :: * -> *). Migration m -> Bool
isDropTableMigration Migration m
mgr ]
([ValidationResult] -> ValidationResult)
-> m [ValidationResult] -> m ValidationResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [ValidationResult] -> ValidationResult
forall a. Monoid a => [a] -> a
mconcat (m [ValidationResult] -> m ValidationResult)
-> ((RawSQL () -> m ValidationResult) -> m [ValidationResult])
-> (RawSQL () -> m ValidationResult)
-> m ValidationResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [RawSQL ()]
-> (RawSQL () -> m ValidationResult) -> m [ValidationResult]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [RawSQL ()]
droppedTableNames ((RawSQL () -> m ValidationResult) -> m ValidationResult)
-> (RawSQL () -> m ValidationResult) -> m ValidationResult
forall a b. (a -> b) -> a -> b
$
\RawSQL ()
tblName -> do
Maybe Int32
mver <- String -> m (Maybe Int32)
forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
String -> m (Maybe Int32)
checkTableVersion (Text -> String
T.unpack (Text -> String) -> (RawSQL () -> Text) -> RawSQL () -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSQL () -> Text
unRawSQL (RawSQL () -> String) -> RawSQL () -> String
forall a b. (a -> b) -> a -> b
$ RawSQL ()
tblName)
ValidationResult -> m ValidationResult
forall (m :: * -> *) a. Monad m => a -> m a
return (ValidationResult -> m ValidationResult)
-> ValidationResult -> m ValidationResult
forall a b. (a -> b) -> a -> b
$ if Maybe Int32 -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Int32
mver
then ValidationResult
forall a. Monoid a => a
mempty
else Text -> ValidationResult
validationError (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$ Text
"The table '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RawSQL () -> Text
unRawSQL RawSQL ()
tblName
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' that must have been dropped"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is still present in the database."
data CompositesCreationMode
= CreateCompositesIfDatabaseEmpty
| DontCreateComposites
deriving CompositesCreationMode -> CompositesCreationMode -> Bool
(CompositesCreationMode -> CompositesCreationMode -> Bool)
-> (CompositesCreationMode -> CompositesCreationMode -> Bool)
-> Eq CompositesCreationMode
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 :: TablesWithVersions
-> CompositesCreationMode
-> ObjectsValidationMode
-> [CompositeType]
-> m ValidationResult
checkCompositesStructure TablesWithVersions
tablesWithVersions CompositesCreationMode
ccm ObjectsValidationMode
ovm [CompositeType]
compositeList = m [CompositeType]
forall (m :: * -> *). MonadDB m => m [CompositeType]
getDBCompositeTypes m [CompositeType]
-> ([CompositeType] -> m ValidationResult) -> m ValidationResult
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
[] | TablesWithVersions -> Bool
noTablesPresent TablesWithVersions
tablesWithVersions Bool -> Bool -> Bool
&& CompositesCreationMode
ccm CompositesCreationMode -> CompositesCreationMode -> Bool
forall a. Eq a => a -> a -> Bool
== CompositesCreationMode
CreateCompositesIfDatabaseEmpty -> do
(CompositeType -> m ()) -> [CompositeType] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (RawSQL () -> m ()
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ (RawSQL () -> m ())
-> (CompositeType -> RawSQL ()) -> CompositeType -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompositeType -> RawSQL ()
sqlCreateComposite) [CompositeType]
compositeList
ValidationResult -> m ValidationResult
forall (m :: * -> *) a. Monad m => a -> m a
return ValidationResult
forall a. Monoid a => a
mempty
[CompositeType]
dbCompositeTypes -> ValidationResult -> m ValidationResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ValidationResult -> m ValidationResult)
-> ValidationResult -> m ValidationResult
forall a b. (a -> b) -> a -> b
$ [ValidationResult] -> ValidationResult
forall a. Monoid a => [a] -> a
mconcat
[ ValidationResult
checkNotPresentComposites
, ValidationResult
checkDatabaseComposites
]
where
compositeMap :: Map Text [CompositeColumn]
compositeMap = [(Text, [CompositeColumn])] -> Map Text [CompositeColumn]
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Text, [CompositeColumn])] -> Map Text [CompositeColumn])
-> [(Text, [CompositeColumn])] -> Map Text [CompositeColumn]
forall a b. (a -> b) -> a -> b
$
(CompositeType -> (Text, [CompositeColumn]))
-> [CompositeType] -> [(Text, [CompositeColumn])]
forall a b. (a -> b) -> [a] -> [b]
map ((RawSQL () -> Text
unRawSQL (RawSQL () -> Text)
-> (CompositeType -> RawSQL ()) -> CompositeType -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompositeType -> RawSQL ()
ctName) (CompositeType -> Text)
-> (CompositeType -> [CompositeColumn])
-> CompositeType
-> (Text, [CompositeColumn])
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 = Set Text -> [Text]
forall a. Set a -> [a]
S.toList (Set Text -> [Text]) -> Set Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Map Text [CompositeColumn] -> Set Text
forall k a. Map k a -> Set k
M.keysSet Map Text [CompositeColumn]
compositeMap
Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
S.\\ [Text] -> Set Text
forall a. Ord a => [a] -> Set a
S.fromList ((CompositeType -> Text) -> [CompositeType] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (RawSQL () -> Text
unRawSQL (RawSQL () -> Text)
-> (CompositeType -> RawSQL ()) -> CompositeType -> Text
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 = [ValidationResult] -> ValidationResult
forall a. Monoid a => [a] -> a
mconcat ([ValidationResult] -> ValidationResult)
-> ((CompositeType -> ValidationResult) -> [ValidationResult])
-> (CompositeType -> ValidationResult)
-> ValidationResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((CompositeType -> ValidationResult)
-> [CompositeType] -> [ValidationResult]
forall a b. (a -> b) -> [a] -> [b]
`map` [CompositeType]
dbCompositeTypes) ((CompositeType -> ValidationResult) -> ValidationResult)
-> (CompositeType -> ValidationResult) -> ValidationResult
forall a b. (a -> b) -> a -> b
$ \CompositeType
dbComposite ->
let cname :: Text
cname = RawSQL () -> Text
unRawSQL (RawSQL () -> Text) -> RawSQL () -> Text
forall a b. (a -> b) -> a -> b
$ CompositeType -> RawSQL ()
ctName CompositeType
dbComposite
in case Text
cname Text -> Map Text [CompositeColumn] -> Maybe [CompositeColumn]
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 (ValidationResult -> ValidationResult)
-> ValidationResult -> ValidationResult
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 -> ValidationResult
forall a. Monoid a => a
mempty
ObjectsValidationMode
DontAllowUnknownObjects -> Text -> ValidationResult
validationError (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
[ Text
"Composite type '"
, String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ CompositeType -> String
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
_ [] [] = ValidationResult
forall a. Monoid a => a
mempty
checkColumns Int
_ [CompositeColumn]
rest [] = Text -> ValidationResult
validationError (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$
Text -> Text -> [CompositeColumn] -> Text
forall t. Show t => Text -> Text -> t -> Text
objectHasLess Text
"Composite type" Text
"columns" [CompositeColumn]
rest
checkColumns Int
_ [] [CompositeColumn]
rest = Text -> ValidationResult
validationError (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$
Text -> Text -> [CompositeColumn] -> Text
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) = [ValidationResult] -> ValidationResult
forall a. Monoid a => [a] -> a
mconcat [
Bool -> ValidationResult
validateNames (Bool -> ValidationResult) -> Bool -> ValidationResult
forall a b. (a -> b) -> a -> b
$ CompositeColumn -> RawSQL ()
ccName CompositeColumn
d RawSQL () -> RawSQL () -> Bool
forall a. Eq a => a -> a -> Bool
== CompositeColumn -> RawSQL ()
ccName CompositeColumn
c
, Bool -> ValidationResult
validateTypes (Bool -> ValidationResult) -> Bool -> ValidationResult
forall a b. (a -> b) -> a -> b
$ CompositeColumn -> ColumnType
ccType CompositeColumn
d ColumnType -> ColumnType -> Bool
forall a. Eq a => a -> a -> Bool
== CompositeColumn -> ColumnType
ccType CompositeColumn
c
, Int -> [CompositeColumn] -> [CompositeColumn] -> ValidationResult
checkColumns (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [CompositeColumn]
defs [CompositeColumn]
cols
]
where
validateNames :: Bool -> ValidationResult
validateNames Bool
True = ValidationResult
forall a. Monoid a => a
mempty
validateNames Bool
False = Text -> ValidationResult
validationError (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$
Text -> Text -> (CompositeColumn -> Text) -> Text
errorMsg (Text
"no. " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. TextShow a => a -> Text
showt Int
n) Text
"names" (RawSQL () -> Text
unRawSQL (RawSQL () -> Text)
-> (CompositeColumn -> RawSQL ()) -> CompositeColumn -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompositeColumn -> RawSQL ()
ccName)
validateTypes :: Bool -> ValidationResult
validateTypes Bool
True = ValidationResult
forall a. Monoid a => a
mempty
validateTypes Bool
False = Text -> ValidationResult
validationError (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$
Text -> Text -> (CompositeColumn -> Text) -> Text
errorMsg (RawSQL () -> Text
unRawSQL (RawSQL () -> Text) -> RawSQL () -> Text
forall a b. (a -> b) -> a -> b
$ CompositeColumn -> RawSQL ()
ccName CompositeColumn
d) Text
"types" (String -> Text
T.pack (String -> Text)
-> (CompositeColumn -> String) -> CompositeColumn -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ColumnType -> String
forall a. Show a => a -> String
show (ColumnType -> String)
-> (CompositeColumn -> ColumnType) -> CompositeColumn -> String
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 '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ident Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' differs in"
Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> Text
attr Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> Text
"(database:" Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> CompositeColumn -> Text
f CompositeColumn
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", definition:" Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> CompositeColumn -> Text
f CompositeColumn
d Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")."
checkDBStructure
:: forall m. (MonadDB m, MonadThrow m)
=> ExtrasOptions
-> TablesWithVersions
-> m ValidationResult
checkDBStructure :: ExtrasOptions -> TablesWithVersions -> m ValidationResult
checkDBStructure ExtrasOptions
options TablesWithVersions
tables = ([ValidationResult] -> ValidationResult)
-> m [ValidationResult] -> m ValidationResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [ValidationResult] -> ValidationResult
forall a. Monoid a => [a] -> a
mconcat (m [ValidationResult] -> m ValidationResult)
-> (((Table, Int32) -> m ValidationResult) -> m [ValidationResult])
-> ((Table, Int32) -> m ValidationResult)
-> m ValidationResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
TablesWithVersions
-> ((Table, Int32) -> m ValidationResult) -> m [ValidationResult]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM TablesWithVersions
tables (((Table, Int32) -> m ValidationResult) -> m ValidationResult)
-> ((Table, Int32) -> m ValidationResult) -> m ValidationResult
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) (ValidationResult -> ValidationResult)
-> m ValidationResult -> m ValidationResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Table -> m ValidationResult
checkTableStructure Table
table
ValidationResult -> m ValidationResult
forall (m :: * -> *) a. Monad m => a -> m a
return (ValidationResult -> m ValidationResult)
-> ValidationResult -> m ValidationResult
forall a b. (a -> b) -> a -> b
$ if Int32
version Int32 -> [Int32] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Table -> [Int32]
tblAcceptedDbVersions Table
table
then ValidationResult -> ValidationResult
validationErrorsToInfos ValidationResult
result
else ValidationResult
result
where
checkTableStructure :: Table -> m ValidationResult
checkTableStructure :: Table -> m ValidationResult
checkTableStructure table :: Table
table@Table{Int32
[Int32]
[Check]
[ForeignKey]
[TableIndex]
[TableColumn]
Maybe PrimaryKey
Maybe TableInitialSetup
RawSQL ()
tblInitialSetup :: Maybe TableInitialSetup
tblIndexes :: [TableIndex]
tblForeignKeys :: [ForeignKey]
tblChecks :: [Check]
tblPrimaryKey :: Maybe PrimaryKey
tblColumns :: [TableColumn]
tblAcceptedDbVersions :: [Int32]
tblVersion :: Int32
tblName :: RawSQL ()
tblInitialSetup :: Table -> Maybe TableInitialSetup
tblIndexes :: Table -> [TableIndex]
tblForeignKeys :: Table -> [ForeignKey]
tblChecks :: Table -> [Check]
tblPrimaryKey :: Table -> Maybe PrimaryKey
tblColumns :: Table -> [TableColumn]
tblAcceptedDbVersions :: Table -> [Int32]
tblVersion :: Table -> Int32
tblName :: Table -> RawSQL ()
..} = do
SqlSelect -> m ()
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ (SqlSelect -> m ()) -> SqlSelect -> m ()
forall a b. (a -> b) -> a -> b
$ SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_attribute a" (State SqlSelect () -> SqlSelect)
-> State SqlSelect () -> SqlSelect
forall a b. (a -> b) -> a -> b
$ do
SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"a.attname::text"
SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"pg_catalog.format_type(a.atttypid, a.atttypmod)"
SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"NOT a.attnotnull"
SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult (SQL -> State SqlSelect ())
-> (SqlSelect -> SQL) -> SqlSelect -> State SqlSelect ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> SQL
parenthesize (SQL -> SQL) -> (SqlSelect -> SQL) -> SqlSelect -> SQL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SqlSelect -> SQL
forall a. Sqlable a => a -> SQL
toSQLCommand (SqlSelect -> State SqlSelect ())
-> SqlSelect -> State SqlSelect ()
forall a b. (a -> b) -> a -> b
$
SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_attrdef d" (State SqlSelect () -> SqlSelect)
-> State SqlSelect () -> SqlSelect
forall a b. (a -> b) -> a -> b
$ do
SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"pg_catalog.pg_get_expr(d.adbin, d.adrelid)"
SQL -> State SqlSelect ()
forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere SQL
"d.adrelid = a.attrelid"
SQL -> State SqlSelect ()
forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere SQL
"d.adnum = a.attnum"
SQL -> State SqlSelect ()
forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere SQL
"a.atthasdef"
SQL -> State SqlSelect ()
forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere SQL
"a.attnum > 0"
SQL -> State SqlSelect ()
forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere SQL
"NOT a.attisdropped"
SQL -> SQL -> State SqlSelect ()
forall v (m :: * -> *) sql.
(MonadState v m, SqlWhere v, Sqlable sql) =>
SQL -> sql -> m ()
sqlWhereEqSql SQL
"a.attrelid" (SQL -> State SqlSelect ()) -> SQL -> State SqlSelect ()
forall a b. (a -> b) -> a -> b
$ Table -> SQL
sqlGetTableID Table
table
SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlOrderBy v) =>
SQL -> m ()
sqlOrderBy SQL
"a.attnum"
[TableColumn]
desc <- ((String, ColumnType, Bool, Maybe String) -> TableColumn)
-> m [TableColumn]
forall (m :: * -> *) row t.
(MonadDB m, FromRow row) =>
(row -> t) -> m [t]
fetchMany (String, ColumnType, Bool, Maybe String) -> TableColumn
fetchTableColumn
Maybe (PrimaryKey, RawSQL ())
pk <- Table -> m (Maybe (PrimaryKey, RawSQL ()))
forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
Table -> m (Maybe (PrimaryKey, RawSQL ()))
sqlGetPrimaryKey Table
table
SQL -> m ()
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ (SQL -> m ()) -> SQL -> m ()
forall a b. (a -> b) -> a -> b
$ Table -> SQL
sqlGetChecks Table
table
[Check]
checks <- ((String, String, Bool) -> Check) -> m [Check]
forall (m :: * -> *) row t.
(MonadDB m, FromRow row) =>
(row -> t) -> m [t]
fetchMany (String, String, Bool) -> Check
fetchTableCheck
SQL -> m ()
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ (SQL -> m ()) -> SQL -> m ()
forall a b. (a -> b) -> a -> b
$ Table -> SQL
sqlGetIndexes Table
table
[(TableIndex, RawSQL ())]
indexes <- ((String, Array1 String, String, Bool, Bool, Maybe String)
-> (TableIndex, RawSQL ()))
-> m [(TableIndex, RawSQL ())]
forall (m :: * -> *) row t.
(MonadDB m, FromRow row) =>
(row -> t) -> m [t]
fetchMany (String, Array1 String, String, Bool, Bool, Maybe String)
-> (TableIndex, RawSQL ())
fetchTableIndex
SQL -> m ()
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ (SQL -> m ()) -> SQL -> m ()
forall a b. (a -> b) -> a -> b
$ Table -> SQL
sqlGetForeignKeys Table
table
[(ForeignKey, RawSQL ())]
fkeys <- ((String, Array1 String, String, Array1 String, Char, Char, Bool,
Bool, Bool)
-> (ForeignKey, RawSQL ()))
-> m [(ForeignKey, RawSQL ())]
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
ValidationResult -> m ValidationResult
forall (m :: * -> *) a. Monad m => a -> m a
return (ValidationResult -> m ValidationResult)
-> ValidationResult -> m ValidationResult
forall a b. (a -> b) -> a -> b
$ [ValidationResult] -> ValidationResult
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
]
where
fetchTableColumn
:: (String, ColumnType, Bool, Maybe String) -> TableColumn
fetchTableColumn :: (String, ColumnType, Bool, Maybe String) -> TableColumn
fetchTableColumn (String
name, ColumnType
ctype, Bool
nullable, Maybe String
mdefault) = TableColumn :: RawSQL () -> ColumnType -> Bool -> Maybe (RawSQL ()) -> TableColumn
TableColumn {
colName :: RawSQL ()
colName = String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL String
name
, colType :: ColumnType
colType = ColumnType
ctype
, colNullable :: Bool
colNullable = Bool
nullable
, colDefault :: Maybe (RawSQL ())
colDefault = String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL (String -> RawSQL ()) -> Maybe String -> Maybe (RawSQL ())
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
_ [] [] = ValidationResult
forall a. Monoid a => a
mempty
checkColumns Int
_ [TableColumn]
rest [] = Text -> ValidationResult
validationError (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$
Text -> Text -> [TableColumn] -> Text
forall t. Show t => Text -> Text -> t -> Text
objectHasLess Text
"Table" Text
"columns" [TableColumn]
rest
checkColumns Int
_ [] [TableColumn]
rest = Text -> ValidationResult
validationError (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$
Text -> Text -> [TableColumn] -> Text
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) = [ValidationResult] -> ValidationResult
forall a. Monoid a => [a] -> a
mconcat [
Bool -> ValidationResult
validateNames (Bool -> ValidationResult) -> Bool -> ValidationResult
forall a b. (a -> b) -> a -> b
$ TableColumn -> RawSQL ()
colName TableColumn
d RawSQL () -> RawSQL () -> Bool
forall a. Eq a => a -> a -> Bool
== TableColumn -> RawSQL ()
colName TableColumn
c
, Bool -> ValidationResult
validateTypes (Bool -> ValidationResult) -> Bool -> ValidationResult
forall a b. (a -> b) -> a -> b
$ TableColumn -> ColumnType
colType TableColumn
d ColumnType -> ColumnType -> Bool
forall a. Eq a => a -> a -> Bool
== TableColumn -> ColumnType
colType TableColumn
c Bool -> Bool -> Bool
||
(TableColumn -> ColumnType
colType TableColumn
d ColumnType -> ColumnType -> Bool
forall a. Eq a => a -> a -> Bool
== ColumnType
BigSerialT Bool -> Bool -> Bool
&& TableColumn -> ColumnType
colType TableColumn
c ColumnType -> ColumnType -> Bool
forall a. Eq a => a -> a -> Bool
== ColumnType
BigIntT)
, Bool -> ValidationResult
validateDefaults (Bool -> ValidationResult) -> Bool -> ValidationResult
forall a b. (a -> b) -> a -> b
$ TableColumn -> Maybe (RawSQL ())
colDefault TableColumn
d Maybe (RawSQL ()) -> Maybe (RawSQL ()) -> Bool
forall a. Eq a => a -> a -> Bool
== TableColumn -> Maybe (RawSQL ())
colDefault TableColumn
c Bool -> Bool -> Bool
||
(TableColumn -> Maybe (RawSQL ())
colDefault TableColumn
d Maybe (RawSQL ()) -> Maybe (RawSQL ()) -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe (RawSQL ())
forall a. Maybe a
Nothing
Bool -> Bool -> Bool
&& ((Text -> Text -> Bool
T.isPrefixOf Text
"nextval('" (Text -> Bool) -> (RawSQL () -> Text) -> RawSQL () -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSQL () -> Text
unRawSQL) (RawSQL () -> Bool) -> Maybe (RawSQL ()) -> Maybe Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` TableColumn -> Maybe (RawSQL ())
colDefault TableColumn
c)
Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True)
, Bool -> ValidationResult
validateNullables (Bool -> ValidationResult) -> Bool -> ValidationResult
forall a b. (a -> b) -> a -> b
$ TableColumn -> Bool
colNullable TableColumn
d Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== TableColumn -> Bool
colNullable TableColumn
c
, Int -> [TableColumn] -> [TableColumn] -> ValidationResult
checkColumns (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [TableColumn]
defs [TableColumn]
cols
]
where
validateNames :: Bool -> ValidationResult
validateNames Bool
True = ValidationResult
forall a. Monoid a => a
mempty
validateNames Bool
False = Text -> ValidationResult
validationError (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$
Text -> Text -> (TableColumn -> Text) -> Text
errorMsg (Text
"no. " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. TextShow a => a -> Text
showt Int
n) Text
"names" (RawSQL () -> Text
unRawSQL (RawSQL () -> Text)
-> (TableColumn -> RawSQL ()) -> TableColumn -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableColumn -> RawSQL ()
colName)
validateTypes :: Bool -> ValidationResult
validateTypes Bool
True = ValidationResult
forall a. Monoid a => a
mempty
validateTypes Bool
False = Text -> ValidationResult
validationError (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$
Text -> Text -> (TableColumn -> Text) -> Text
errorMsg Text
cname Text
"types" (String -> Text
T.pack (String -> Text) -> (TableColumn -> String) -> TableColumn -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ColumnType -> String
forall a. Show a => a -> String
show (ColumnType -> String)
-> (TableColumn -> ColumnType) -> TableColumn -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableColumn -> ColumnType
colType)
Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL () -> Text
sqlHint (RawSQL ()
"TYPE" RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> ColumnType -> RawSQL ()
columnTypeToSQL (TableColumn -> ColumnType
colType TableColumn
d))
validateNullables :: Bool -> ValidationResult
validateNullables Bool
True = ValidationResult
forall a. Monoid a => a
mempty
validateNullables Bool
False = Text -> ValidationResult
validationError (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$
Text -> Text -> (TableColumn -> Text) -> Text
errorMsg Text
cname Text
"nullables" (Bool -> Text
forall a. TextShow a => a -> Text
showt (Bool -> Text) -> (TableColumn -> Bool) -> TableColumn -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableColumn -> Bool
colNullable)
Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL () -> Text
sqlHint ((if TableColumn -> Bool
colNullable TableColumn
d then RawSQL ()
"DROP" else RawSQL ()
"SET")
RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
"NOT NULL")
validateDefaults :: Bool -> ValidationResult
validateDefaults Bool
True = ValidationResult
forall a. Monoid a => a
mempty
validateDefaults Bool
False = Text -> ValidationResult
validationError (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$
(Text -> Text -> (TableColumn -> Text) -> Text
errorMsg Text
cname Text
"defaults" (Maybe Text -> Text
forall a. TextShow a => a -> Text
showt (Maybe Text -> Text)
-> (TableColumn -> Maybe Text) -> TableColumn -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RawSQL () -> Text) -> Maybe (RawSQL ()) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RawSQL () -> Text
unRawSQL (Maybe (RawSQL ()) -> Maybe Text)
-> (TableColumn -> Maybe (RawSQL ())) -> TableColumn -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableColumn -> Maybe (RawSQL ())
colDefault))
Text -> Text -> Text
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" RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
v
Maybe (RawSQL ())
Nothing -> RawSQL ()
"DROP DEFAULT"
cname :: Text
cname = RawSQL () -> Text
unRawSQL (RawSQL () -> Text) -> RawSQL () -> Text
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 '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ident Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' differs in"
Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> Text
attr Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> Text
"(table:" Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> TableColumn -> Text
f TableColumn
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", definition:" Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> TableColumn -> Text
f TableColumn
d Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")."
sqlHint :: RawSQL () -> Text
sqlHint RawSQL ()
sql =
Text
"(HINT: SQL for making the change is: ALTER TABLE"
Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> Table -> Text
tblNameText Table
table Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> Text
"ALTER COLUMN" Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL () -> Text
unRawSQL (TableColumn -> RawSQL ()
colName TableColumn
d)
Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL () -> Text
unRawSQL RawSQL ()
sql Text -> Text -> Text
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 = [ValidationResult] -> ValidationResult
forall a. Monoid a => [a] -> a
mconcat [
Text -> [PrimaryKey] -> [PrimaryKey] -> ValidationResult
forall t. (Eq t, Show t) => Text -> [t] -> [t] -> ValidationResult
checkEquality Text
"PRIMARY KEY" [PrimaryKey]
def (((PrimaryKey, RawSQL ()) -> PrimaryKey)
-> [(PrimaryKey, RawSQL ())] -> [PrimaryKey]
forall a b. (a -> b) -> [a] -> [b]
map (PrimaryKey, RawSQL ()) -> PrimaryKey
forall a b. (a, b) -> a
fst [(PrimaryKey, RawSQL ())]
pk)
, (PrimaryKey -> RawSQL ())
-> [(PrimaryKey, RawSQL ())] -> ValidationResult
forall t.
Show t =>
(t -> RawSQL ()) -> [(t, RawSQL ())] -> ValidationResult
checkNames (RawSQL () -> PrimaryKey -> RawSQL ()
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 ValidationResult
forall a. Monoid a => a
mempty
]
where
def :: [PrimaryKey]
def = Maybe PrimaryKey -> [PrimaryKey]
forall a. Maybe a -> [a]
maybeToList Maybe PrimaryKey
mdef
pk :: [(PrimaryKey, RawSQL ())]
pk = Maybe (PrimaryKey, RawSQL ()) -> [(PrimaryKey, RawSQL ())]
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 [Text] -> [Text]
forall a. a -> a
id [Text] -> [Text]
forall a. IsString a => [a] -> [a]
mapErrs (Text -> [Check] -> [Check] -> ValidationResult
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 [a] -> [a] -> [a]
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 ())]
indexes = [ValidationResult] -> ValidationResult
forall a. Monoid a => [a] -> a
mconcat [
Text -> [TableIndex] -> [TableIndex] -> ValidationResult
forall t. (Eq t, Show t) => Text -> [t] -> [t] -> ValidationResult
checkEquality Text
"INDEXes" [TableIndex]
defs (((TableIndex, RawSQL ()) -> TableIndex)
-> [(TableIndex, RawSQL ())] -> [TableIndex]
forall a b. (a -> b) -> [a] -> [b]
map (TableIndex, RawSQL ()) -> TableIndex
forall a b. (a, b) -> a
fst [(TableIndex, RawSQL ())]
indexes)
, (TableIndex -> RawSQL ())
-> [(TableIndex, RawSQL ())] -> ValidationResult
forall t.
Show t =>
(t -> RawSQL ()) -> [(t, RawSQL ())] -> ValidationResult
checkNames (RawSQL () -> TableIndex -> RawSQL ()
indexName RawSQL ()
tblName) [(TableIndex, RawSQL ())]
indexes
]
checkForeignKeys :: [ForeignKey] -> [(ForeignKey, RawSQL ())]
-> ValidationResult
checkForeignKeys :: [ForeignKey] -> [(ForeignKey, RawSQL ())] -> ValidationResult
checkForeignKeys [ForeignKey]
defs [(ForeignKey, RawSQL ())]
fkeys = [ValidationResult] -> ValidationResult
forall a. Monoid a => [a] -> a
mconcat [
Text -> [ForeignKey] -> [ForeignKey] -> ValidationResult
forall t. (Eq t, Show t) => Text -> [t] -> [t] -> ValidationResult
checkEquality Text
"FOREIGN KEYs" [ForeignKey]
defs (((ForeignKey, RawSQL ()) -> ForeignKey)
-> [(ForeignKey, RawSQL ())] -> [ForeignKey]
forall a b. (a -> b) -> [a] -> [b]
map (ForeignKey, RawSQL ()) -> ForeignKey
forall a b. (a, b) -> a
fst [(ForeignKey, RawSQL ())]
fkeys)
, (ForeignKey -> RawSQL ())
-> [(ForeignKey, RawSQL ())] -> ValidationResult
forall t.
Show t =>
(t -> RawSQL ()) -> [(t, RawSQL ())] -> ValidationResult
checkNames (RawSQL () -> ForeignKey -> RawSQL ()
fkName RawSQL ()
tblName) [(ForeignKey, RawSQL ())]
fkeys
]
checkDBConsistency
:: forall m. (MonadDB m, MonadLog m, MonadMask m)
=> ExtrasOptions -> [Domain] -> TablesWithVersions -> [Migration m]
-> m ()
checkDBConsistency :: ExtrasOptions
-> [Domain] -> TablesWithVersions -> [Migration m] -> m ()
checkDBConsistency ExtrasOptions
options [Domain]
domains TablesWithVersions
tablesWithVersions [Migration m]
migrations = do
Bool
autoTransaction <- TransactionSettings -> Bool
tsAutoTransaction (TransactionSettings -> Bool) -> m TransactionSettings -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m TransactionSettings
forall (m :: * -> *). MonadDB m => m TransactionSettings
getTransactionSettings
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
autoTransaction (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
String -> m ()
forall a. HasCallStack => String -> a
error String
"checkDBConsistency: tsAutoTransaction setting needs to be True"
m ()
validateMigrations
m ()
validateDropTableMigrations
[(Text, Int32)]
dbTablesWithVersions <- m [(Text, Int32)]
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 = ((Table, Int32) -> Table) -> TablesWithVersions -> [Table]
forall a b. (a -> b) -> [a] -> [b]
map (Table, Int32) -> Table
forall a b. (a, b) -> a
fst TablesWithVersions
tablesWithVersions
errorInvalidMigrations :: HasCallStack => [RawSQL ()] -> a
errorInvalidMigrations :: [RawSQL ()] -> a
errorInvalidMigrations [RawSQL ()]
tblNames =
String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"checkDBConsistency: invalid migrations for tables"
String -> String -> String
forall m. (IsString m, Monoid m) => m -> m -> m
<+> (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
L.intercalate String
", " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (RawSQL () -> String) -> [RawSQL ()] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
T.unpack (Text -> String) -> (RawSQL () -> Text) -> RawSQL () -> String
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
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Int32]
presentMigrationVersions [Int32] -> [Int32] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Int32]
expectedMigrationVersions) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
Text -> Value -> m ()
forall (m :: * -> *) a. (MonadLog m, ToJSON a) => Text -> a -> m ()
logAttention Text
"Migrations are invalid" (Value -> m ()) -> Value -> m ()
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [
Text
"table" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Table -> Text
tblNameText Table
table
, Text
"migration_versions" Text -> [Int32] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [Int32]
presentMigrationVersions
, Text
"expected_migration_versions" Text -> [Int32] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [Int32]
expectedMigrationVersions
]
[RawSQL ()] -> m ()
forall a. HasCallStack => [RawSQL ()] -> a
errorInvalidMigrations [Table -> RawSQL ()
tblName (Table -> RawSQL ()) -> Table -> RawSQL ()
forall a b. (a -> b) -> a -> b
$ Table
table]
validateMigrations :: m ()
validateMigrations :: m ()
validateMigrations = [Table] -> (Table -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Table]
tables ((Table -> m ()) -> m ()) -> (Table -> m ()) -> m ()
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 RawSQL () -> RawSQL () -> Bool
forall a. Eq a => a -> a -> Bool
== Table -> RawSQL ()
tblName Table
table ]
expectedMigrationVersions :: [Int32]
expectedMigrationVersions
= [Int32] -> [Int32]
forall a. [a] -> [a]
reverse ([Int32] -> [Int32]) -> [Int32] -> [Int32]
forall a b. (a -> b) -> a -> b
$ Int -> [Int32] -> [Int32]
forall a. Int -> [a] -> [a]
take ([Int32] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int32]
presentMigrationVersions) ([Int32] -> [Int32]) -> [Int32] -> [Int32]
forall a b. (a -> b) -> a -> b
$
[Int32] -> [Int32]
forall a. [a] -> [a]
reverse [Int32
0 .. Table -> Int32
tblVersion Table
table Int32 -> Int32 -> Int32
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 =
[ Migration m -> RawSQL ()
forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName (Migration m -> RawSQL ()) -> Migration m -> RawSQL ()
forall a b. (a -> b) -> a -> b
$ Migration m
mgr | Migration m
mgr <- [Migration m]
migrations
, Migration m -> Bool
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 = [RawSQL ()] -> [RawSQL ()] -> [RawSQL ()]
forall a. Eq a => [a] -> [a] -> [a]
L.intersect [RawSQL ()]
droppedTableNames [RawSQL ()]
tableNames
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> ([RawSQL ()] -> Bool) -> [RawSQL ()] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [RawSQL ()] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([RawSQL ()] -> Bool) -> [RawSQL ()] -> Bool
forall a b. (a -> b) -> a -> b
$ [RawSQL ()]
intersection) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
Text -> Value -> m ()
forall (m :: * -> *) a. (MonadLog m, ToJSON a) => Text -> a -> m ()
logAttention (Text
"The intersection between tables "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"and dropped tables is not empty")
(Value -> m ()) -> Value -> m ()
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object
[ Text
"intersection" Text -> [Text] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (RawSQL () -> Text) -> [RawSQL ()] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map RawSQL () -> Text
unRawSQL [RawSQL ()]
intersection ]
[RawSQL ()] -> m ()
forall a. HasCallStack => [RawSQL ()] -> a
errorInvalidMigrations [ Table -> RawSQL ()
tblName Table
tbl
| Table
tbl <- [Table]
tables
, Table -> RawSQL ()
tblName Table
tbl RawSQL () -> [RawSQL ()] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [RawSQL ()]
intersection ]
let migrationsByTable :: [[Migration m]]
migrationsByTable = (Migration m -> Migration m -> Bool)
-> [Migration m] -> [[Migration m]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
L.groupBy (RawSQL () -> RawSQL () -> Bool
forall a. Eq a => a -> a -> Bool
(==) (RawSQL () -> RawSQL () -> Bool)
-> (Migration m -> RawSQL ()) -> Migration m -> Migration m -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Migration m -> RawSQL ()
forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName)
[Migration m]
migrations
dropMigrationLists :: [[Migration m]]
dropMigrationLists = [ [Migration m]
mgrs | [Migration m]
mgrs <- [[Migration m]]
migrationsByTable
, (Migration m -> Bool) -> [Migration m] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Migration m -> Bool
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 (Bool -> Bool) -> ([Migration m] -> Bool) -> [Migration m] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Migration m -> Bool
forall (m :: * -> *). Migration m -> Bool
isDropTableMigration (Migration m -> Bool)
-> ([Migration m] -> Migration m) -> [Migration m] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Migration m] -> Migration m
forall a. [a] -> a
last ([Migration m] -> Bool) -> [Migration m] -> Bool
forall a b. (a -> b) -> a -> b
$ [Migration m]
mgrs) Bool -> Bool -> Bool
||
([Migration m] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Migration m] -> Int)
-> ([Migration m] -> [Migration m]) -> [Migration m] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Migration m -> Bool) -> [Migration m] -> [Migration m]
forall a. (a -> Bool) -> [a] -> [a]
filter Migration m -> Bool
forall (m :: * -> *). Migration m -> Bool
isDropTableMigration ([Migration m] -> Int) -> [Migration m] -> Int
forall a b. (a -> b) -> a -> b
$ [Migration m]
mgrs) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 ]
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool)
-> ([[Migration m]] -> Bool) -> [[Migration m]] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Migration m]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([[Migration m]] -> Bool) -> [[Migration m]] -> Bool
forall a b. (a -> b) -> a -> b
$ [[Migration m]]
invalidMigrationLists) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
let tablesWithInvalidMigrationLists :: [RawSQL ()]
tablesWithInvalidMigrationLists =
[ Migration m -> RawSQL ()
forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName Migration m
mgr | [Migration m]
mgrs <- [[Migration m]]
invalidMigrationLists
, let mgr :: Migration m
mgr = [Migration m] -> Migration m
forall a. [a] -> a
head [Migration m]
mgrs ]
Text -> Value -> m ()
forall (m :: * -> *) a. (MonadLog m, ToJSON a) => Text -> a -> m ()
logAttention (Text
"Migration lists for some tables contain "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"either multiple drop table migrations or "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"a drop table migration in non-tail position.")
(Value -> m ()) -> Value -> m ()
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [ Text
"tables" Text -> [Text] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.=
[ RawSQL () -> Text
unRawSQL RawSQL ()
tblName
| RawSQL ()
tblName <- [RawSQL ()]
tablesWithInvalidMigrationLists ] ]
[RawSQL ()] -> m ()
forall a. HasCallStack => [RawSQL ()] -> a
errorInvalidMigrations [RawSQL ()]
tablesWithInvalidMigrationLists
createDBSchema :: m ()
createDBSchema :: m ()
createDBSchema = do
Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ Text
"Creating domains..."
(Domain -> m ()) -> [Domain] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Domain -> m ()
forall (m :: * -> *). MonadDB m => Domain -> m ()
createDomain [Domain]
domains
Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ Text
"Creating tables..."
(Table -> m ()) -> [Table] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Bool -> Table -> m ()
forall (m :: * -> *). MonadDB m => Bool -> Table -> m ()
createTable Bool
False) [Table]
tables
Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ Text
"Creating table constraints..."
(Table -> m ()) -> [Table] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Table -> m ()
forall (m :: * -> *). MonadDB m => Table -> m ()
createTableConstraints [Table]
tables
Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ Text
"Done."
initializeDB :: m ()
initializeDB :: m ()
initializeDB = do
Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ Text
"Running initial setup for tables..."
[Table] -> (Table -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Table]
tables ((Table -> m ()) -> m ()) -> (Table -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Table
t -> case Table -> Maybe TableInitialSetup
tblInitialSetup Table
t of
Maybe TableInitialSetup
Nothing -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just TableInitialSetup
tis -> do
Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Initializing" Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> Table -> Text
tblNameText Table
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"..."
TableInitialSetup
-> forall (m :: * -> *). (MonadDB m, MonadThrow m) => m ()
initialSetup TableInitialSetup
tis
Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ Text
"Done."
validateMigrationsAgainstDB :: [(RawSQL (), Int32, Int32)] -> m ()
validateMigrationsAgainstDB :: [(RawSQL (), Int32, Int32)] -> m ()
validateMigrationsAgainstDB [(RawSQL (), Int32, Int32)]
tablesWithVersions_
= [(RawSQL (), Int32, Int32)]
-> ((RawSQL (), Int32, Int32) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(RawSQL (), Int32, Int32)]
tablesWithVersions_ (((RawSQL (), Int32, Int32) -> m ()) -> m ())
-> ((RawSQL (), Int32, Int32) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(RawSQL ()
tableName, Int32
expectedVer, Int32
actualVer) ->
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int32
expectedVer Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Int32
actualVer) (m () -> m ()) -> m () -> m ()
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 RawSQL () -> RawSQL () -> Bool
forall a. Eq a => a -> a -> Bool
== RawSQL ()
tableName ] of
[] ->
String -> m ()
forall a. HasCallStack => String -> a
error (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"checkDBConsistency: no migrations found for table '"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Text -> String
T.unpack (Text -> String) -> (RawSQL () -> Text) -> RawSQL () -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSQL () -> Text
unRawSQL (RawSQL () -> String) -> RawSQL () -> String
forall a b. (a -> b) -> a -> b
$ RawSQL ()
tableName) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"', cannot migrate "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int32 -> String
forall a. Show a => a -> String
show Int32
actualVer String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int32 -> String
forall a. Show a => a -> String
show Int32
expectedVer
(Migration m
m:[Migration m]
_) | Migration m -> Int32
forall (m :: * -> *). Migration m -> Int32
mgrFrom Migration m
m Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
> Int32
actualVer ->
String -> m ()
forall a. HasCallStack => String -> a
error (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"checkDBConsistency: earliest migration for table '"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Text -> String
T.unpack (Text -> String) -> (RawSQL () -> Text) -> RawSQL () -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSQL () -> Text
unRawSQL (RawSQL () -> String) -> RawSQL () -> String
forall a b. (a -> b) -> a -> b
$ RawSQL ()
tableName) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' is from version "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int32 -> String
forall a. Show a => a -> String
show (Migration m -> Int32
forall (m :: * -> *). Migration m -> Int32
mgrFrom Migration m
m) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", cannot migrate "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int32 -> String
forall a. Show a => a -> String
show Int32
actualVer String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int32 -> String
forall a. Show a => a -> String
show Int32
expectedVer
| Bool
otherwise -> () -> m ()
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, Migration m -> Int32
forall (m :: * -> *). Migration m -> Int32
mgrFrom Migration m
mgr, Maybe Int32 -> Int32
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Int32
mver)
| Migration m
mgr <- [Migration m]
migrations
, Migration m -> Bool
forall (m :: * -> *). Migration m -> Bool
isDropTableMigration Migration m
mgr
, let tblName :: RawSQL ()
tblName = Migration m -> RawSQL ()
forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName Migration m
mgr
, let mver :: Maybe Int32
mver = Text -> [(Text, Int32)] -> Maybe Int32
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (RawSQL () -> Text
unRawSQL RawSQL ()
tblName) ([(Text, Int32)] -> Maybe Int32) -> [(Text, Int32)] -> Maybe Int32
forall a b. (a -> b) -> a -> b
$ [(Text, Int32)]
dbTablesWithVersions
, Maybe Int32 -> Bool
forall a. Maybe a -> Bool
isJust Maybe Int32
mver ]
[(RawSQL (), Int32, Int32)]
-> ((RawSQL (), Int32, Int32) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(RawSQL (), Int32, Int32)]
dbTablesToDropWithVersions (((RawSQL (), Int32, Int32) -> m ()) -> m ())
-> ((RawSQL (), Int32, Int32) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(RawSQL ()
tblName, Int32
fromVer, Int32
ver) ->
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int32
fromVer Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Int32
ver) (m () -> m ()) -> m () -> m ()
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 = [ Migration m -> RawSQL ()
forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName Migration m
mgr | Migration m
mgr <- [Migration m]
migrations
, Migration m -> Bool
forall (m :: * -> *). Migration m -> Bool
isDropTableMigration Migration m
mgr ]
droppedEventually :: Migration m -> Bool
droppedEventually :: Migration m -> Bool
droppedEventually Migration m
mgr = Migration m -> RawSQL ()
forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName Migration m
mgr RawSQL () -> [RawSQL ()] -> Bool
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 = Text -> [(Text, Int32)] -> Maybe Int32
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (RawSQL () -> Text
unRawSQL (RawSQL () -> Text) -> RawSQL () -> Text
forall a b. (a -> b) -> a -> b
$ Migration m -> RawSQL ()
forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName Migration m
mgr)
[(Text, Int32)]
dbTablesWithVersions
tableDoesNotExist :: Migration m -> Bool
tableDoesNotExist = Maybe Int32 -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Int32 -> Bool)
-> (Migration m -> Maybe Int32) -> Migration m -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Migration m -> Maybe Int32
lookupVer
migrationsToRun' :: [Migration m]
migrationsToRun' = (Migration m -> Bool) -> [Migration m] -> [Migration m]
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 (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
(Migration m -> Int32
forall (m :: * -> *). Migration m -> Int32
mgrFrom Migration m
mgr Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
== Int32
0) Bool -> Bool -> Bool
&&
(Bool -> Bool
not (Bool -> Bool) -> (Migration m -> Bool) -> Migration m -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Migration m -> Bool
droppedEventually (Migration m -> Bool) -> Migration m -> Bool
forall a b. (a -> b) -> a -> b
$ Migration m
mgr)
Just Int32
ver -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
Migration m -> Int32
forall (m :: * -> *). Migration m -> Int32
mgrFrom Migration m
mgr Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
>= Int32
ver)
[Migration m]
migrations
l :: Int
l = [Migration m] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Migration m]
migrationsToRun'
initialMigrations :: [Migration m]
initialMigrations = Int -> [Migration m] -> [Migration m]
forall a. Int -> [a] -> [a]
drop Int
l ([Migration m] -> [Migration m]) -> [Migration m] -> [Migration m]
forall a b. (a -> b) -> a -> b
$ [Migration m] -> [Migration m]
forall a. [a] -> [a]
reverse [Migration m]
migrations
additionalMigrations' :: [Migration m]
additionalMigrations' = (Migration m -> Bool) -> [Migration m] -> [Migration m]
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 = [Migration m] -> [Migration m]
forall a. [a] -> [a]
reverse [Migration m]
additionalMigrations'
grps :: [[Migration m]]
grps = (Migration m -> Migration m -> Bool)
-> [Migration m] -> [[Migration m]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
L.groupBy (RawSQL () -> RawSQL () -> Bool
forall a. Eq a => a -> a -> Bool
(==) (RawSQL () -> RawSQL () -> Bool)
-> (Migration m -> RawSQL ()) -> Migration m -> Migration m -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Migration m -> RawSQL ()
forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName) [Migration m]
ret
in if ([Migration m] -> Bool) -> [[Migration m]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
(/=) Int32
0 (Int32 -> Bool)
-> ([Migration m] -> Int32) -> [Migration m] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Migration m -> Int32
forall (m :: * -> *). Migration m -> Int32
mgrFrom (Migration m -> Int32)
-> ([Migration m] -> Migration m) -> [Migration m] -> Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Migration m] -> Migration m
forall a. [a] -> a
head) [[Migration m]]
grps
then []
else [Migration m]
ret
migrationsToRun :: [Migration m]
migrationsToRun = if Bool -> Bool
not (Bool -> Bool) -> ([Migration m] -> Bool) -> [Migration m] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Migration m] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Migration m] -> Bool) -> [Migration m] -> Bool
forall a b. (a -> b) -> a -> b
$ [Migration m]
migrationsToRun'
then [Migration m]
additionalMigrations [Migration m] -> [Migration m] -> [Migration m]
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
Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ RawSQL () -> Text
arrListTable RawSQL ()
mgrTableName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"drop table"
RawSQL () -> m ()
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ (RawSQL () -> m ()) -> RawSQL () -> m ()
forall a b. (a -> b) -> a -> b
$ RawSQL () -> DropTableMode -> RawSQL ()
sqlDropTable RawSQL ()
mgrTableName
DropTableMode
mgrDropTableMode
SqlDelete -> m ()
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ (SqlDelete -> m ()) -> SqlDelete -> m ()
forall a b. (a -> b) -> a -> b
$ SQL -> State SqlDelete () -> SqlDelete
sqlDelete SQL
"table_versions" (State SqlDelete () -> SqlDelete)
-> State SqlDelete () -> SqlDelete
forall a b. (a -> b) -> a -> b
$ do
SQL -> String -> State SqlDelete ()
forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"name" (Text -> String
T.unpack (Text -> String) -> (RawSQL () -> Text) -> RawSQL () -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSQL () -> Text
unRawSQL (RawSQL () -> String) -> RawSQL () -> String
forall a b. (a -> b) -> a -> b
$ RawSQL ()
mgrTableName)
CreateIndexConcurrentlyMigration RawSQL ()
tname TableIndex
idx -> do
m ()
logMigration
RawSQL () -> m ()
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ (RawSQL () -> m ()) -> RawSQL () -> m ()
forall a b. (a -> b) -> a -> b
$ RawSQL ()
"DROP INDEX IF EXISTS" RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL () -> TableIndex -> RawSQL ()
indexName RawSQL ()
tname TableIndex
idx
SQL -> m ()
forall (m :: * -> *). MonadDB m => SQL -> m ()
runSQL_ SQL
"COMMIT"
RawSQL () -> m ()
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ (RawSQL () -> TableIndex -> RawSQL ()
sqlCreateIndexConcurrently RawSQL ()
tname TableIndex
idx) m () -> m () -> m ()
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally` m ()
forall (m :: * -> *). MonadDB m => m ()
begin
m ()
updateTableVersion
where
logMigration :: m ()
logMigration = do
Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ RawSQL () -> Text
arrListTable RawSQL ()
mgrTableName
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int32 -> Text
forall a. TextShow a => a -> Text
showt Int32
mgrFrom Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> Text
"->" Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> Int32 -> Text
forall a. TextShow a => a -> Text
showt (Int32 -> Int32
forall a. Enum a => a -> a
succ Int32
mgrFrom)
updateTableVersion :: m ()
updateTableVersion = do
SqlUpdate -> m ()
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ (SqlUpdate -> m ()) -> SqlUpdate -> m ()
forall a b. (a -> b) -> a -> b
$ SQL -> State SqlUpdate () -> SqlUpdate
sqlUpdate SQL
"table_versions" (State SqlUpdate () -> SqlUpdate)
-> State SqlUpdate () -> SqlUpdate
forall a b. (a -> b) -> a -> b
$ do
SQL -> Int32 -> State SqlUpdate ()
forall v (m :: * -> *) a.
(MonadState v m, SqlSet v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlSet SQL
"version" (Int32 -> Int32
forall a. Enum a => a -> a
succ Int32
mgrFrom)
SQL -> String -> State SqlUpdate ()
forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"name" (Text -> String
T.unpack (Text -> String) -> (RawSQL () -> Text) -> RawSQL () -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSQL () -> Text
unRawSQL (RawSQL () -> String) -> RawSQL () -> String
forall a b. (a -> b) -> a -> b
$ RawSQL ()
mgrTableName)
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
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> ([Migration m] -> Bool) -> [Migration m] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Migration m] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Migration m] -> Bool) -> [Migration m] -> Bool
forall a b. (a -> b) -> a -> b
$ [Migration m]
migrationsToRun) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ Text
"Running migrations..."
[Migration m] -> (Migration m -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Migration m]
migrationsToRun ((Migration m -> m ()) -> m ()) -> (Migration m -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Migration m
mgr -> do
Migration m -> m ()
runMigration Migration m
mgr
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExtrasOptions -> Bool
eoForceCommit ExtrasOptions
options) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Committing migration changes..."
m ()
forall (m :: * -> *). MonadDB m => m ()
commit
Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Committing migration changes done."
Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ Text
"!IMPORTANT! Database has been permanently changed"
Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ Text
"Running migrations... done."
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 =
(Migration m -> Migration m -> Bool)
-> [Migration m] -> [[Migration m]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
L.groupBy (RawSQL () -> RawSQL () -> Bool
forall a. Eq a => a -> a -> Bool
(==) (RawSQL () -> RawSQL () -> Bool)
-> (Migration m -> RawSQL ()) -> Migration m -> Migration m -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Migration m -> RawSQL ()
forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName) ([Migration m] -> [[Migration m]])
-> ([Migration m] -> [Migration m])
-> [Migration m]
-> [[Migration m]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(Migration m -> Migration m -> Ordering)
-> [Migration m] -> [Migration m]
forall a. (a -> a -> Ordering) -> [a] -> [a]
L.sortBy ((Migration m -> RawSQL ())
-> Migration m -> Migration m -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Migration m -> RawSQL ()
forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName) ([Migration m] -> [[Migration m]])
-> [Migration m] -> [[Migration m]]
forall a b. (a -> b) -> a -> b
$
[Migration m]
migrationsToRun
loc_common :: String
loc_common = String
"Database.PostgreSQL.PQTypes.Checks."
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"checkDBConsistency.validateMigrationsToRun"
lookupDBTableVer :: [Migration m] -> Maybe Int32
lookupDBTableVer :: [Migration m] -> Maybe Int32
lookupDBTableVer [Migration m]
mgrGroup =
Text -> [(Text, Int32)] -> Maybe Int32
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (RawSQL () -> Text
unRawSQL (RawSQL () -> Text)
-> ([Migration m] -> RawSQL ()) -> [Migration m] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Migration m -> RawSQL ()
forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName (Migration m -> RawSQL ())
-> ([Migration m] -> Migration m) -> [Migration m] -> RawSQL ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Migration m] -> Migration m
forall a. String -> [a] -> a
headExc String
head_err
([Migration m] -> Text) -> [Migration m] -> Text
forall a b. (a -> b) -> a -> b
$ [Migration m]
mgrGroup) [(Text, Int32)]
dbTablesWithVersions
where
head_err :: String
head_err = String
loc_common String -> String -> String
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 = Int32 -> Maybe Int32 -> Int32
forall a. a -> Maybe a -> a
fromMaybe Int32
0 (Maybe Int32 -> Int32) -> Maybe Int32 -> Int32
forall a b. (a -> b) -> a -> b
$ [Migration m] -> Maybe Int32
lookupDBTableVer [Migration m]
mgrGroup
, Int32
dbTableVer Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
/= (Migration m -> Int32
forall (m :: * -> *). Migration m -> Int32
mgrFrom (Migration m -> Int32)
-> ([Migration m] -> Migration m) -> [Migration m] -> Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Migration m] -> Migration m
forall a. String -> [a] -> a
headExc String
head_err ([Migration m] -> Int32) -> [Migration m] -> Int32
forall a b. (a -> b) -> a -> b
$ [Migration m]
mgrGroup)
]
where
head_err :: String
head_err = String
loc_common
String -> String -> String
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
, Maybe Int32 -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Int32 -> Bool) -> Maybe Int32 -> Bool
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
, Migration m -> Bool
forall (m :: * -> *). Migration m -> Bool
isDropTableMigration (Migration m -> Bool)
-> ([Migration m] -> Migration m) -> [Migration m] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Migration m] -> Migration m
forall a. String -> [a] -> a
headExc String
head_err ([Migration m] -> Bool) -> [Migration m] -> Bool
forall a b. (a -> b) -> a -> b
$ [Migration m]
mgrGroup
]
where
head_err :: String
head_err = String
loc_common
String -> String -> String
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
, Migration m -> Int32
forall (m :: * -> *). Migration m -> Int32
mgrFrom (String -> [Migration m] -> Migration m
forall a. String -> [a] -> a
headExc String
head_err [Migration m]
mgrGroup) Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Int32
0
]
where
head_err :: String
head_err = String
loc_common
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".groupsNotStartingWithCreateTable: broken invariant"
tblNames :: [[Migration m]] -> [RawSQL ()]
tblNames :: [[Migration m]] -> [RawSQL ()]
tblNames [[Migration m]]
grps =
[ Migration m -> RawSQL ()
forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName (Migration m -> RawSQL ())
-> ([Migration m] -> Migration m) -> [Migration m] -> RawSQL ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Migration m] -> Migration m
forall a. String -> [a] -> a
headExc String
head_err ([Migration m] -> RawSQL ()) -> [Migration m] -> RawSQL ()
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 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".tblNames: broken invariant"
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool)
-> ([([Migration m], Int32)] -> Bool)
-> [([Migration m], Int32)]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [([Migration m], Int32)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([([Migration m], Int32)] -> Bool)
-> [([Migration m], Int32)] -> Bool
forall a b. (a -> b) -> a -> b
$ [([Migration m], Int32)]
groupsWithWrongDBTableVersions) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
let tnms :: [RawSQL ()]
tnms = [[Migration m]] -> [RawSQL ()]
tblNames ([[Migration m]] -> [RawSQL ()])
-> ([([Migration m], Int32)] -> [[Migration m]])
-> [([Migration m], Int32)]
-> [RawSQL ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Migration m], Int32) -> [Migration m])
-> [([Migration m], Int32)] -> [[Migration m]]
forall a b. (a -> b) -> [a] -> [b]
map ([Migration m], Int32) -> [Migration m]
forall a b. (a, b) -> a
fst ([([Migration m], Int32)] -> [RawSQL ()])
-> [([Migration m], Int32)] -> [RawSQL ()]
forall a b. (a -> b) -> a -> b
$ [([Migration m], Int32)]
groupsWithWrongDBTableVersions
Text -> Value -> m ()
forall (m :: * -> *) a. (MonadLog m, ToJSON a) => Text -> a -> m ()
logAttention
(Text
"There are migration chains selected for execution "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"that expect a different starting table version number "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"from the one in the database. "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"This likely means that the order of migrations is wrong.")
(Value -> m ()) -> Value -> m ()
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [ Text
"tables" Text -> [Text] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (RawSQL () -> Text) -> [RawSQL ()] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map RawSQL () -> Text
unRawSQL [RawSQL ()]
tnms ]
[RawSQL ()] -> m ()
forall a. HasCallStack => [RawSQL ()] -> a
errorInvalidMigrations [RawSQL ()]
tnms
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool)
-> ([[Migration m]] -> Bool) -> [[Migration m]] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Migration m]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([[Migration m]] -> Bool) -> [[Migration m]] -> Bool
forall a b. (a -> b) -> a -> b
$ [[Migration m]]
groupsStartingWithDropTable) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
let tnms :: [RawSQL ()]
tnms = [[Migration m]] -> [RawSQL ()]
tblNames [[Migration m]]
groupsStartingWithDropTable
Text -> Value -> m ()
forall (m :: * -> *) a. (MonadLog m, ToJSON a) => Text -> a -> m ()
logAttention Text
"There are drop table migrations for non-existing tables."
(Value -> m ()) -> Value -> m ()
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [ Text
"tables" Text -> [Text] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (RawSQL () -> Text) -> [RawSQL ()] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map RawSQL () -> Text
unRawSQL [RawSQL ()]
tnms ]
[RawSQL ()] -> m ()
forall a. HasCallStack => [RawSQL ()] -> a
errorInvalidMigrations [RawSQL ()]
tnms
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool)
-> ([[Migration m]] -> Bool) -> [[Migration m]] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Migration m]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([[Migration m]] -> Bool) -> [[Migration m]] -> Bool
forall a b. (a -> b) -> a -> b
$ [[Migration m]]
groupsNotStartingWithCreateTable) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
let tnms :: [RawSQL ()]
tnms = [[Migration m]] -> [RawSQL ()]
tblNames [[Migration m]]
groupsNotStartingWithCreateTable
Text -> Value -> m ()
forall (m :: * -> *) a. (MonadLog m, ToJSON a) => Text -> a -> m ()
logAttention
(Text
"Some tables haven't been created yet, but" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
Text
"their migration lists don't start with a create table migration.")
(Value -> m ()) -> Value -> m ()
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [ Text
"tables" Text -> [Text] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (RawSQL () -> Text) -> [RawSQL ()] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map RawSQL () -> Text
unRawSQL [RawSQL ()]
tnms ]
[RawSQL ()] -> m ()
forall a. HasCallStack => [RawSQL ()] -> a
errorInvalidMigrations [RawSQL ()]
tnms
type TablesWithVersions = [(Table, Int32)]
getTableVersions :: (MonadDB m, MonadThrow m) => [Table] -> m TablesWithVersions
getTableVersions :: [Table] -> m TablesWithVersions
getTableVersions [Table]
tbls =
[m (Table, Int32)] -> m TablesWithVersions
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
[ (\Maybe Int32
mver -> (Table
tbl, Int32 -> Maybe Int32 -> Int32
forall a. a -> Maybe a -> a
fromMaybe Int32
0 Maybe Int32
mver)) (Maybe Int32 -> (Table, Int32))
-> m (Maybe Int32) -> m (Table, Int32)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> m (Maybe Int32)
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 = ((Table, Int32) -> Bool) -> TablesWithVersions -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
(==) Int32
0 (Int32 -> Bool)
-> ((Table, Int32) -> Int32) -> (Table, Int32) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Table, Int32) -> Int32
forall a b. (a, b) -> b
snd)
getDBTableVersions :: (MonadDB m, MonadThrow m) => m [(Text, Int32)]
getDBTableVersions :: m [(Text, Int32)]
getDBTableVersions = do
[Text]
dbTableNames <- m [Text]
forall (m :: * -> *). MonadDB m => m [Text]
getDBTableNames
[m (Text, Int32)] -> m [(Text, Int32)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
[ (\Maybe Int32
mver -> (Text
name, Int32 -> Maybe Int32 -> Int32
forall a. a -> Maybe a -> a
fromMaybe Int32
0 Maybe Int32
mver)) (Maybe Int32 -> (Text, Int32))
-> m (Maybe Int32) -> m (Text, Int32)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> m (Maybe Int32)
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 :: String -> m (Maybe Int32)
checkTableVersion String
tblName = do
Bool
doesExist <- SqlSelect -> m Bool
forall sql (m :: * -> *).
(IsSQL sql, MonadDB m, MonadThrow m) =>
sql -> m Bool
runQuery01 (SqlSelect -> m Bool)
-> (State SqlSelect () -> SqlSelect)
-> State SqlSelect ()
-> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_class c" (State SqlSelect () -> m Bool) -> State SqlSelect () -> m Bool
forall a b. (a -> b) -> a -> b
$ do
SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"TRUE"
SQL -> SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlFrom v) =>
SQL -> SQL -> m ()
sqlLeftJoinOn SQL
"pg_catalog.pg_namespace n" SQL
"n.oid = c.relnamespace"
SQL -> String -> State SqlSelect ()
forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"c.relname" (String -> State SqlSelect ()) -> String -> State SqlSelect ()
forall a b. (a -> b) -> a -> b
$ String
tblName
SQL -> State SqlSelect ()
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
SQL -> m ()
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ (SQL -> m ()) -> SQL -> m ()
forall a b. (a -> b) -> a -> b
$ SQL
"SELECT version FROM table_versions WHERE name ="
SQL -> String -> SQL
forall t. (Show t, ToSQL t) => SQL -> t -> SQL
<?> String
tblName
Maybe Int32
mver <- (Identity Int32 -> Int32) -> m (Maybe Int32)
forall (m :: * -> *) row t.
(MonadDB m, MonadThrow m, FromRow row) =>
(row -> t) -> m (Maybe t)
fetchMaybe Identity Int32 -> Int32
forall a. Identity a -> a
runIdentity
case Maybe Int32
mver of
Just Int32
ver -> Maybe Int32 -> m (Maybe Int32)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Int32 -> m (Maybe Int32)) -> Maybe Int32 -> m (Maybe Int32)
forall a b. (a -> b) -> a -> b
$ Int32 -> Maybe Int32
forall a. a -> Maybe a
Just Int32
ver
Maybe Int32
Nothing -> String -> m (Maybe Int32)
forall a. HasCallStack => String -> a
error (String -> m (Maybe Int32)) -> String -> m (Maybe Int32)
forall a b. (a -> b) -> a -> b
$ String
"checkTableVersion: table '"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tblName
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' is present in the database, "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"but there is no corresponding version info in 'table_versions'."
else do
Maybe Int32 -> m (Maybe Int32)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int32
forall a. Maybe a
Nothing
sqlGetTableID :: Table -> SQL
sqlGetTableID :: Table -> SQL
sqlGetTableID Table
table = SQL -> SQL
parenthesize (SQL -> SQL) -> (SqlSelect -> SQL) -> SqlSelect -> SQL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SqlSelect -> SQL
forall a. Sqlable a => a -> SQL
toSQLCommand (SqlSelect -> SQL) -> SqlSelect -> SQL
forall a b. (a -> b) -> a -> b
$
SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_class c" (State SqlSelect () -> SqlSelect)
-> State SqlSelect () -> SqlSelect
forall a b. (a -> b) -> a -> b
$ do
SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"c.oid"
SQL -> SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlFrom v) =>
SQL -> SQL -> m ()
sqlLeftJoinOn SQL
"pg_catalog.pg_namespace n" SQL
"n.oid = c.relnamespace"
SQL -> String -> State SqlSelect ()
forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"c.relname" (String -> State SqlSelect ()) -> String -> State SqlSelect ()
forall a b. (a -> b) -> a -> b
$ Table -> String
tblNameString Table
table
SQL -> State SqlSelect ()
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 :: Table -> m (Maybe (PrimaryKey, RawSQL ()))
sqlGetPrimaryKey Table
table = do
(Maybe [Int16]
mColumnNumbers :: Maybe [Int16]) <- do
SqlSelect -> m ()
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ (SqlSelect -> m ())
-> (State SqlSelect () -> SqlSelect) -> State SqlSelect () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_constraint" (State SqlSelect () -> m ()) -> State SqlSelect () -> m ()
forall a b. (a -> b) -> a -> b
$ do
SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"conkey"
SQL -> SQL -> State SqlSelect ()
forall v (m :: * -> *) sql.
(MonadState v m, SqlWhere v, Sqlable sql) =>
SQL -> sql -> m ()
sqlWhereEqSql SQL
"conrelid" (Table -> SQL
sqlGetTableID Table
table)
SQL -> Char -> State SqlSelect ()
forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"contype" Char
'p'
(Identity (Array1 Int16) -> [Int16]) -> m (Maybe [Int16])
forall (m :: * -> *) row t.
(MonadDB m, MonadThrow m, FromRow row) =>
(row -> t) -> m (Maybe t)
fetchMaybe ((Identity (Array1 Int16) -> [Int16]) -> m (Maybe [Int16]))
-> (Identity (Array1 Int16) -> [Int16]) -> m (Maybe [Int16])
forall a b. (a -> b) -> a -> b
$ Array1 Int16 -> [Int16]
forall a. Array1 a -> [a]
unArray1 (Array1 Int16 -> [Int16])
-> (Identity (Array1 Int16) -> Array1 Int16)
-> Identity (Array1 Int16)
-> [Int16]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity (Array1 Int16) -> Array1 Int16
forall a. Identity a -> a
runIdentity
case Maybe [Int16]
mColumnNumbers of
Maybe [Int16]
Nothing -> do Maybe (PrimaryKey, RawSQL ()) -> m (Maybe (PrimaryKey, RawSQL ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (PrimaryKey, RawSQL ())
forall a. Maybe a
Nothing
Just [Int16]
columnNumbers -> do
[String]
columnNames <- do
[Int16] -> (Int16 -> m String) -> m [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int16]
columnNumbers ((Int16 -> m String) -> m [String])
-> (Int16 -> m String) -> m [String]
forall a b. (a -> b) -> a -> b
$ \Int16
k -> do
SqlSelect -> m ()
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ (SqlSelect -> m ())
-> (State SqlSelect () -> SqlSelect) -> State SqlSelect () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pk_columns" (State SqlSelect () -> m ()) -> State SqlSelect () -> m ()
forall a b. (a -> b) -> a -> b
$ do
SQL -> SqlSelect -> State SqlSelect ()
forall v (m :: * -> *) s.
(MonadState v m, SqlWith v, Sqlable s) =>
SQL -> s -> m ()
sqlWith SQL
"key_series" (SqlSelect -> State SqlSelect ())
-> (State SqlSelect () -> SqlSelect)
-> State SqlSelect ()
-> State SqlSelect ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_constraint as c2" (State SqlSelect () -> State SqlSelect ())
-> State SqlSelect () -> State SqlSelect ()
forall a b. (a -> b) -> a -> b
$ do
SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"unnest(c2.conkey) as k"
SQL -> SQL -> State SqlSelect ()
forall v (m :: * -> *) sql.
(MonadState v m, SqlWhere v, Sqlable sql) =>
SQL -> sql -> m ()
sqlWhereEqSql SQL
"c2.conrelid" (SQL -> State SqlSelect ()) -> SQL -> State SqlSelect ()
forall a b. (a -> b) -> a -> b
$ Table -> SQL
sqlGetTableID Table
table
SQL -> Char -> State SqlSelect ()
forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"c2.contype" Char
'p'
SQL -> SqlSelect -> State SqlSelect ()
forall v (m :: * -> *) s.
(MonadState v m, SqlWith v, Sqlable s) =>
SQL -> s -> m ()
sqlWith SQL
"pk_columns" (SqlSelect -> State SqlSelect ())
-> (State SqlSelect () -> SqlSelect)
-> State SqlSelect ()
-> State SqlSelect ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"key_series" (State SqlSelect () -> State SqlSelect ())
-> State SqlSelect () -> State SqlSelect ()
forall a b. (a -> b) -> a -> b
$ do
SQL -> SQL -> State SqlSelect ()
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"
SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"a.attname::text as column_name"
SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"key_series.k as column_order"
SQL -> SQL -> State SqlSelect ()
forall v (m :: * -> *) sql.
(MonadState v m, SqlWhere v, Sqlable sql) =>
SQL -> sql -> m ()
sqlWhereEqSql SQL
"a.attrelid" (SQL -> State SqlSelect ()) -> SQL -> State SqlSelect ()
forall a b. (a -> b) -> a -> b
$ Table -> SQL
sqlGetTableID Table
table
SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"pk_columns.column_name"
SQL -> Int16 -> State SqlSelect ()
forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"pk_columns.column_order" Int16
k
(Identity String -> String) -> m String
forall (m :: * -> *) row t.
(MonadDB m, MonadThrow m, FromRow row) =>
(row -> t) -> m t
fetchOne (\(Identity String
t) -> String
t :: String)
SqlSelect -> m ()
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ (SqlSelect -> m ())
-> (State SqlSelect () -> SqlSelect) -> State SqlSelect () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_constraint as c" (State SqlSelect () -> m ()) -> State SqlSelect () -> m ()
forall a b. (a -> b) -> a -> b
$ do
SQL -> Char -> State SqlSelect ()
forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"c.contype" Char
'p'
SQL -> SQL -> State SqlSelect ()
forall v (m :: * -> *) sql.
(MonadState v m, SqlWhere v, Sqlable sql) =>
SQL -> sql -> m ()
sqlWhereEqSql SQL
"c.conrelid" (SQL -> State SqlSelect ()) -> SQL -> State SqlSelect ()
forall a b. (a -> b) -> a -> b
$ Table -> SQL
sqlGetTableID Table
table
SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"c.conname::text"
SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult (SQL -> State SqlSelect ()) -> SQL -> State SqlSelect ()
forall a b. (a -> b) -> a -> b
$ String -> SQL
forall a. IsString a => String -> a
Data.String.fromString
(String
"array['" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (String -> [String] -> String
forall m. Monoid m => m -> [m] -> m
mintercalate String
"', '" [String]
columnNames) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"']::text[]")
Maybe (Maybe (PrimaryKey, RawSQL ()))
-> Maybe (PrimaryKey, RawSQL ())
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe (PrimaryKey, RawSQL ()))
-> Maybe (PrimaryKey, RawSQL ()))
-> m (Maybe (Maybe (PrimaryKey, RawSQL ())))
-> m (Maybe (PrimaryKey, RawSQL ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((String, Array1 String) -> Maybe (PrimaryKey, RawSQL ()))
-> m (Maybe (Maybe (PrimaryKey, RawSQL ())))
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) = (, String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL String
name)
(PrimaryKey -> (PrimaryKey, RawSQL ()))
-> Maybe PrimaryKey -> Maybe (PrimaryKey, RawSQL ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([RawSQL ()] -> Maybe PrimaryKey
pkOnColumns ([RawSQL ()] -> Maybe PrimaryKey)
-> [RawSQL ()] -> Maybe PrimaryKey
forall a b. (a -> b) -> a -> b
$ (String -> RawSQL ()) -> [String] -> [RawSQL ()]
forall a b. (a -> b) -> [a] -> [b]
map String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL [String]
columns)
sqlGetChecks :: Table -> SQL
sqlGetChecks :: Table -> SQL
sqlGetChecks Table
table = SqlSelect -> SQL
forall a. Sqlable a => a -> SQL
toSQLCommand (SqlSelect -> SQL)
-> (State SqlSelect () -> SqlSelect) -> State SqlSelect () -> SQL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_constraint c" (State SqlSelect () -> SQL) -> State SqlSelect () -> SQL
forall a b. (a -> b) -> a -> b
$ do
SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"c.conname::text"
SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"regexp_replace(pg_get_constraintdef(c.oid, true), \
\'CHECK \\((.*)\\)', '\\1') AS body"
SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"c.convalidated"
SQL -> Char -> State SqlSelect ()
forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"c.contype" Char
'c'
SQL -> SQL -> State SqlSelect ()
forall v (m :: * -> *) sql.
(MonadState v m, SqlWhere v, Sqlable sql) =>
SQL -> sql -> m ()
sqlWhereEqSql SQL
"c.conrelid" (SQL -> State SqlSelect ()) -> SQL -> State SqlSelect ()
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 :: RawSQL () -> RawSQL () -> Bool -> Check
Check {
chkName :: RawSQL ()
chkName = String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL String
name
, chkCondition :: RawSQL ()
chkCondition = String -> RawSQL ()
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 = SqlSelect -> SQL
forall a. Sqlable a => a -> SQL
toSQLCommand (SqlSelect -> SQL)
-> (State SqlSelect () -> SqlSelect) -> State SqlSelect () -> SQL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_class c" (State SqlSelect () -> SQL) -> State SqlSelect () -> SQL
forall a b. (a -> b) -> a -> b
$ do
SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"c.relname::text"
SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult (SQL -> State SqlSelect ()) -> SQL -> State SqlSelect ()
forall a b. (a -> b) -> a -> b
$ SQL
"ARRAY(" SQL -> SQL -> SQL
forall a. Semigroup a => a -> a -> a
<> SQL
selectCoordinates SQL -> SQL -> SQL
forall a. Semigroup a => a -> a -> a
<> SQL
")"
SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"am.amname::text"
SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"i.indisunique"
SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"i.indisvalid"
SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"pg_catalog.pg_get_expr(i.indpred, i.indrelid, true)"
SQL -> SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlFrom v) =>
SQL -> SQL -> m ()
sqlJoinOn SQL
"pg_catalog.pg_index i" SQL
"c.oid = i.indexrelid"
SQL -> SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlFrom v) =>
SQL -> SQL -> m ()
sqlJoinOn SQL
"pg_catalog.pg_am am" SQL
"c.relam = am.oid"
SQL -> SQL -> State SqlSelect ()
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"
SQL -> SQL -> State SqlSelect ()
forall v (m :: * -> *) sql.
(MonadState v m, SqlWhere v, Sqlable sql) =>
SQL -> sql -> m ()
sqlWhereEqSql SQL
"i.indrelid" (SQL -> State SqlSelect ()) -> SQL -> State SqlSelect ()
forall a b. (a -> b) -> a -> b
$ Table -> SQL
sqlGetTableID Table
table
SQL -> State SqlSelect ()
forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhereIsNULL SQL
"r.contype"
where
selectCoordinates :: SQL
selectCoordinates = [SQL] -> SQL
forall m. (IsString m, Monoid m) => [m] -> m
smconcat [
SQL
"WITH RECURSIVE coordinates(k, name) AS ("
, SQL
" VALUES (0, NULL)"
, SQL
" UNION ALL"
, SQL
" SELECT k+1, pg_catalog.pg_get_indexdef(i.indexrelid, k+1, true)"
, SQL
" FROM coordinates"
, SQL
" WHERE pg_catalog.pg_get_indexdef(i.indexrelid, k+1, true) != ''"
, SQL
")"
, SQL
"SELECT name FROM coordinates WHERE k > 0"
]
fetchTableIndex :: (String, Array1 String, String, Bool, Bool, Maybe String)
-> (TableIndex, RawSQL ())
fetchTableIndex :: (String, Array1 String, String, Bool, Bool, Maybe String)
-> (TableIndex, RawSQL ())
fetchTableIndex (String
name, Array1 [String]
columns, String
method, Bool
unique, Bool
valid, Maybe String
mconstraint) =
(TableIndex :: [RawSQL ()]
-> IndexMethod -> Bool -> Bool -> Maybe (RawSQL ()) -> TableIndex
TableIndex
{ idxColumns :: [RawSQL ()]
idxColumns = (String -> RawSQL ()) -> [String] -> [RawSQL ()]
forall a b. (a -> b) -> [a] -> [b]
map String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL [String]
columns
, idxMethod :: IndexMethod
idxMethod = String -> IndexMethod
forall a. Read a => String -> a
read String
method
, idxUnique :: Bool
idxUnique = Bool
unique
, idxValid :: Bool
idxValid = Bool
valid
, idxWhere :: Maybe (RawSQL ())
idxWhere = String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL (String -> RawSQL ()) -> Maybe String -> Maybe (RawSQL ())
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` Maybe String
mconstraint
}
, String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL String
name)
sqlGetForeignKeys :: Table -> SQL
sqlGetForeignKeys :: Table -> SQL
sqlGetForeignKeys Table
table = SqlSelect -> SQL
forall a. Sqlable a => a -> SQL
toSQLCommand
(SqlSelect -> SQL)
-> (State SqlSelect () -> SqlSelect) -> State SqlSelect () -> SQL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_constraint r" (State SqlSelect () -> SQL) -> State SqlSelect () -> SQL
forall a b. (a -> b) -> a -> b
$ do
SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"r.conname::text"
SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult (SQL -> State SqlSelect ()) -> SQL -> State SqlSelect ()
forall a b. (a -> b) -> a -> b
$
SQL
"ARRAY(SELECT a.attname::text FROM pg_catalog.pg_attribute a JOIN ("
SQL -> SQL -> SQL
forall a. Semigroup a => a -> a -> a
<> RawSQL () -> SQL
unnestWithOrdinality RawSQL ()
"r.conkey"
SQL -> SQL -> SQL
forall a. Semigroup a => a -> a -> a
<> SQL
") conkeys ON (a.attnum = conkeys.item) \
\WHERE a.attrelid = r.conrelid \
\ORDER BY conkeys.n)"
SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"c.relname::text"
SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult (SQL -> State SqlSelect ()) -> SQL -> State SqlSelect ()
forall a b. (a -> b) -> a -> b
$ SQL
"ARRAY(SELECT a.attname::text \
\FROM pg_catalog.pg_attribute a JOIN ("
SQL -> SQL -> SQL
forall a. Semigroup a => a -> a -> a
<> RawSQL () -> SQL
unnestWithOrdinality RawSQL ()
"r.confkey"
SQL -> SQL -> SQL
forall a. Semigroup a => a -> a -> a
<> SQL
") confkeys ON (a.attnum = confkeys.item) \
\WHERE a.attrelid = r.confrelid \
\ORDER BY confkeys.n)"
SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"r.confupdtype"
SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"r.confdeltype"
SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"r.condeferrable"
SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"r.condeferred"
SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"r.convalidated"
SQL -> SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlFrom v) =>
SQL -> SQL -> m ()
sqlJoinOn SQL
"pg_catalog.pg_class c" SQL
"c.oid = r.confrelid"
SQL -> SQL -> State SqlSelect ()
forall v (m :: * -> *) sql.
(MonadState v m, SqlWhere v, Sqlable sql) =>
SQL -> sql -> m ()
sqlWhereEqSql SQL
"r.conrelid" (SQL -> State SqlSelect ()) -> SQL -> State SqlSelect ()
forall a b. (a -> b) -> a -> b
$ Table -> SQL
sqlGetTableID Table
table
SQL -> Char -> State SqlSelect ()
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, " SQL -> SQL -> SQL
forall a. Semigroup a => a -> a -> a
<> RawSQL () -> SQL
raw RawSQL ()
arr
SQL -> SQL -> SQL
forall a. Semigroup a => a -> a -> a
<> SQL
"[n] AS item FROM generate_subscripts(" SQL -> SQL -> SQL
forall a. Semigroup a => a -> a -> a
<> RawSQL () -> SQL
raw RawSQL ()
arr SQL -> SQL -> SQL
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 :: [RawSQL ()]
-> RawSQL ()
-> [RawSQL ()]
-> ForeignKeyAction
-> ForeignKeyAction
-> Bool
-> Bool
-> Bool
-> ForeignKey
ForeignKey {
fkColumns :: [RawSQL ()]
fkColumns = (String -> RawSQL ()) -> [String] -> [RawSQL ()]
forall a b. (a -> b) -> [a] -> [b]
map String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL [String]
columns
, fkRefTable :: RawSQL ()
fkRefTable = String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL String
reftable
, fkRefColumns :: [RawSQL ()]
fkRefColumns = (String -> RawSQL ()) -> [String] -> [RawSQL ()]
forall a b. (a -> b) -> [a] -> [b]
map String -> RawSQL ()
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
}, String -> RawSQL ()
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
_ -> String -> ForeignKeyAction
forall a. HasCallStack => String -> a
error (String -> ForeignKeyAction) -> String -> ForeignKeyAction
forall a b. (a -> b) -> a -> b
$ String
"fetchForeignKey: invalid foreign key action code: "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. Show a => a -> String
show Char
c