Support running with higher table versions in the database than in th…

…e code (#45)

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)

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:
                      .

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 @@ migrateDatabase options
   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 @@ checkDatabase_ options ovm composites domains tables = do
   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 @@ getDBTableNames = do
   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 @@ checkDBStructure
   => 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 @@ checkDBConsistency options domains tablesWithVersions migrations = do
         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 ()

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

src/Database/PostgreSQL/PQTypes/Model/Table.hs

@@ -65,11 +65,6 @@ data Table =
   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
 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 = []

test/Main.hs

@@ -805,6 +805,7 @@ migrationTest2 connSource =
       currentSchema   = schema1Tables
       differentSchema = schema5Tables
       extrasOptions   = defaultExtrasOptions { eoEnforcePKs = True }
+      extrasOptionsWithUnknownObjects = extrasOptions { eoObjectsValidationMode = AllowUnknownObjects }
 
   runQuery_ $ sqlCreateComposite composite
 
@@ -814,38 +815,38 @@ migrationTest2 connSource =
     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)"
   assertException "checkDatabase throw when extra entry in 'table_versions'" $
     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)"
   assertException "checkDatabase should throw with unknown table" $
     checkDatabase extrasOptions [] [] currentSchema
   assertNoException ("checkDatabaseAllowUnknownObjects \
                      \accepts unknown tables with version") $
-    checkDatabaseAllowUnknownObjects extrasOptions [] [] currentSchema
+    checkDatabase extrasOptionsWithUnknownObjects [] [] currentSchema
 
   freshTestDB    step