Merge pull request #22 from scrive/unknown-objects

Extend checkDatabaseAllowUnknownTables to allow unknown composite types

CHANGELOG.md

@@ -1,3 +1,7 @@
+# hpqtypes-extras-1.9.0.0 (2019-05-22)
+* 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)).

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:
                      .
@@ -51,7 +51,7 @@ library
                  , Database.PostgreSQL.PQTypes.Utils.NubList
 
   build-depends: base > 4 && < 4.13
-               , hpqtypes >= 1.6.0.0
+               , hpqtypes >= 1.7.0.0
                , base16-bytestring
                , bytestring
                , containers
@@ -101,6 +101,7 @@ test-suite  hpqtypes-extras-tests
                     , ScopedTypeVariables
   ghc-options:        -Wall
   build-depends:      base,
+                      data-default,
                       exceptions,
                       hpqtypes,
                       hpqtypes-extras,

src/Database/PostgreSQL/PQTypes/Checks.hs

@@ -1,7 +1,7 @@
 module Database.PostgreSQL.PQTypes.Checks (
   -- * Checks
     checkDatabase
-  , checkDatabaseAllowUnknownTables
+  , checkDatabaseAllowUnknownObjects
   , createTable
   , createDomain
 
@@ -24,7 +24,7 @@ import Data.Monoid.Utils
 import Data.Ord (comparing)
 import qualified Data.String
 import Data.Text (Text)
-import Database.PostgreSQL.PQTypes hiding (def)
+import Database.PostgreSQL.PQTypes
 import GHC.Stack (HasCallStack)
 import Log
 import Prelude
@@ -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

src/Database/PostgreSQL/PQTypes/Migrate.hs

@@ -7,7 +7,7 @@ module Database.PostgreSQL.PQTypes.Migrate (
 import Control.Monad
 import qualified Data.Foldable as F
 
-import Database.PostgreSQL.PQTypes hiding (def)
+import Database.PostgreSQL.PQTypes
 import Database.PostgreSQL.PQTypes.Checks.Util
 import Database.PostgreSQL.PQTypes.Model
 import Database.PostgreSQL.PQTypes.SQL.Builder

test/Main.hs

@@ -5,6 +5,7 @@ import Control.Exception.Lifted as E
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Control
 
+import Data.Default
 import Data.Monoid
 import Prelude
 import Data.Int
@@ -14,6 +15,7 @@ import Data.Typeable
 import Database.PostgreSQL.PQTypes
 import Database.PostgreSQL.PQTypes.Checks
 import Database.PostgreSQL.PQTypes.Model.ColumnType
+import Database.PostgreSQL.PQTypes.Model.CompositeType
 import Database.PostgreSQL.PQTypes.Model.ForeignKey
 import Database.PostgreSQL.PQTypes.Model.Index
 import Database.PostgreSQL.PQTypes.Model.Migration
@@ -735,49 +737,65 @@ migrationTest1 connSource =
 
   freshTestDB         step
 
--- | Test for behaviour of 'checkDatabase' and 'checkDatabaseAllowUnknownTables'
+-- | Test for behaviour of 'checkDatabase' and 'checkDatabaseAllowUnknownObjects'
 migrationTest2 :: ConnectionSourceM (LogT IO) -> TestTree
 migrationTest2 connSource =
   testCaseSteps' "Migration test 2" connSource $ \step -> do
   freshTestDB    step
 
   createTablesSchema1 step
-  let currentSchema   = schema1Tables
+
+  let composite = CompositeType
+        { ctName = "composite"
+        , ctColumns =
+          [ CompositeColumn { ccName = "cint",  ccType = BigIntT }
+          , CompositeColumn { ccName = "ctext", ccType = TextT }
+          ]
+        }
+      currentSchema   = schema1Tables
       differentSchema = schema5Tables
       extrasOptions = def { eoEnforcePKs = True }
+
+  runQuery_ $ sqlCreateComposite composite
+
   assertNoException "checkDatabase should run fine for consistent DB" $
+    checkDatabase extrasOptions [composite] [] currentSchema
+  assertException "checkDatabase fails if composite type definition is not provided" $
     checkDatabase extrasOptions [] [] currentSchema
   assertNoException "checkDatabaseAllowUnknownTables runs fine \
                     \for consistent DB" $
-    checkDatabaseAllowUnknownTables extrasOptions [] [] currentSchema
+    checkDatabaseAllowUnknownObjects extrasOptions [composite] [] currentSchema
+  assertNoException "checkDatabaseAllowUnknownTables runs fine \
+                    \for consistent DB with unknown composite type in the database" $
+    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
 
@@ -860,14 +878,16 @@ testCaseSteps' testName connSource f =
   let step s = liftIO $ step' s
   withSimpleStdOutLogger $ \logger ->
     runLogT "hpqtypes-extras-test" logger $
-    runDBT connSource {- transactionSettings -} def $
+    runDBT connSource defaultTransactionSettings $
     f step
 
 main :: IO ()
 main = do
   defaultMainWithIngredients ings $
     askOption $ \(ConnectionString connectionString) ->
-    let connSettings = def { csConnInfo = T.pack connectionString }
+    let connSettings = defaultConnectionSettings
+          { csConnInfo = T.pack connectionString
+          }
         ConnectionSource connSource = simpleSource connSettings
     in
     testGroup "DB tests" [ migrationTest1 connSource