Extend checkDatabaseAllowUnknownTables to allow unknown composite types

scrive · May 20, 2019 · 22f353d · 22f353d
1 parent f470352
commit 22f353d
Show file tree

Hide file tree

Showing 4 changed files with 53 additions and 29 deletions.
diff --git a/CHANGELOG.md b/CHANGELOG.md
@@ -1,3 +1,7 @@
+# hpqtypes-extras-1.8.0.0 (2019-05-21)
+* Extend checkDatabaseAllowUnknownTables to allow unknown composite types and
+  rename it to checkDatabaseAllowUnknownObjects.
+
 # hpqtypes-extras-1.8.0.0 (2019-04-30)
 * Make composite types subject to migration process
   ([#21](https://github.com/scrive/hpqtypes-extras/pull/21)).

diff --git a/hpqtypes-extras.cabal b/hpqtypes-extras.cabal
@@ -1,6 +1,6 @@
 cabal-version:       1.18
 name:                hpqtypes-extras
-version:             1.8.0.0
+version:             1.9.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
@@ -1,7 +1,7 @@
 module Database.PostgreSQL.PQTypes.Checks (
   -- * Checks
     checkDatabase
-  , checkDatabaseAllowUnknownTables
+  , checkDatabaseAllowUnknownObjects
   , createTable
   , createDomain
 
@@ -64,7 +64,9 @@ migrateDatabase options@ExtrasOptions{..}
   tablesWithVersions <- getTableVersions (tableVersions : tables)
   -- 'checkDBConsistency' also performs migrations.
   checkDBConsistency options domains tablesWithVersions migrations
-  resultCheck =<< checkCompositesStructure True composites
+  resultCheck =<< checkCompositesStructure CreateCompositesIfDatabaseEmpty
+                                           DontAllowUnknownObjects
+                                           composites
   resultCheck =<< checkDomainsStructure domains
   resultCheck =<< checkDBStructure options tablesWithVersions
   resultCheck =<< checkTablesWereDropped migrations
@@ -79,25 +81,33 @@ migrateDatabase options@ExtrasOptions{..}
 checkDatabase
   :: forall m . (MonadDB m, MonadLog m, MonadThrow m)
   => ExtrasOptions -> [CompositeType] -> [Domain] -> [Table] -> m ()
-checkDatabase options = checkDatabase_ options False
+checkDatabase options = checkDatabase_ options DontAllowUnknownObjects
 
--- | Same as 'checkDatabase', but will not failed if there are
--- additional tables in database.
-checkDatabaseAllowUnknownTables
+-- | 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 ()
-checkDatabaseAllowUnknownTables options = checkDatabase_ options True
+checkDatabaseAllowUnknownObjects options = checkDatabase_ options AllowUnknownObjects
+
+data ObjectsValidationMode = AllowUnknownObjects | DontAllowUnknownObjects
+  deriving Eq
 
 checkDatabase_
   :: forall m . (MonadDB m, MonadLog m, MonadThrow m)
-  => ExtrasOptions -> Bool -> [CompositeType] -> [Domain] -> [Table] -> m ()
-checkDatabase_ options allowUnknownTables composites domains tables = do
+  => ExtrasOptions
+  -> ObjectsValidationMode
+  -> [CompositeType]
+  -> [Domain]
+  -> [Table]
+  -> m ()
+checkDatabase_ options ovm composites domains tables = do
   tablesWithVersions <- getTableVersions (tableVersions : tables)
   resultCheck $ checkVersions tablesWithVersions
-  resultCheck =<< checkCompositesStructure False composites
+  resultCheck =<< checkCompositesStructure DontCreateComposites ovm composites
   resultCheck =<< checkDomainsStructure domains
   resultCheck =<< checkDBStructure options tablesWithVersions
-  when (not $ allowUnknownTables) $ do
+  when (ovm == DontAllowUnknownObjects) $ do
     resultCheck =<< checkUnknownTables tables
     resultCheck =<< checkExistenceOfVersionsForTables (tableVersions : tables)
 
@@ -307,18 +317,23 @@ checkTablesWereDropped mgrs = do
                     <> "' that must have been dropped"
                     <> " is still present in the database."
 
+data CompositesCreationMode
+  = CreateCompositesIfDatabaseEmpty
+  | DontCreateComposites
+  deriving Eq
+
 -- | Check that there is 1 to 1 correspondence between composite types in the
 -- database and the list of their code definitions.
 checkCompositesStructure
   :: MonadDB m
-  => Bool -- ^ Create types if none are present in the database
+  => CompositesCreationMode
+  -> ObjectsValidationMode
   -> [CompositeType]
   -> m ValidationResult
-checkCompositesStructure createTypes compositeList = getDBCompositeTypes >>= \case
-  [] | createTypes -> do -- if there are no composite types in the database,
-                         -- create them (if there are any as code definitions).
-    mapM_ (runQuery_ . sqlCreateComposite) compositeList
-    return mempty
+checkCompositesStructure ccm ovm compositeList = getDBCompositeTypes >>= \case
+  [] | ccm == CreateCompositesIfDatabaseEmpty -> do
+         mapM_ (runQuery_ . sqlCreateComposite) compositeList
+         return mempty
   dbCompositeTypes -> pure $ mconcat
     [ checkNotPresentComposites
     , checkDatabaseComposites
@@ -337,8 +352,13 @@ checkCompositesStructure createTypes compositeList = getDBCompositeTypes >>= \ca
         in case cname `M.lookup` compositeMap of
           Just columns -> topMessage "composite type" cname $
             checkColumns 1 columns (ctColumns dbComposite)
-          Nothing -> validationError $ "Composite type '" <> T.pack (show dbComposite)
-            <> "' from the database doesn't have a corresponding code definition"
+          Nothing -> case ovm of
+            AllowUnknownObjects     -> mempty
+            DontAllowUnknownObjects -> validationError $ mconcat
+              [ "Composite type '"
+              , T.pack $ show dbComposite
+              , "' from the database doesn't have a corresponding code definition"
+              ]
         where
           checkColumns
             :: Int -> [CompositeColumn] -> [CompositeColumn] -> ValidationResult

diff --git a/test/Main.hs b/test/Main.hs
@@ -749,35 +749,35 @@ migrationTest2 connSource =
     checkDatabase extrasOptions [] [] currentSchema
   assertNoException "checkDatabaseAllowUnknownTables runs fine \
                     \for consistent DB" $
-    checkDatabaseAllowUnknownTables extrasOptions [] [] currentSchema
+    checkDatabaseAllowUnknownObjects extrasOptions [] [] currentSchema
   assertException "checkDatabase should throw exception for wrong schema" $
     checkDatabase extrasOptions [] [] differentSchema
-  assertException ("checkDatabaseAllowUnknownTables \
+  assertException ("checkDatabaseAllowUnknownObjects \
                    \should throw exception for wrong scheme") $
-    checkDatabaseAllowUnknownTables extrasOptions [] [] differentSchema
+    checkDatabaseAllowUnknownObjects extrasOptions [] [] 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 ("checkDatabaseAllowUnknownTables \
+  assertNoException ("checkDatabaseAllowUnknownObjects \
                      \accepts extra entry in 'table_versions'") $
-    checkDatabaseAllowUnknownTables extrasOptions [] [] currentSchema
+    checkDatabaseAllowUnknownObjects extrasOptions [] [] 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 "checkDatabaseAllowUnknownTables accepts unknown table" $
-    checkDatabaseAllowUnknownTables extrasOptions [] [] currentSchema
+  assertNoException "checkDatabaseAllowUnknownObjects accepts unknown table" $
+    checkDatabaseAllowUnknownObjects extrasOptions [] [] currentSchema
 
   runSQL_ "INSERT INTO table_versions (name, version) \
           \VALUES ('unknown_table', 0)"
   assertException "checkDatabase should throw with unknown table" $
     checkDatabase extrasOptions [] [] currentSchema
-  assertNoException ("checkDatabaseAllowUnknownTables \
+  assertNoException ("checkDatabaseAllowUnknownObjects \
                      \accepts unknown tables with version") $
-    checkDatabaseAllowUnknownTables extrasOptions [] [] currentSchema
+    checkDatabaseAllowUnknownObjects extrasOptions [] [] currentSchema
 
   freshTestDB    step