diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,8 +1,11 @@ -# hpqtypes-extra-1.10.4.0 (2021-02-04) +# hpqtypes-extras-1.11.0.0 (2021-03-29) +* Support running with higher table versions in the database than in the code + +# hpqtypes-extras-1.10.4.0 (2021-02-04) * Generate valid INSERT SELECT query with data modifying WITH clauses * Add DerivingVia helpers for enums -# hpqtypes-extra-1.10.3.0 (2020-11-16) +# hpqtypes-extras-1.10.3.0 (2020-11-16) * Include LIMIT clause in UNION subqueries of the select # hpqtypes-extras-1.10.2.1 (2020-05-05) diff --git a/hpqtypes-extras.cabal b/hpqtypes-extras.cabal --- a/hpqtypes-extras.cabal +++ b/hpqtypes-extras.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: hpqtypes-extras -version: 1.10.4.0 +version: 1.11.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 --- a/src/Database/PostgreSQL/PQTypes/Checks.hs +++ b/src/Database/PostgreSQL/PQTypes/Checks.hs @@ -1,20 +1,19 @@ module Database.PostgreSQL.PQTypes.Checks ( -- * Checks checkDatabase - , checkDatabaseAllowUnknownObjects , createTable , createDomain -- * Options , ExtrasOptions(..) , defaultExtrasOptions + , ObjectsValidationMode(..) -- * Migrations , migrateDatabase ) where import Control.Arrow ((&&&)) -import Control.Applicative ((<$>)) import Control.Monad.Catch import Control.Monad.Reader import Data.Int @@ -67,49 +66,41 @@ checkDBConsistency options domains tablesWithVersions migrations resultCheck =<< checkCompositesStructure tablesWithVersions CreateCompositesIfDatabaseEmpty - DontAllowUnknownObjects + (eoObjectsValidationMode options) composites resultCheck =<< checkDomainsStructure domains resultCheck =<< checkDBStructure options tablesWithVersions resultCheck =<< checkTablesWereDropped migrations - resultCheck =<< checkUnknownTables tables - resultCheck =<< checkExistenceOfVersionsForTables (tableVersions : tables) + when (eoObjectsValidationMode options == DontAllowUnknownObjects) $ do + resultCheck =<< checkUnknownTables tables + resultCheck =<< checkExistenceOfVersionsForTables (tableVersions : tables) + + -- After migrations are done make sure the table versions are correct. + resultCheck . checkVersions options =<< getTableVersions (tableVersions : tables) + -- everything is OK, commit changes commit --- | Run checks on the database structure and whether the database --- needs to be migrated. Will do a full check of DB structure. +-- | Run checks on the database structure and whether the database needs to be +-- migrated. Will do a full check of DB structure. checkDatabase :: forall m . (MonadDB m, MonadLog m, MonadThrow m) - => ExtrasOptions -> [CompositeType] -> [Domain] -> [Table] -> m () -checkDatabase options = checkDatabase_ options DontAllowUnknownObjects - --- | Same as 'checkDatabase', but will not fail if there are additional tables --- and composite types in the database. -checkDatabaseAllowUnknownObjects - :: forall m . (MonadDB m, MonadLog m, MonadThrow m) - => ExtrasOptions -> [CompositeType] -> [Domain] -> [Table] -> m () -checkDatabaseAllowUnknownObjects options = checkDatabase_ options AllowUnknownObjects - -data ObjectsValidationMode = AllowUnknownObjects | DontAllowUnknownObjects - deriving Eq - -checkDatabase_ - :: forall m . (MonadDB m, MonadLog m, MonadThrow m) => ExtrasOptions - -> ObjectsValidationMode -> [CompositeType] -> [Domain] -> [Table] -> m () -checkDatabase_ options ovm composites domains tables = do +checkDatabase options composites domains tables = do tablesWithVersions <- getTableVersions (tableVersions : tables) - resultCheck $ checkVersions tablesWithVersions - resultCheck =<< checkCompositesStructure tablesWithVersions DontCreateComposites ovm composites + resultCheck $ checkVersions options tablesWithVersions + resultCheck =<< checkCompositesStructure tablesWithVersions + DontCreateComposites + (eoObjectsValidationMode options) + composites resultCheck =<< checkDomainsStructure domains resultCheck =<< checkDBStructure options tablesWithVersions - when (ovm == DontAllowUnknownObjects) $ do + when (eoObjectsValidationMode options == DontAllowUnknownObjects) $ do resultCheck =<< checkUnknownTables tables resultCheck =<< checkExistenceOfVersionsForTables (tableVersions : tables) @@ -118,24 +109,6 @@ resultCheck =<< checkInitialSetups tables where - checkVersions :: TablesWithVersions -> ValidationResult - checkVersions vs = mconcat . map checkVersion $ vs - - checkVersion :: (Table, Int32) -> ValidationResult - checkVersion (t@Table{..}, v) - | 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 checkInitialSetup' $ tbls @@ -198,6 +171,21 @@ dbTableNames <- fetchMany runIdentity return dbTableNames +checkVersions :: ExtrasOptions -> TablesWithVersions -> ValidationResult +checkVersions options = mconcat . map checkVersion + where + checkVersion :: (Table, Int32) -> ValidationResult + checkVersion (t@Table{..}, v) + | if eoAllowHigherTableVersions options + then tblVersion <= v + else tblVersion == v = mempty + | v == 0 = validationError $ + "Table '" <> tblNameText t <> "' must be created" + | otherwise = validationError $ + "Table '" <> tblNameText t + <> "' must be migrated" <+> showt v <+> "->" + <+> showt tblVersion + -- | Check that there's a 1-to-1 correspondence between the list of -- 'Table's and what's actually in the database. checkUnknownTables :: (MonadDB m, MonadLog m) => [Table] -> m ValidationResult @@ -395,13 +383,11 @@ => ExtrasOptions -> TablesWithVersions -> m ValidationResult -checkDBStructure options tables = fmap mconcat . - forM tables $ \(table, version) -> - do +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 + -- If we allow higher table versions in the database, show inconsistencies as + -- info messages only. + return $ if eoAllowHigherTableVersions options && tblVersion table < version then validationErrorsToInfos result else result where @@ -824,12 +810,9 @@ logInfo_ "Running migrations..." forM_ migrationsToRun $ \mgr -> do runMigration mgr - - when (eoForceCommit options) $ do + when (eoCommitAfterEachMigration options) $ do logInfo_ $ "Committing migration changes..." commit - logInfo_ $ "Committing migration changes done." - logInfo_ "!IMPORTANT! Database has been permanently changed" logInfo_ "Running migrations... done." validateMigrationsToRun :: [Migration m] -> [(Text, Int32)] -> m () diff --git a/src/Database/PostgreSQL/PQTypes/ExtrasOptions.hs b/src/Database/PostgreSQL/PQTypes/ExtrasOptions.hs --- a/src/Database/PostgreSQL/PQTypes/ExtrasOptions.hs +++ b/src/Database/PostgreSQL/PQTypes/ExtrasOptions.hs @@ -1,18 +1,29 @@ module Database.PostgreSQL.PQTypes.ExtrasOptions ( ExtrasOptions(..) , defaultExtrasOptions + , ObjectsValidationMode(..) ) where data ExtrasOptions = ExtrasOptions - { eoForceCommit :: Bool - -- ^ Force commit after every migration - , eoEnforcePKs :: Bool + { eoCommitAfterEachMigration :: Bool + -- ^ Run commit after every migration. + , eoEnforcePKs :: Bool -- ^ Validate that every handled table has a primary key + , eoObjectsValidationMode :: !ObjectsValidationMode + -- ^ Validation mode for unknown tables and composite types. + , eoAllowHigherTableVersions :: !Bool + -- ^ Whether to allow tables in the database to have higher versions than + -- the one in the code definition. } deriving Eq defaultExtrasOptions :: ExtrasOptions defaultExtrasOptions = ExtrasOptions - { eoForceCommit = False - , eoEnforcePKs = False + { eoCommitAfterEachMigration = False + , eoEnforcePKs = False + , eoObjectsValidationMode = DontAllowUnknownObjects + , eoAllowHigherTableVersions = False } + +data ObjectsValidationMode = AllowUnknownObjects | DontAllowUnknownObjects + deriving Eq diff --git a/src/Database/PostgreSQL/PQTypes/Model/Table.hs b/src/Database/PostgreSQL/PQTypes/Model/Table.hs --- a/src/Database/PostgreSQL/PQTypes/Model/Table.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/Table.hs @@ -65,11 +65,6 @@ Table { tblName :: RawSQL () -- ^ Must be in lower case. , tblVersion :: 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] @@ -87,7 +82,6 @@ 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 = [] diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -805,6 +805,7 @@ currentSchema = schema1Tables differentSchema = schema5Tables extrasOptions = defaultExtrasOptions { eoEnforcePKs = True } + extrasOptionsWithUnknownObjects = extrasOptions { eoObjectsValidationMode = AllowUnknownObjects } runQuery_ $ sqlCreateComposite composite @@ -814,15 +815,15 @@ checkDatabase extrasOptions [] [] currentSchema assertNoException "checkDatabaseAllowUnknownTables runs fine \ \for consistent DB" $ - checkDatabaseAllowUnknownObjects extrasOptions [composite] [] currentSchema + checkDatabase extrasOptionsWithUnknownObjects [composite] [] currentSchema assertNoException "checkDatabaseAllowUnknownTables runs fine \ \for consistent DB with unknown composite type in the database" $ - checkDatabaseAllowUnknownObjects extrasOptions [] [] currentSchema + checkDatabase extrasOptionsWithUnknownObjects [] [] currentSchema assertException "checkDatabase should throw exception for wrong schema" $ checkDatabase extrasOptions [] [] differentSchema assertException ("checkDatabaseAllowUnknownObjects \ \should throw exception for wrong scheme") $ - checkDatabaseAllowUnknownObjects extrasOptions [] [] differentSchema + checkDatabase extrasOptionsWithUnknownObjects [] [] differentSchema runSQL_ "INSERT INTO table_versions (name, version) \ \VALUES ('unknown_table', 0)" @@ -830,14 +831,14 @@ checkDatabase extrasOptions [] [] currentSchema assertNoException ("checkDatabaseAllowUnknownObjects \ \accepts extra entry in 'table_versions'") $ - checkDatabaseAllowUnknownObjects extrasOptions [] [] currentSchema + checkDatabase extrasOptionsWithUnknownObjects [] [] currentSchema runSQL_ "DELETE FROM table_versions where name='unknown_table'" runSQL_ "CREATE TABLE unknown_table (title text)" assertException "checkDatabase should throw with unknown table" $ checkDatabase extrasOptions [] [] currentSchema assertNoException "checkDatabaseAllowUnknownObjects accepts unknown table" $ - checkDatabaseAllowUnknownObjects extrasOptions [] [] currentSchema + checkDatabase extrasOptionsWithUnknownObjects [] [] currentSchema runSQL_ "INSERT INTO table_versions (name, version) \ \VALUES ('unknown_table', 0)" @@ -845,7 +846,7 @@ checkDatabase extrasOptions [] [] currentSchema assertNoException ("checkDatabaseAllowUnknownObjects \ \accepts unknown tables with version") $ - checkDatabaseAllowUnknownObjects extrasOptions [] [] currentSchema + checkDatabase extrasOptionsWithUnknownObjects [] [] currentSchema freshTestDB step