diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,7 +1,15 @@ +# hpqtypes-extras-1.9.0.0 (2019-05-22) +* Extend `checkDatabaseAllowUnknownTables` to allow unknown composite + types and rename it to `checkDatabaseAllowUnknownObjects` + ([#22](https://github.com/scrive/hpqtypes-extras/pull/22)). +* Remove the `Default` instance for `ExtrasOptions`; use + `defaultExtrasOptions` instead + ([#23](https://github.com/scrive/hpqtypes-extras/pull/23)). + # 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)). -* Add migration type for concurrent creation of an index +* Add a migration type for concurrent creation of an index ([#21](https://github.com/scrive/hpqtypes-extras/pull/21)). # hpqtypes-extras-1.7.1.0 (2019-02-04) diff --git a/hpqtypes-extras.cabal b/hpqtypes-extras.cabal --- 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: . @@ -50,23 +50,22 @@ other-modules: Database.PostgreSQL.PQTypes.Checks.Util , Database.PostgreSQL.PQTypes.Utils.NubList - build-depends: base > 4 && < 4.13 - , hpqtypes >= 1.6.0.0 - , base16-bytestring - , bytestring - , containers - , cryptohash - , data-default - , exceptions - , fields-json - , lifted-base - , log-base >= 0.7 - , monad-control >= 1.0.0.0 - , mtl - , safe - , semigroups >= 0.16 - , text - , text-show + build-depends: base >= 4.9 && < 4.13 + , hpqtypes >= 1.7.0.0 && < 1.8.0.0 + , base16-bytestring >= 0.1 && < 0.2 + , bytestring >= 0.10 && < 0.11 + , containers >= 0.5 && < 0.7 + , cryptohash >= 0.11 && < 0.12 + , exceptions >= 0.10 && < 0.11 + , mtl >= 2.2 && < 2.3 + , fields-json >= 0.2 && < 0.3 + , text >= 1.2 && < 1.3 + , lifted-base >= 0.2 && < 0.3 + , monad-control >= 1.0 && < 1.1 + , semigroups >= 0.16 && < 0.20 + , text-show >= 3.8 && < 3.9 + , log-base >= 0.8 && < 0.9 + , safe >= 0.3 && < 0.4 default-language: Haskell2010 default-extensions: BangPatterns 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,12 +1,13 @@ module Database.PostgreSQL.PQTypes.Checks ( -- * Checks checkDatabase - , checkDatabaseAllowUnknownTables + , checkDatabaseAllowUnknownObjects , createTable , createDomain -- * Options , ExtrasOptions(..) + , defaultExtrasOptions -- * Migrations , migrateDatabase @@ -24,7 +25,7 @@ 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 @@ -57,14 +58,16 @@ -> [Table] -> [Migration m] -> m () -migrateDatabase options@ExtrasOptions{..} +migrateDatabase options extensions composites domains tables migrations = do setDBTimeZoneToUTC mapM_ checkExtension extensions 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 +82,33 @@ 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 +318,23 @@ <> "' 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 +353,13 @@ 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/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,16 +1,18 @@ -module Database.PostgreSQL.PQTypes.ExtrasOptions ( - ExtrasOptions(..) +module Database.PostgreSQL.PQTypes.ExtrasOptions + ( ExtrasOptions(..) + , defaultExtrasOptions ) where -import Data.Default data ExtrasOptions = ExtrasOptions - { - eoForceCommit :: Bool - -- ^ Force commit after every migration + { eoForceCommit :: Bool + -- ^ Force commit after every migration , eoEnforcePKs :: Bool - -- ^ Validate that every handled table has a primary key + -- ^ Validate that every handled table has a primary key } deriving Eq -instance Default ExtrasOptions where - def = ExtrasOptions False False +defaultExtrasOptions :: ExtrasOptions +defaultExtrasOptions = ExtrasOptions + { eoForceCommit = False + , eoEnforcePKs = False + } diff --git a/src/Database/PostgreSQL/PQTypes/Migrate.hs b/src/Database/PostgreSQL/PQTypes/Migrate.hs --- a/src/Database/PostgreSQL/PQTypes/Migrate.hs +++ b/src/Database/PostgreSQL/PQTypes/Migrate.hs @@ -7,7 +7,7 @@ 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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -14,6 +14,7 @@ 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 @@ -437,14 +438,13 @@ createTablesSchema1 :: (String -> TestM ()) -> TestM () createTablesSchema1 step = do - let extrasOptions = def - extensions = [] + let extensions = [] composites = [] domains = [] step "Creating the database (schema version 1)..." - migrateDatabase extrasOptions extensions domains + migrateDatabase defaultExtrasOptions extensions domains composites schema1Tables schema1Migrations - checkDatabase extrasOptions composites domains schema1Tables + checkDatabase defaultExtrasOptions composites domains schema1Tables testDBSchema1 :: (String -> TestM ()) -> TestM ([Int64], [Int64]) testDBSchema1 step = do @@ -528,27 +528,25 @@ migrateDBToSchema2 :: (String -> TestM ()) -> TestM () migrateDBToSchema2 step = do - let extrasOptions = def - extensions = [] + let extensions = [] composites = [] domains = [] step "Migrating the database (schema version 1 -> schema version 2)..." - migrateDatabase extrasOptions extensions composites domains + migrateDatabase defaultExtrasOptions extensions composites domains schema2Tables schema2Migrations - checkDatabase extrasOptions composites domains schema2Tables + checkDatabase defaultExtrasOptions composites domains schema2Tables -- | Hacky version of 'migrateDBToSchema2' used by 'migrationTest3'. migrateDBToSchema2Hacky :: (String -> TestM ()) -> TestM () migrateDBToSchema2Hacky step = do - let extrasOptions = def - extensions = [] + let extensions = [] composites = [] domains = [] step "Hackily migrating the database (schema version 1 \ \-> schema version 2)..." - migrateDatabase extrasOptions extensions composites domains + migrateDatabase defaultExtrasOptions extensions composites domains schema2Tables schema2Migrations' - checkDatabase extrasOptions composites domains schema2Tables + checkDatabase defaultExtrasOptions composites domains schema2Tables where schema2Migrations' = createTableMigration tableFlash : schema2Migrations @@ -590,14 +588,13 @@ migrateDBToSchema3 :: (String -> TestM ()) -> TestM () migrateDBToSchema3 step = do - let extrasOptions = def - extensions = [] + let extensions = [] composites = [] domains = [] step "Migrating the database (schema version 2 -> schema version 3)..." - migrateDatabase extrasOptions extensions composites domains + migrateDatabase defaultExtrasOptions extensions composites domains schema3Tables schema3Migrations - checkDatabase extrasOptions composites domains schema3Tables + checkDatabase defaultExtrasOptions composites domains schema3Tables testDBSchema3 :: (String -> TestM ()) -> [Int64] -> [Int64] -> TestM () testDBSchema3 step badGuyIds robberyIds = do @@ -642,14 +639,13 @@ migrateDBToSchema4 :: (String -> TestM ()) -> TestM () migrateDBToSchema4 step = do - let extrasOptions = def - extensions = [] + let extensions = [] composites = [] domains = [] step "Migrating the database (schema version 3 -> schema version 4)..." - migrateDatabase extrasOptions extensions composites domains + migrateDatabase defaultExtrasOptions extensions composites domains schema4Tables schema4Migrations - checkDatabase extrasOptions composites domains schema4Tables + checkDatabase defaultExtrasOptions composites domains schema4Tables testDBSchema4 :: (String -> TestM ()) -> TestM () testDBSchema4 step = do @@ -668,14 +664,13 @@ migrateDBToSchema5 :: (String -> TestM ()) -> TestM () migrateDBToSchema5 step = do - let extrasOptions = def - extensions = [] + let extensions = [] composites = [] domains = [] step "Migrating the database (schema version 4 -> schema version 5)..." - migrateDatabase extrasOptions extensions composites domains + migrateDatabase defaultExtrasOptions extensions composites domains schema5Tables schema5Migrations - checkDatabase extrasOptions composites domains schema5Tables + checkDatabase defaultExtrasOptions composites domains schema5Tables testDBSchema5 :: (String -> TestM ()) -> TestM () testDBSchema5 step = do @@ -735,57 +730,75 @@ 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 } + extrasOptions = defaultExtrasOptions { 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 - let schema1TablesWithMissingPK = schema6Tables + let schema1TablesWithMissingPK = schema6Tables schema1MigrationsWithMissingPK = schema6Migrations - withMissingPKSchema = schema1TablesWithMissingPK - optionsNoPKCheck = def { eoEnforcePKs = False } - optionsWithPKCheck = def { eoEnforcePKs = True } + withMissingPKSchema = schema1TablesWithMissingPK + optionsNoPKCheck = defaultExtrasOptions + { eoEnforcePKs = False } + optionsWithPKCheck = defaultExtrasOptions + { eoEnforcePKs = True } step "Recreating the database (schema version 1, one table is missing PK)..." @@ -860,14 +873,15 @@ 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