hpqtypes-extras 1.8.0.0 → 1.9.0.0

raw patch · 6 files changed

+136/−92 lines, 6 filesdep −data-defaultdep ~basedep ~base16-bytestringdep ~bytestringPVP ok

version bump matches the API change (PVP)

Dependencies removed: data-default

Dependency ranges changed: base, base16-bytestring, bytestring, containers, cryptohash, exceptions, fields-json, hpqtypes, lifted-base, log-base, monad-control, mtl, safe, semigroups, text, text-show

API changes (from Hackage documentation)

Files

• CHANGELOG.md +9/−1
• hpqtypes-extras.cabal +17/−18
• src/Database/PostgreSQL/PQTypes/Checks.hs +42/−21
• src/Database/PostgreSQL/PQTypes/ExtrasOptions.hs +11/−9
• src/Database/PostgreSQL/PQTypes/Migrate.hs +1/−1
• test/Main.hs +56/−42

@@ -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)

@@ -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

@@ -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

@@ -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+  }

@@ -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

@@ -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