From 0a61f6552a420829a1d23bc24c68fd0286caa30a Mon Sep 17 00:00:00 2001 From: Andrzej Rybczak Date: Wed, 5 Dec 2018 00:52:31 +0100 Subject: [PATCH 1/8] Add support for no downtime migrations --- hpqtypes-extras.cabal | 2 +- src/Database/PostgreSQL/PQTypes/Checks.hs | 86 +++++++++++-------- .../PostgreSQL/PQTypes/Checks/Util.hs | 29 +++++++ src/Database/PostgreSQL/PQTypes/Migrate.hs | 8 +- .../PostgreSQL/PQTypes/Model/Check.hs | 41 ++++++++- .../PostgreSQL/PQTypes/Model/ForeignKey.hs | 31 ++++++- .../PostgreSQL/PQTypes/Model/Index.hs | 30 ++++++- .../PostgreSQL/PQTypes/Model/PrimaryKey.hs | 14 +++ .../PostgreSQL/PQTypes/Model/Table.hs | 18 ++-- 9 files changed, 204 insertions(+), 55 deletions(-) diff --git a/hpqtypes-extras.cabal b/hpqtypes-extras.cabal index c09cda3..76c38d4 100644 --- a/hpqtypes-extras.cabal +++ b/hpqtypes-extras.cabal @@ -1,6 +1,6 @@ cabal-version: 1.18 name: hpqtypes-extras -version: 1.6.3.0 +version: 1.7.0.0 synopsis: Extra utilities for hpqtypes library description: The following extras for hpqtypes library: . diff --git a/src/Database/PostgreSQL/PQTypes/Checks.hs b/src/Database/PostgreSQL/PQTypes/Checks.hs index 72cc262..c46cd49 100644 --- a/src/Database/PostgreSQL/PQTypes/Checks.hs +++ b/src/Database/PostgreSQL/PQTypes/Checks.hs @@ -51,13 +51,14 @@ migrateDatabase migrateDatabase options@ExtrasOptions{..} extensions domains tables migrations = do setDBTimeZoneToUTC mapM_ checkExtension extensions + tablesWithVersions <- getTableVersions (tableVersions : tables) -- 'checkDBConsistency' also performs migrations. - checkDBConsistency options domains (tableVersions : tables) migrations - resultCheck =<< checkDomainsStructure domains - resultCheck =<< checkDBStructure options (tableVersions : tables) - resultCheck =<< checkTablesWereDropped migrations - resultCheck =<< checkUnknownTables tables - resultCheck =<< checkExistenceOfVersionsForTables (tableVersions : tables) + checkDBConsistency options domains tablesWithVersions migrations + resultCheck =<< checkDomainsStructure domains + resultsCheck =<< checkDBStructure options tablesWithVersions + resultCheck =<< checkTablesWereDropped migrations + resultCheck =<< checkUnknownTables tables + resultCheck =<< checkExistenceOfVersionsForTables (tableVersions : tables) -- everything is OK, commit changes commit @@ -80,11 +81,10 @@ checkDatabase_ :: forall m . (MonadDB m, MonadLog m, MonadThrow m) => ExtrasOptions -> Bool -> [Domain] -> [Table] -> m () checkDatabase_ options allowUnknownTables domains tables = do - tablesWithVersions <- getTableVersions tables - + tablesWithVersions <- getTableVersions (tableVersions : tables) resultCheck $ checkVersions tablesWithVersions - resultCheck =<< checkDomainsStructure domains - resultCheck =<< checkDBStructure options (tableVersions : tables) + resultCheck =<< checkDomainsStructure domains + resultsCheck =<< checkDBStructure options tablesWithVersions when (not $ allowUnknownTables) $ do resultCheck =<< checkUnknownTables tables resultCheck =<< checkExistenceOfVersionsForTables (tableVersions : tables) @@ -99,7 +99,10 @@ checkDatabase_ options allowUnknownTables domains tables = do checkVersion :: (Table, Int32) -> [Text] checkVersion (t@Table{..}, v) - | tblVersion == v = [] + | tblVersion `elem` tblAcceptedDbVersions = + ["Table '" <> tblNameText t <> + "' has its current table version in accepted db versions"] + | tblVersion == v || v `elem` tblAcceptedDbVersions = [] | v == 0 = ["Table '" <> tblNameText t <> "' must be created"] | otherwise = ["Table '" <> tblNameText t <> "' must be migrated" <+> showt v <+> "->" @@ -225,17 +228,19 @@ checkDomainsStructure defs = fmap mconcat . forM defs $ \def -> do sqlResult "t1.typdefault" -- default value sqlResult "ARRAY(SELECT c.conname::text FROM pg_catalog.pg_constraint c WHERE c.contypid = t1.oid ORDER by c.oid)" -- constraint names sqlResult "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)" -- constraint definitions + sqlResult "ARRAY(SELECT c.convalidated FROM pg_catalog.pg_constraint c WHERE c.contypid = t1.oid ORDER by c.oid)" -- are constraints validated? sqlWhereEq "t1.typname" $ unRawSQL $ domName def - mdom <- fetchMaybe $ \(dname, dtype, nullable, defval, cnames, conds) -> + mdom <- fetchMaybe $ \(dname, dtype, nullable, defval, cnames, conds, valids) -> Domain { domName = unsafeSQL dname , domType = dtype , domNullable = nullable , domDefault = unsafeSQL <$> defval - , domChecks = mkChecks $ zipWith (\cname cond -> Check { + , domChecks = mkChecks $ zipWith3 (\cname cond validated -> Check { chkName = unsafeSQL cname , chkCondition = unsafeSQL cond - }) (unArray1 cnames) (unArray1 conds) + , chkValidated = validated + }) (unArray1 cnames) (unArray1 conds) (unArray1 valids) } return $ case mdom of Just dom @@ -276,12 +281,18 @@ checkTablesWereDropped mgrs = do <> " is still present in the database." ] -- | Checks whether database is consistent. -checkDBStructure :: forall m. (MonadDB m, MonadThrow m) - => ExtrasOptions -> [Table] -> m ValidationResult -checkDBStructure options tables = fmap mconcat . forM tables $ \table -> - -- final checks for table structure, we do this - -- both when creating stuff and when migrating - topMessage "table" (tblNameText table) <$> checkTableStructure table +checkDBStructure + :: forall m. (MonadDB m, MonadThrow m) + => ExtrasOptions + -> [(Table, Int32)] + -> m ValidationResults +checkDBStructure options tables = fmap mconcat . forM tables $ \(table, version) -> do + result <- topMessage "table" (tblNameText table) <$> checkTableStructure table + -- If one of the accepted versions defined for the table is the current table + -- version in the database, show inconsistencies as info messages only. + return $ if version `elem` tblAcceptedDbVersions table + then ValidationResults result mempty + else ValidationResults mempty result where checkTableStructure :: Table -> m ValidationResult checkTableStructure table@Table{..} = do @@ -422,15 +433,14 @@ checkDBStructure options tables = fmap mconcat . forM tables $ \table -> -- the 'tables' list checkDBConsistency :: forall m. (MonadDB m, MonadLog m, MonadThrow m) - => ExtrasOptions -> [Domain] -> [Table] -> [Migration m] + => ExtrasOptions -> [Domain] -> [(Table, Int32)] -> [Migration m] -> m () -checkDBConsistency options domains tables migrations = do +checkDBConsistency options domains tablesWithVersions migrations = do -- Check the validity of the migrations list. validateMigrations validateDropTableMigrations -- Load version numbers of the tables that actually exist in the DB. - tablesWithVersions <- getTableVersions $ tables dbTablesWithVersions <- getDBTableVersions if all ((==) 0 . snd) tablesWithVersions @@ -450,6 +460,7 @@ checkDBConsistency options domains tables migrations = do runMigrations dbTablesWithVersions where + tables = map fst tablesWithVersions errorInvalidMigrations :: [RawSQL ()] -> a errorInvalidMigrations tblNames = @@ -543,8 +554,8 @@ checkDBConsistency options domains tables migrations = do -- | Input is a list of (table name, expected version, actual version) triples. validateMigrationsAgainstDB :: [(RawSQL (), Int32, Int32)] -> m () - validateMigrationsAgainstDB tablesWithVersions - = forM_ tablesWithVersions $ \(tableName, expectedVer, actualVer) -> + validateMigrationsAgainstDB tablesWithVersions_ + = forM_ tablesWithVersions_ $ \(tableName, expectedVer, actualVer) -> when (expectedVer /= actualVer) $ case [ m | m@Migration{..} <- migrations , mgrTableName == tableName ] of @@ -646,12 +657,9 @@ checkDBConsistency options domains tables migrations = do runMigration mgr when (eoForceCommit options) $ do - logInfo_ $ "Forcing commit after migraton" - <> " and starting new transaction..." + logInfo_ $ "Commiting migration changes..." commit - begin - logInfo_ $ "Forcing commit after migraton" - <> " and starting new transaction... done." + logInfo_ $ "Commiting migration changes done." logInfo_ "!IMPORTANT! Database has been permanently changed" logInfo_ "Running migrations... done." @@ -847,13 +855,15 @@ sqlGetChecks :: Table -> SQL sqlGetChecks table = toSQLCommand . sqlSelect "pg_catalog.pg_constraint c" $ do sqlResult "c.conname::text" sqlResult "regexp_replace(pg_get_constraintdef(c.oid, true), 'CHECK \\((.*)\\)', '\\1') AS body" -- check body + sqlResult "c.convalidated" -- validated? sqlWhereEq "c.contype" 'c' sqlWhereEqSql "c.conrelid" $ sqlGetTableID table -fetchTableCheck :: (String, String) -> Check -fetchTableCheck (name, condition) = Check { +fetchTableCheck :: (String, String, Bool) -> Check +fetchTableCheck (name, condition, validated) = Check { chkName = unsafeSQL name , chkCondition = unsafeSQL condition +, chkValidated = validated } -- *** INDEXES *** @@ -864,6 +874,7 @@ sqlGetIndexes table = toSQLCommand . sqlSelect "pg_catalog.pg_class c" $ do sqlResult $ "ARRAY(" <> selectCoordinates <> ")" -- array of index coordinates sqlResult "am.amname::text" -- the method used (btree, gin etc) sqlResult "i.indisunique" -- is it unique? + sqlResult "i.indisvalid" -- is it valid? -- if partial, get constraint def sqlResult "pg_catalog.pg_get_expr(i.indpred, i.indrelid, true)" sqlJoinOn "pg_catalog.pg_index i" "c.oid = i.indexrelid" @@ -885,12 +896,13 @@ sqlGetIndexes table = toSQLCommand . sqlSelect "pg_catalog.pg_class c" $ do , "SELECT name FROM coordinates WHERE k > 0" ] -fetchTableIndex :: (String, Array1 String, String, Bool, Maybe String) +fetchTableIndex :: (String, Array1 String, String, Bool, Bool, Maybe String) -> (TableIndex, RawSQL ()) -fetchTableIndex (name, Array1 columns, method, unique, mconstraint) = (TableIndex { +fetchTableIndex (name, Array1 columns, method, unique, valid, mconstraint) = (TableIndex { idxColumns = map unsafeSQL columns , idxMethod = read method , idxUnique = unique +, idxValid = valid , idxWhere = unsafeSQL `liftM` mconstraint }, unsafeSQL name) @@ -912,6 +924,7 @@ sqlGetForeignKeys table = toSQLCommand sqlResult "r.confdeltype" -- on delete sqlResult "r.condeferrable" -- deferrable? sqlResult "r.condeferred" -- initially deferred? + sqlResult "r.convalidated" -- validated? sqlJoinOn "pg_catalog.pg_class c" "c.oid = r.confrelid" sqlWhereEqSql "r.conrelid" $ sqlGetTableID table sqlWhereEq "r.contype" 'f' @@ -922,11 +935,11 @@ sqlGetForeignKeys table = toSQLCommand <> "[n] AS item FROM generate_subscripts(" <> raw arr <> ", 1) AS n" fetchForeignKey :: - (String, Array1 String, String, Array1 String, Char, Char, Bool, Bool) + (String, Array1 String, String, Array1 String, Char, Char, Bool, Bool, Bool) -> (ForeignKey, RawSQL ()) fetchForeignKey ( name, Array1 columns, reftable, Array1 refcolumns - , on_update, on_delete, deferrable, deferred ) = (ForeignKey { + , on_update, on_delete, deferrable, deferred, validated ) = (ForeignKey { fkColumns = map unsafeSQL columns , fkRefTable = unsafeSQL reftable , fkRefColumns = map unsafeSQL refcolumns @@ -934,6 +947,7 @@ fetchForeignKey , fkOnDelete = charToForeignKeyAction on_delete , fkDeferrable = deferrable , fkDeferred = deferred +, fkValidated = validated }, unsafeSQL name) where charToForeignKeyAction c = case c of diff --git a/src/Database/PostgreSQL/PQTypes/Checks/Util.hs b/src/Database/PostgreSQL/PQTypes/Checks/Util.hs index 0677c7b..546380b 100644 --- a/src/Database/PostgreSQL/PQTypes/Checks/Util.hs +++ b/src/Database/PostgreSQL/PQTypes/Checks/Util.hs @@ -2,6 +2,8 @@ module Database.PostgreSQL.PQTypes.Checks.Util ( ValidationResult(..), resultCheck, + ValidationResults(..), + resultsCheck, topMessage, tblNameText, tblNameString, @@ -54,6 +56,33 @@ resultCheck = \case mapM_ logAttention_ msgs error "resultCheck: validation failed" +---------------------------------------- + +data ValidationResults = ValidationResults + { vrInfo :: ValidationResult + , vrError :: ValidationResult + } + +instance SG.Semigroup ValidationResults where + ValidationResults info1 error1 <> ValidationResults info2 error2 = + ValidationResults (info1 SG.<> info2) (error1 SG.<> error2) + +instance Monoid ValidationResults where + mempty = ValidationResults mempty mempty + mappend = (SG.<>) + +resultsCheck + :: (MonadLog m, MonadThrow m) + => ValidationResults + -> m () +resultsCheck ValidationResults{..} = do + mapM_ logInfo_ infoMsgs + resultCheck vrError + where + ValidationResult infoMsgs = vrInfo + +---------------------------------------- + tblNameText :: Table -> Text tblNameText = unRawSQL . tblName diff --git a/src/Database/PostgreSQL/PQTypes/Migrate.hs b/src/Database/PostgreSQL/PQTypes/Migrate.hs index 1bc1111..cd760da 100644 --- a/src/Database/PostgreSQL/PQTypes/Migrate.hs +++ b/src/Database/PostgreSQL/PQTypes/Migrate.hs @@ -17,7 +17,7 @@ createDomain dom@Domain{..} = do -- create the domain runQuery_ $ sqlCreateDomain dom -- add constraint checks to the domain - F.forM_ domChecks $ runQuery_ . sqlAlterDomain domName . sqlAddCheck + F.forM_ domChecks $ runQuery_ . sqlAlterDomain domName . sqlAddValidCheck createTable :: MonadDB m => Bool -> Table -> m () createTable withConstraints table@Table{..} = do @@ -25,7 +25,7 @@ createTable withConstraints table@Table{..} = do runQuery_ $ sqlCreateTable tblName runQuery_ $ sqlAlterTable tblName $ map sqlAddColumn tblColumns -- Add indexes. - forM_ tblIndexes $ runQuery_ . sqlCreateIndex tblName + forM_ tblIndexes $ runQuery_ . sqlCreateIndexSequentially tblName -- Add all the other constraints if applicable. when withConstraints $ createTableConstraints table -- Register the table along with its version. @@ -39,6 +39,6 @@ createTableConstraints Table{..} = when (not $ null addConstraints) $ do where addConstraints = concat [ [sqlAddPK tblName pk | Just pk <- return tblPrimaryKey] - , map sqlAddCheck tblChecks - , map (sqlAddFK tblName) tblForeignKeys + , map sqlAddValidCheck tblChecks + , map (sqlAddValidFK tblName) tblForeignKeys ] diff --git a/src/Database/PostgreSQL/PQTypes/Model/Check.hs b/src/Database/PostgreSQL/PQTypes/Model/Check.hs index 8ce1f78..8474df7 100644 --- a/src/Database/PostgreSQL/PQTypes/Model/Check.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/Check.hs @@ -1,6 +1,10 @@ module Database.PostgreSQL.PQTypes.Model.Check ( Check(..) + , tblCheck , sqlAddCheck + , sqlAddValidCheck + , sqlAddNotValidCheck + , sqlValidateCheck , sqlDropCheck ) where @@ -11,16 +15,47 @@ import Prelude data Check = Check { chkName :: RawSQL () , chkCondition :: RawSQL () +, chkValidated :: Bool } deriving (Eq, Ord, Show) +tblCheck :: Check +tblCheck = Check + { chkName = "" + , chkCondition = "" + , chkValidated = True + } + +{-# DEPRECATED sqlAddCheck "Use sqlAddValidCheck instead" #-} +-- | Deprecated version of 'sqlAddValidCheck'. sqlAddCheck :: Check -> RawSQL () -sqlAddCheck Check{..} = smconcat [ +sqlAddCheck = sqlAddCheck_ True + +-- | Add valid check constraint. Warning: PostgreSQL acquires SHARE ROW +-- EXCLUSIVE lock (that prevents updates) on modified table for the duration of +-- the creation. If this is not acceptable, use 'sqlAddNotValidCheck' and +-- 'sqlValidateCheck'. +sqlAddValidCheck :: Check -> RawSQL () +sqlAddValidCheck = sqlAddCheck_ True + +-- | Add check marked as NOT VALID. This avoids potentially long validation +-- blocking updates to modified table for its dueation. However, checks created +-- as such need to be validated later using 'sqlValidateCheck'. +sqlAddNotValidCheck :: Check -> RawSQL () +sqlAddNotValidCheck = sqlAddCheck_ False + +-- | Validate check previously created as NOT VALID. +sqlValidateCheck :: Check -> RawSQL () +sqlValidateCheck Check{..} = "VALIDATE" <+> chkName + +sqlAddCheck_ :: Bool -> Check -> RawSQL () +sqlAddCheck_ valid Check{..} = smconcat [ "ADD CONSTRAINT" , chkName , "CHECK (" , chkCondition , ")" + , if valid then "" else " NOT VALID" ] -sqlDropCheck :: Check -> RawSQL () -sqlDropCheck Check{..} = "DROP CONSTRAINT" <+> chkName +sqlDropCheck :: RawSQL () -> RawSQL () +sqlDropCheck name = "DROP CONSTRAINT" <+> name diff --git a/src/Database/PostgreSQL/PQTypes/Model/ForeignKey.hs b/src/Database/PostgreSQL/PQTypes/Model/ForeignKey.hs index bf47f76..1d06d22 100644 --- a/src/Database/PostgreSQL/PQTypes/Model/ForeignKey.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/ForeignKey.hs @@ -5,6 +5,9 @@ module Database.PostgreSQL.PQTypes.Model.ForeignKey ( , fkOnColumns , fkName , sqlAddFK + , sqlAddValidFK + , sqlAddNotValidFK + , sqlValidateFK , sqlDropFK ) where @@ -22,6 +25,7 @@ data ForeignKey = ForeignKey { , fkOnDelete :: ForeignKeyAction , fkDeferrable :: Bool , fkDeferred :: Bool +, fkValidated :: Bool } deriving (Eq, Ord, Show) data ForeignKeyAction @@ -45,6 +49,7 @@ fkOnColumns columns reftable refcolumns = ForeignKey { , fkOnDelete = ForeignKeyNoAction , fkDeferrable = True , fkDeferred = False +, fkValidated = True } fkName :: RawSQL () -> ForeignKey -> RawSQL () @@ -60,8 +65,31 @@ fkName tname ForeignKey{..} = shorten $ mconcat [ -- PostgreSQL's limit for identifier is 63 characters shorten = flip rawSQL () . T.take 63 . unRawSQL +{-# DEPRECATED sqlAddFK "Use sqlAddValidFK instead" #-} +-- | Deprecated version of sqlAddValidFK. sqlAddFK :: RawSQL () -> ForeignKey -> RawSQL () -sqlAddFK tname fk@ForeignKey{..} = mconcat [ +sqlAddFK = sqlAddFK_ True + +-- | Add valid foreign key. Warning: PostgreSQL acquires SHARE ROW EXCLUSIVE +-- lock (that prevents data updates) on both modified and referenced table for +-- the duration of the creation. If this is not acceptable, use +-- 'sqlAddNotValidFK' and 'sqlValidateFK'. +sqlAddValidFK :: RawSQL () -> ForeignKey -> RawSQL () +sqlAddValidFK = sqlAddFK_ True + +-- | Add foreign key marked as NOT VALID. This avoids potentially long +-- validation blocking updates to both modified and referenced table for its +-- duration. However, keys created as such need to be validated later using +-- 'sqlValidateFK'. +sqlAddNotValidFK :: RawSQL () -> ForeignKey -> RawSQL () +sqlAddNotValidFK = sqlAddFK_ False + +-- | Validate foreign key previously created as NOT VALID. +sqlValidateFK :: RawSQL () -> ForeignKey -> RawSQL () +sqlValidateFK tname fk = "VALIDATE" <+> fkName tname fk + +sqlAddFK_ :: Bool -> RawSQL () -> ForeignKey -> RawSQL () +sqlAddFK_ valid tname fk@ForeignKey{..} = mconcat [ "ADD CONSTRAINT" <+> fkName tname fk <+> "FOREIGN KEY (" , mintercalate ", " fkColumns , ") REFERENCES" <+> fkRefTable <+> "(" @@ -70,6 +98,7 @@ sqlAddFK tname fk@ForeignKey{..} = mconcat [ , " ON DELETE" <+> foreignKeyActionToSQL fkOnDelete , " " <> if fkDeferrable then "DEFERRABLE" else "NOT DEFERRABLE" , " INITIALLY" <+> if fkDeferred then "DEFERRED" else "IMMEDIATE" + , if valid then "" else " NOT VALID" ] where foreignKeyActionToSQL ForeignKeyNoAction = "NO ACTION" diff --git a/src/Database/PostgreSQL/PQTypes/Model/Index.hs b/src/Database/PostgreSQL/PQTypes/Model/Index.hs index 425541f..8239792 100644 --- a/src/Database/PostgreSQL/PQTypes/Model/Index.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/Index.hs @@ -11,6 +11,8 @@ module Database.PostgreSQL.PQTypes.Model.Index ( , uniqueIndexOnColumns , indexName , sqlCreateIndex + , sqlCreateIndexSequentially + , sqlCreateIndexConcurrently , sqlDropIndex ) where @@ -29,6 +31,7 @@ data TableIndex = TableIndex { idxColumns :: [RawSQL ()] , idxMethod :: IndexMethod , idxUnique :: Bool +, idxValid :: Bool , idxWhere :: Maybe (RawSQL ()) } deriving (Eq, Ord, Show) @@ -51,6 +54,7 @@ tblIndex = TableIndex { idxColumns = [] , idxMethod = BTree , idxUnique = False +, idxValid = True , idxWhere = Nothing } @@ -80,6 +84,7 @@ uniqueIndexOnColumn column = TableIndex { idxColumns = [column] , idxMethod = BTree , idxUnique = True +, idxValid = True , idxWhere = Nothing } @@ -88,6 +93,7 @@ uniqueIndexOnColumns columns = TableIndex { idxColumns = columns , idxMethod = BTree , idxUnique = True +, idxValid = True , idxWhere = Nothing } @@ -96,6 +102,7 @@ uniqueIndexOnColumnWithCondition column whereC = TableIndex { idxColumns = [column] , idxMethod = BTree , idxUnique = True +, idxValid = True , idxWhere = Just whereC } @@ -122,11 +129,30 @@ indexName tname TableIndex{..} = flip rawSQL () $ T.take 63 . unRawSQL $ mconcat -- with the same columns, but different constraints can coexist hashWhere = asText $ T.decodeUtf8 . encode . BS.take 10 . hash . T.encodeUtf8 +{-# DEPRECATED sqlCreateIndex "Use sqlCreateIndexSequentially instead" #-} +-- | Deprecated version of 'sqlCreateIndexSequentially'. sqlCreateIndex :: RawSQL () -> TableIndex -> RawSQL () -sqlCreateIndex tname idx@TableIndex{..} = mconcat [ +sqlCreateIndex = sqlCreateIndex_ False + +-- | Create index sequentially. Warning: if the affected table is large, this +-- will prevent the table from being modified during the creation. If this is +-- not acceptable, use sqlCreateIndexConcurrently. See +-- https://www.postgresql.org/docs/current/sql-createindex.html for more +-- information. +sqlCreateIndexSequentially :: RawSQL () -> TableIndex -> RawSQL () +sqlCreateIndexSequentially = sqlCreateIndex_ False + +-- | Create index concurrently. +sqlCreateIndexConcurrently :: RawSQL () -> TableIndex -> RawSQL () +sqlCreateIndexConcurrently = sqlCreateIndex_ True + +sqlCreateIndex_ :: Bool -> RawSQL () -> TableIndex -> RawSQL () +sqlCreateIndex_ concurrently tname idx@TableIndex{..} = mconcat [ "CREATE " , if idxUnique then "UNIQUE " else "" - , "INDEX" <+> indexName tname idx <+> "ON" <+> tname <+> "" + , "INDEX " <+> indexName tname idx + , if concurrently then " CONCURRENTLY" else "" + , " ON" <+> tname <+> "" , "USING" <+> (rawSQL (T.pack . show $ idxMethod) ()) <+> "(" , mintercalate ", " idxColumns , ")" diff --git a/src/Database/PostgreSQL/PQTypes/Model/PrimaryKey.hs b/src/Database/PostgreSQL/PQTypes/Model/PrimaryKey.hs index 9062f2c..3199810 100644 --- a/src/Database/PostgreSQL/PQTypes/Model/PrimaryKey.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/PrimaryKey.hs @@ -4,6 +4,7 @@ module Database.PostgreSQL.PQTypes.Model.PrimaryKey ( , pkOnColumns , pkName , sqlAddPK + , sqlAddPKUsing , sqlDropPK ) where @@ -11,6 +12,7 @@ import Data.Monoid (mconcat) import Data.Monoid.Utils import Database.PostgreSQL.PQTypes import Prelude +import Database.PostgreSQL.PQTypes.Model.Index import Database.PostgreSQL.PQTypes.Utils.NubList newtype PrimaryKey = PrimaryKey (NubList (RawSQL ())) @@ -35,5 +37,17 @@ sqlAddPK tname (PrimaryKey columns) = smconcat [ , ")" ] +-- | Convert a unique index into a primary key. Main usage is to build a unique +-- index concurrently first (so that its creation doesn't conflict with table +-- updates on the modified table) and then convert it into a primary key using +-- this function. +sqlAddPKUsing :: RawSQL () -> TableIndex -> RawSQL () +sqlAddPKUsing tname idx = smconcat + [ "ADD CONSTRAINT" + , pkName tname + , "PRIMARY KEY USING INDEX" + , indexName tname idx + ] + sqlDropPK :: RawSQL () -> RawSQL () sqlDropPK tname = "DROP CONSTRAINT" <+> pkName tname diff --git a/src/Database/PostgreSQL/PQTypes/Model/Table.hs b/src/Database/PostgreSQL/PQTypes/Model/Table.hs index 0114e81..d273857 100644 --- a/src/Database/PostgreSQL/PQTypes/Model/Table.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/Table.hs @@ -63,14 +63,15 @@ data Rows = forall row. (Show row, ToRow row) => Rows [ByteString] [row] data Table = Table { - tblName :: RawSQL () -- ^ Must be in lower case. -, tblVersion :: Int32 -, tblColumns :: [TableColumn] -, tblPrimaryKey :: Maybe PrimaryKey -, tblChecks :: [Check] -, tblForeignKeys :: [ForeignKey] -, tblIndexes :: [TableIndex] -, tblInitialSetup :: Maybe TableInitialSetup + tblName :: RawSQL () -- ^ Must be in lower case. +, tblVersion :: Int32 +, tblAcceptedDbVersions :: [Int32] +, tblColumns :: [TableColumn] +, tblPrimaryKey :: Maybe PrimaryKey +, tblChecks :: [Check] +, tblForeignKeys :: [ForeignKey] +, tblIndexes :: [TableIndex] +, tblInitialSetup :: Maybe TableInitialSetup } data TableInitialSetup = TableInitialSetup { @@ -82,6 +83,7 @@ tblTable :: Table tblTable = Table { tblName = error "tblTable: table name must be specified" , tblVersion = error "tblTable: table version must be specified" +, tblAcceptedDbVersions = [] , tblColumns = error "tblTable: table columns must be specified" , tblPrimaryKey = Nothing , tblChecks = [] From 27a2c0cc1b1c2cf648483c60892027f8151537fc Mon Sep 17 00:00:00 2001 From: Mikhail Glushenkov Date: Mon, 17 Dec 2018 13:24:12 +0000 Subject: [PATCH 2/8] Formatting. --- src/Database/PostgreSQL/PQTypes/Model/Check.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Database/PostgreSQL/PQTypes/Model/Check.hs b/src/Database/PostgreSQL/PQTypes/Model/Check.hs index 8474df7..bf4c749 100644 --- a/src/Database/PostgreSQL/PQTypes/Model/Check.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/Check.hs @@ -20,7 +20,7 @@ data Check = Check { tblCheck :: Check tblCheck = Check - { chkName = "" + { chkName = "" , chkCondition = "" , chkValidated = True } From f4bd34c9f7e3f6dbdd9e7827f32eb531e8c3c990 Mon Sep 17 00:00:00 2001 From: Mikhail Glushenkov Date: Mon, 17 Dec 2018 13:24:21 +0000 Subject: [PATCH 3/8] Typo. --- src/Database/PostgreSQL/PQTypes/Model/Check.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Database/PostgreSQL/PQTypes/Model/Check.hs b/src/Database/PostgreSQL/PQTypes/Model/Check.hs index bf4c749..bd3cf26 100644 --- a/src/Database/PostgreSQL/PQTypes/Model/Check.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/Check.hs @@ -38,7 +38,7 @@ sqlAddValidCheck :: Check -> RawSQL () sqlAddValidCheck = sqlAddCheck_ True -- | Add check marked as NOT VALID. This avoids potentially long validation --- blocking updates to modified table for its dueation. However, checks created +-- blocking updates to modified table for its duration. However, checks created -- as such need to be validated later using 'sqlValidateCheck'. sqlAddNotValidCheck :: Check -> RawSQL () sqlAddNotValidCheck = sqlAddCheck_ False From 1e3bcee5fc83ac2fa575441feb36ad6e559861ea Mon Sep 17 00:00:00 2001 From: Mikhail Glushenkov Date: Tue, 18 Dec 2018 16:15:17 +0000 Subject: [PATCH 4/8] Merge 'ValidationResults' and 'ValidationResult'. --- src/Database/PostgreSQL/PQTypes/Checks.hs | 164 +++++++++--------- .../PostgreSQL/PQTypes/Checks/Util.hs | 103 +++++------ 2 files changed, 139 insertions(+), 128 deletions(-) diff --git a/src/Database/PostgreSQL/PQTypes/Checks.hs b/src/Database/PostgreSQL/PQTypes/Checks.hs index c46cd49..fc4ae2c 100644 --- a/src/Database/PostgreSQL/PQTypes/Checks.hs +++ b/src/Database/PostgreSQL/PQTypes/Checks.hs @@ -54,11 +54,11 @@ migrateDatabase options@ExtrasOptions{..} extensions domains tables migrations = tablesWithVersions <- getTableVersions (tableVersions : tables) -- 'checkDBConsistency' also performs migrations. checkDBConsistency options domains tablesWithVersions migrations - resultCheck =<< checkDomainsStructure domains - resultsCheck =<< checkDBStructure options tablesWithVersions - resultCheck =<< checkTablesWereDropped migrations - resultCheck =<< checkUnknownTables tables - resultCheck =<< checkExistenceOfVersionsForTables (tableVersions : tables) + resultCheck =<< checkDomainsStructure domains + resultCheck =<< checkDBStructure options tablesWithVersions + resultCheck =<< checkTablesWereDropped migrations + resultCheck =<< checkUnknownTables tables + resultCheck =<< checkExistenceOfVersionsForTables (tableVersions : tables) -- everything is OK, commit changes commit @@ -83,8 +83,8 @@ checkDatabase_ checkDatabase_ options allowUnknownTables domains tables = do tablesWithVersions <- getTableVersions (tableVersions : tables) resultCheck $ checkVersions tablesWithVersions - resultCheck =<< checkDomainsStructure domains - resultsCheck =<< checkDBStructure options tablesWithVersions + resultCheck =<< checkDomainsStructure domains + resultCheck =<< checkDBStructure options tablesWithVersions when (not $ allowUnknownTables) $ do resultCheck =<< checkUnknownTables tables resultCheck =<< checkExistenceOfVersionsForTables (tableVersions : tables) @@ -95,30 +95,34 @@ checkDatabase_ options allowUnknownTables domains tables = do where checkVersions :: [(Table, Int32)] -> ValidationResult - checkVersions vs = mconcat . map (ValidationResult . checkVersion) $ vs + checkVersions vs = mconcat . map checkVersion $ vs - checkVersion :: (Table, Int32) -> [Text] + checkVersion :: (Table, Int32) -> ValidationResult checkVersion (t@Table{..}, v) - | tblVersion `elem` tblAcceptedDbVersions = - ["Table '" <> tblNameText t <> - "' has its current table version in accepted db versions"] - | tblVersion == v || v `elem` tblAcceptedDbVersions = [] - | v == 0 = ["Table '" <> tblNameText t <> "' must be created"] - | otherwise = ["Table '" <> tblNameText t - <> "' must be migrated" <+> showt v <+> "->" - <+> showt tblVersion] + | tblVersion `elem` tblAcceptedDbVersions + = validationError $ + "Table '" <> tblNameText t <> + "' has its current table version in accepted db versions" + | tblVersion == v || v `elem` tblAcceptedDbVersions + = mempty + | v == 0 = validationError $ + "Table '" <> tblNameText t <> "' must be created" + | otherwise = validationError $ + "Table '" <> tblNameText t + <> "' must be migrated" <+> showt v <+> "->" + <+> showt tblVersion checkInitialSetups :: [Table] -> m ValidationResult checkInitialSetups tbls = - liftM mconcat . mapM (liftM ValidationResult . checkInitialSetup') $ tbls + liftM mconcat . mapM checkInitialSetup' $ tbls - checkInitialSetup' :: Table -> m [Text] + checkInitialSetup' :: Table -> m ValidationResult checkInitialSetup' t@Table{..} = case tblInitialSetup of - Nothing -> return [] + Nothing -> return mempty Just is -> checkInitialSetup is >>= \case - True -> return [] - False -> return ["Initial setup for table '" - <> tblNameText t <> "' is not valid"] + True -> return mempty + False -> return . validationError $ "Initial setup for table '" + <> tblNameText t <> "' is not valid" -- | Return SQL fragment of current catalog within quotes currentCatalog :: (MonadDB m, MonadThrow m) => m (RawSQL ()) @@ -183,18 +187,20 @@ checkUnknownTables tables = do then do mapM_ (logInfo_ . (<+>) "Unknown table:") absent mapM_ (logInfo_ . (<+>) "Table not present in the database:") notPresent - return . ValidationResult $ - (joinedResult "Unknown tables:" absent) ++ - (joinedResult "Tables not present in the database:" notPresent) + return $ + (validateIsNull "Unknown tables:" absent) <> + (validateIsNull "Tables not present in the database:" notPresent) else return mempty - where - joinedResult :: Text -> [Text] -> [Text] - joinedResult _ [] = [] - joinedResult t ts = [ t <+> T.intercalate ", " ts] + +validateIsNull :: Text -> [Text] -> ValidationResult +validateIsNull _ [] = mempty +validateIsNull msg ts = validationError $ msg <+> T.intercalate ", " ts -- | Check that there's a 1-to-1 correspondence between the list of -- 'Table's and what's actually in the table 'table_versions'. -checkExistenceOfVersionsForTables :: (MonadDB m, MonadLog m) => [Table] -> m ValidationResult +checkExistenceOfVersionsForTables + :: (MonadDB m, MonadLog m) + => [Table] -> m ValidationResult checkExistenceOfVersionsForTables tables = do runQuery_ $ sqlSelect "table_versions" $ do sqlResult "name::text" @@ -208,14 +214,10 @@ checkExistenceOfVersionsForTables tables = do then do mapM_ (logInfo_ . (<+>) "Unknown entry in 'table_versions':") absent mapM_ (logInfo_ . (<+>) "Table not present in the 'table_versions':") notPresent - return . ValidationResult $ - (joinedResult "Unknown entry in table_versions':" absent ) ++ - (joinedResult "Tables not present in the 'table_versions':" notPresent) + return $ + (validateIsNull "Unknown entry in table_versions':" absent ) <> + (validateIsNull "Tables not present in the 'table_versions':" notPresent) else return mempty - where - joinedResult :: Text -> [Text] -> [Text] - joinedResult _ [] = [] - joinedResult t ts = [ t <+> T.intercalate ", " ts] checkDomainsStructure :: (MonadDB m, MonadThrow m) @@ -252,17 +254,17 @@ checkDomainsStructure defs = fmap mconcat . forM defs $ \def -> do , compareAttr dom def "checks" domChecks ] | otherwise -> mempty - Nothing -> ValidationResult ["Domain '" <> unRawSQL (domName def) - <> "' doesn't exist in the database"] + Nothing -> validationError $ "Domain '" <> unRawSQL (domName def) + <> "' doesn't exist in the database" where compareAttr :: (Eq a, Show a) => Domain -> Domain -> Text -> (Domain -> a) -> ValidationResult compareAttr dom def attrname attr - | attr dom == attr def = ValidationResult [] - | otherwise = ValidationResult - [ "Attribute '" <> attrname - <> "' does not match (database:" <+> T.pack (show $ attr dom) - <> ", definition:" <+> T.pack (show $ attr def) <> ")" ] + | attr dom == attr def = mempty + | otherwise = validationError $ + "Attribute '" <> attrname + <> "' does not match (database:" <+> T.pack (show $ attr dom) + <> ", definition:" <+> T.pack (show $ attr def) <> ")" -- | Check that the tables that must have been dropped are actually -- missing from the DB. @@ -276,23 +278,24 @@ checkTablesWereDropped mgrs = do mver <- checkTableVersion (T.unpack . unRawSQL $ tblName) return $ if isNothing mver then mempty - else ValidationResult [ "The table '" <> unRawSQL tblName - <> "' that must have been dropped" - <> " is still present in the database." ] + else validationError $ "The table '" <> unRawSQL tblName + <> "' that must have been dropped" + <> " is still present in the database." --- | Checks whether database is consistent. +-- | Checks whether the database is consistent. checkDBStructure :: forall m. (MonadDB m, MonadThrow m) => ExtrasOptions -> [(Table, Int32)] - -> m ValidationResults -checkDBStructure options tables = fmap mconcat . forM tables $ \(table, version) -> do + -> m ValidationResult +checkDBStructure options tables = fmap mconcat . forM tables $ \(table, version) -> + do result <- topMessage "table" (tblNameText table) <$> checkTableStructure table -- If one of the accepted versions defined for the table is the current table -- version in the database, show inconsistencies as info messages only. return $ if version `elem` tblAcceptedDbVersions table - then ValidationResults result mempty - else ValidationResults mempty result + then validationErrorsToInfos result + else result where checkTableStructure :: Table -> m ValidationResult checkTableStructure table@Table{..} = do @@ -339,8 +342,8 @@ checkDBStructure options tables = fmap mconcat . forM tables $ \(table, version) checkColumns :: Int -> [TableColumn] -> [TableColumn] -> ValidationResult checkColumns _ [] [] = mempty - checkColumns _ rest [] = ValidationResult [tableHasLess "columns" rest] - checkColumns _ [] rest = ValidationResult [tableHasMore "columns" rest] + checkColumns _ rest [] = validationError $ tableHasLess "columns" rest + checkColumns _ [] rest = validationError $ tableHasMore "columns" rest checkColumns !n (d:defs) (c:cols) = mconcat [ validateNames $ colName d == colName c -- bigserial == bigint + autoincrement and there is no @@ -357,25 +360,25 @@ checkDBStructure options tables = fmap mconcat . forM tables $ \(table, version) , checkColumns (n+1) defs cols ] where - validateNames True = mempty - validateNames False = ValidationResult - [ errorMsg ("no. " <> showt n) "names" (unRawSQL . colName) ] - - validateTypes True = mempty - validateTypes False = ValidationResult - [ errorMsg cname "types" (T.pack . show . colType) - <+> sqlHint ("TYPE" <+> columnTypeToSQL (colType d)) ] - - validateNullables True = mempty - validateNullables False = ValidationResult - [ errorMsg cname "nullables" (showt . colNullable) - <+> sqlHint ((if colNullable d then "DROP" else "SET") - <+> "NOT NULL") ] - - validateDefaults True = mempty - validateDefaults False = ValidationResult - [ (errorMsg cname "defaults" (showt . fmap unRawSQL . colDefault)) - <+> sqlHint set_default ] + validateNames True = mempty + validateNames False = validationError $ + errorMsg ("no. " <> showt n) "names" (unRawSQL . colName) + + validateTypes True = mempty + validateTypes False = validationError $ + errorMsg cname "types" (T.pack . show . colType) + <+> sqlHint ("TYPE" <+> columnTypeToSQL (colType d)) + + validateNullables True = mempty + validateNullables False = validationError $ + errorMsg cname "nullables" (showt . colNullable) + <+> sqlHint ((if colNullable d then "DROP" else "SET") + <+> "NOT NULL") + + validateDefaults True = mempty + validateDefaults False = validationError $ + (errorMsg cname "defaults" (showt . fmap unRawSQL . colDefault)) + <+> sqlHint set_default where set_default = case colDefault d of Just v -> "SET DEFAULT" <+> v @@ -404,10 +407,15 @@ checkDBStructure options tables = fmap mconcat . forM tables $ \(table, version) pk = maybeToList mpk checkChecks :: [Check] -> [Check] -> ValidationResult - checkChecks defs checks = case checkEquality "CHECKs" defs checks of - ValidationResult [] -> ValidationResult [] - ValidationResult errmsgs -> ValidationResult $ - errmsgs ++ [" (HINT: If checks are equal modulo number of parentheses/whitespaces used in conditions, just copy and paste expected output into source code)"] + checkChecks defs checks = + mapValidationResult id mapErrs (checkEquality "CHECKs" defs checks) + where + mapErrs [] = [] + mapErrs errmsgs = errmsgs <> + [ " (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 diff --git a/src/Database/PostgreSQL/PQTypes/Checks/Util.hs b/src/Database/PostgreSQL/PQTypes/Checks/Util.hs index 546380b..430ad57 100644 --- a/src/Database/PostgreSQL/PQTypes/Checks/Util.hs +++ b/src/Database/PostgreSQL/PQTypes/Checks/Util.hs @@ -1,9 +1,11 @@ {-# LANGUAGE CPP #-} module Database.PostgreSQL.PQTypes.Checks.Util ( - ValidationResult(..), + ValidationResult, + validationError, + validationInfo, + mapValidationResult, + validationErrorsToInfos, resultCheck, - ValidationResults(..), - resultsCheck, topMessage, tblNameText, tblNameString, @@ -30,56 +32,57 @@ import qualified Data.Semigroup as SG import Database.PostgreSQL.PQTypes.Model import Database.PostgreSQL.PQTypes --- | A (potentially empty) list of error messages. -newtype ValidationResult = ValidationResult [Text] +-- | A (potentially empty) list of info/error messages. +data ValidationResult = ValidationResult + { vrInfos :: [Text] + , vrErrors :: [Text] + } + +validationError :: Text -> ValidationResult +validationError err = mempty { vrErrors = [err] } + +validationInfo :: Text -> ValidationResult +validationInfo msg = mempty { vrInfos = [msg] } + +-- | Downgrade all error messages in a ValidationResult to info messages. +validationErrorsToInfos :: ValidationResult -> ValidationResult +validationErrorsToInfos ValidationResult{..} = + mempty { vrInfos = vrInfos <> vrErrors } + +mapValidationResult :: + ([Text] -> [Text]) -> ([Text] -> [Text]) -> ValidationResult -> ValidationResult +mapValidationResult mapInfos mapErrs ValidationResult{..} = + mempty { vrInfos = mapInfos vrInfos, vrErrors = mapErrs vrErrors } instance SG.Semigroup ValidationResult where - (ValidationResult a) <> (ValidationResult b) = ValidationResult (a ++ b) + (ValidationResult infos0 errs0) <> (ValidationResult infos1 errs1) + = ValidationResult (infos0 <> infos1) (errs0 <> errs1) instance Monoid ValidationResult where - mempty = ValidationResult [] + mempty = ValidationResult [] [] mappend = (SG.<>) topMessage :: Text -> Text -> ValidationResult -> ValidationResult -topMessage objtype objname = \case - ValidationResult [] -> ValidationResult [] - ValidationResult es -> ValidationResult - ("There are problems with the" <+> objtype <+> "'" <> objname <> "'" : es) - +topMessage objtype objname vr@ValidationResult{..} = + case vrErrors of + [] -> vr + es -> ValidationResult vrInfos + ("There are problems with the" <+> + objtype <+> "'" <> objname <> "'" : es) + +-- | Log all messages in a 'ValidationResult', and fail if any of them +-- were errors. resultCheck :: (MonadLog m, MonadThrow m) => ValidationResult -> m () -resultCheck = \case - ValidationResult [] -> return () - ValidationResult msgs -> do - mapM_ logAttention_ msgs - error "resultCheck: validation failed" - ----------------------------------------- - -data ValidationResults = ValidationResults - { vrInfo :: ValidationResult - , vrError :: ValidationResult - } - -instance SG.Semigroup ValidationResults where - ValidationResults info1 error1 <> ValidationResults info2 error2 = - ValidationResults (info1 SG.<> info2) (error1 SG.<> error2) - -instance Monoid ValidationResults where - mempty = ValidationResults mempty mempty - mappend = (SG.<>) - -resultsCheck - :: (MonadLog m, MonadThrow m) - => ValidationResults - -> m () -resultsCheck ValidationResults{..} = do - mapM_ logInfo_ infoMsgs - resultCheck vrError - where - ValidationResult infoMsgs = vrInfo +resultCheck ValidationResult{..} = do + mapM_ logInfo_ vrInfos + case vrErrors of + [] -> return () + msgs -> do + mapM_ logAttention_ msgs + error "resultCheck: validation failed" ---------------------------------------- @@ -92,7 +95,7 @@ tblNameString = T.unpack . tblNameText checkEquality :: (Eq t, Show t) => Text -> [t] -> [t] -> ValidationResult checkEquality pname defs props = case (defs L.\\ props, props L.\\ defs) of ([], []) -> mempty - (def_diff, db_diff) -> ValidationResult [mconcat [ + (def_diff, db_diff) -> validationError . mconcat $ [ "Table and its definition have diverged and have " , showt $ length db_diff , " and " @@ -104,7 +107,7 @@ checkEquality pname defs props = case (defs L.\\ props, props L.\\ defs) of , ", definition: " , T.pack $ show def_diff , ")." - ]] + ] checkNames :: Show t => (t -> RawSQL ()) -> [(t, RawSQL ())] -> ValidationResult checkNames prop_name = mconcat . map check @@ -112,7 +115,7 @@ checkNames prop_name = mconcat . map check check (prop, name) = case prop_name prop of pname | pname == name -> mempty - | otherwise -> ValidationResult [mconcat [ + | otherwise -> validationError . mconcat $ [ "Property " , T.pack $ show prop , " has invalid name (expected: " @@ -120,7 +123,7 @@ checkNames prop_name = mconcat . map check , ", given: " , unRawSQL name , ")." - ]] + ] -- | Check presence of primary key on the named table. We cover all the cases so -- this could be used standalone, but note that the those where the table source @@ -144,10 +147,10 @@ checkPKPresence tableName mdef mpk = noSrc = "no source definition" noTbl = "no table definition" valRes msgs = - ValidationResult [ - mconcat [ "Table ", unRawSQL tableName - , " has no primary key defined " - , " (" <> (mintercalate ", " msgs) <> ")"]] + validationError . mconcat $ + [ "Table ", unRawSQL tableName + , " has no primary key defined " + , " (" <> (mintercalate ", " msgs) <> ")"] tableHasLess :: Show t => Text -> t -> Text From a8f7a44b2adf315edf3498145e48acfcec39a601 Mon Sep 17 00:00:00 2001 From: Mikhail Glushenkov Date: Thu, 20 Dec 2018 01:52:03 +0000 Subject: [PATCH 5/8] Update the changelog. --- CHANGELOG.md | 22 +++++++++++++++++++++- 1 file changed, 21 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index f92bab2..0cd0399 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,24 @@ -# hpqtypes-extras-1.6.3.0 (2018-07-11) +# hpqtypes-extras-1.7.0.0 (2018-12-20) +* Added support for no-downtime migrations + ([#17](https://github.com/scrive/hpqtypes-extras/pull/17)): + - `sqlCreateIndex` is deprecated. Use either + `sqlCreateIndexSequentially` or `sqlCreateIndexConcurrently` + (no-downtime migration variant) instead. + - `sqlAddFK` is deprecated. Use either `sqlAddValidFK` or + `sqlAddNotValidFK` (no-downtime migration variant) instead. + - API addition: `sqlValidateFK`, for validating a foreign key + previously added with `sqlAddNotValidFK`. + - `sqlAddCheck` is deprecated. Use either `sqlAddValidCheck` or + `sqlAddNotValidCheck` (no-downtime migration variant) instead. + - API addition: `sqlValidateCheck`, for validating a check + previously added with `sqlAddNotValidCheck`. + - API addition: `sqlAddPKUsing`, converts a unique index to a + primary key. + - New `Table` field: `tblAcceptedDbVersions`. +* `ValidationResult` is now an abstract type. +* `ValidationResult` now supports info-level messages in addition to errors. + +# hpqtypes-extras-1.6.3.0 (2018-11-19) * API addition: `sqlWhereAnyE` ([#16](https://github.com/scrive/hpqtypes-extras/pull/16)). From 4862089fb69d9b87985c100a4c2a03bc160e0347 Mon Sep 17 00:00:00 2001 From: Mikhail Glushenkov Date: Thu, 20 Dec 2018 01:55:21 +0000 Subject: [PATCH 6/8] Regenerate .travis.yml. --- .travis.yml | 6 ++++-- hpqtypes-extras.cabal | 2 +- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/.travis.yml b/.travis.yml index 1d9d077..e07c0a9 100644 --- a/.travis.yml +++ b/.travis.yml @@ -29,9 +29,9 @@ before_cache: matrix: include: - - compiler: "ghc-8.6.2" + - compiler: "ghc-8.6.3" # env: TEST=--disable-tests BENCH=--disable-benchmarks - addons: {"postgresql" : "10", apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.6.2], sources: [hvr-ghc]}} + addons: {"postgresql" : "10", apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.6.3], sources: [hvr-ghc]}} - compiler: "ghc-8.4.4" # env: TEST=--disable-tests BENCH=--disable-benchmarks addons: {"postgresql" : "10", apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.4.4], sources: [hvr-ghc]}} @@ -66,6 +66,7 @@ install: - rm -fv cabal.project cabal.project.local - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$' - "printf 'packages: \".\"\\n' > cabal.project" + - "printf 'write-ghc-environment-files: always\\n' >> cabal.project" - touch cabal.project.local - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | grep -vw -- hpqtypes-extras | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi" - cat cabal.project || true @@ -88,6 +89,7 @@ script: - cd ${DISTDIR} || false - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \; - "printf 'packages: hpqtypes-extras-*/*.cabal\\n' > cabal.project" + - "printf 'write-ghc-environment-files: always\\n' >> cabal.project" - touch cabal.project.local - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | grep -vw -- hpqtypes-extras | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi" - cat cabal.project || true diff --git a/hpqtypes-extras.cabal b/hpqtypes-extras.cabal index 76c38d4..1af9a0b 100644 --- a/hpqtypes-extras.cabal +++ b/hpqtypes-extras.cabal @@ -20,7 +20,7 @@ maintainer: Andrzej Rybczak , copyright: Scrive AB category: Database build-type: Simple -tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.2 +tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.3 Source-repository head Type: git From c725de409e762a8f0e8a72449c5acfa53cba658b Mon Sep 17 00:00:00 2001 From: Mikhail Glushenkov Date: Thu, 20 Dec 2018 01:56:38 +0000 Subject: [PATCH 7/8] Typos. --- src/Database/PostgreSQL/PQTypes/Checks.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Database/PostgreSQL/PQTypes/Checks.hs b/src/Database/PostgreSQL/PQTypes/Checks.hs index fc4ae2c..4b95748 100644 --- a/src/Database/PostgreSQL/PQTypes/Checks.hs +++ b/src/Database/PostgreSQL/PQTypes/Checks.hs @@ -665,9 +665,9 @@ checkDBConsistency options domains tablesWithVersions migrations = do runMigration mgr when (eoForceCommit options) $ do - logInfo_ $ "Commiting migration changes..." + logInfo_ $ "Committing migration changes..." commit - logInfo_ $ "Commiting migration changes done." + logInfo_ $ "Committing migration changes done." logInfo_ "!IMPORTANT! Database has been permanently changed" logInfo_ "Running migrations... done." From fa60b298d15ac65dbe20760ed283355691416f89 Mon Sep 17 00:00:00 2001 From: Andrzej Rybczak Date: Mon, 7 Jan 2019 15:56:19 +0100 Subject: [PATCH 8/8] Add explanation for new fields --- src/Database/PostgreSQL/PQTypes/Model/Check.hs | 3 ++- src/Database/PostgreSQL/PQTypes/Model/ForeignKey.hs | 3 ++- src/Database/PostgreSQL/PQTypes/Model/Index.hs | 4 +++- src/Database/PostgreSQL/PQTypes/Model/Table.hs | 6 +++++- 4 files changed, 12 insertions(+), 4 deletions(-) diff --git a/src/Database/PostgreSQL/PQTypes/Model/Check.hs b/src/Database/PostgreSQL/PQTypes/Model/Check.hs index bd3cf26..7157082 100644 --- a/src/Database/PostgreSQL/PQTypes/Model/Check.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/Check.hs @@ -15,7 +15,8 @@ import Prelude data Check = Check { chkName :: RawSQL () , chkCondition :: RawSQL () -, chkValidated :: Bool +, chkValidated :: Bool -- ^ Set to 'True' if check is created as NOT VALID and + -- not validated afterwards. } deriving (Eq, Ord, Show) tblCheck :: Check diff --git a/src/Database/PostgreSQL/PQTypes/Model/ForeignKey.hs b/src/Database/PostgreSQL/PQTypes/Model/ForeignKey.hs index 1d06d22..b1ad61f 100644 --- a/src/Database/PostgreSQL/PQTypes/Model/ForeignKey.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/ForeignKey.hs @@ -25,7 +25,8 @@ data ForeignKey = ForeignKey { , fkOnDelete :: ForeignKeyAction , fkDeferrable :: Bool , fkDeferred :: Bool -, fkValidated :: Bool +, fkValidated :: Bool -- ^ Set to 'True' if foreign key is created as NOT VALID + -- and not validated afterwards. } deriving (Eq, Ord, Show) data ForeignKeyAction diff --git a/src/Database/PostgreSQL/PQTypes/Model/Index.hs b/src/Database/PostgreSQL/PQTypes/Model/Index.hs index 8239792..5b61e4d 100644 --- a/src/Database/PostgreSQL/PQTypes/Model/Index.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/Index.hs @@ -31,7 +31,9 @@ data TableIndex = TableIndex { idxColumns :: [RawSQL ()] , idxMethod :: IndexMethod , idxUnique :: Bool -, idxValid :: Bool +, idxValid :: Bool -- ^ If creation of index with CONCURRENTLY fails, index + -- will be marked as invalid. Set it to 'False' if such + -- situation is expected. , idxWhere :: Maybe (RawSQL ()) } deriving (Eq, Ord, Show) diff --git a/src/Database/PostgreSQL/PQTypes/Model/Table.hs b/src/Database/PostgreSQL/PQTypes/Model/Table.hs index d273857..7ef4796 100644 --- a/src/Database/PostgreSQL/PQTypes/Model/Table.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/Table.hs @@ -65,7 +65,11 @@ data Table = Table { tblName :: RawSQL () -- ^ Must be in lower case. , tblVersion :: Int32 -, tblAcceptedDbVersions :: [Int32] +, tblAcceptedDbVersions :: [Int32] -- ^ List of database table versions that + -- will be accepted even if they don't match + -- the table definition (note that in such + -- case structural differences are not + -- errors). , tblColumns :: [TableColumn] , tblPrimaryKey :: Maybe PrimaryKey , tblChecks :: [Check]