hpqtypes-extras 1.5.0.1 → 1.6.0.0

raw patch · 7 files changed

+158/−43 lines, 7 filesdep +data-defaultPVP ok

version bump matches the API change (PVP)

Dependencies added: data-default

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• hpqtypes-extras.cabal +3/−1
• src/Database/PostgreSQL/PQTypes/Checks.hs +21/−15
• src/Database/PostgreSQL/PQTypes/Checks/Util.hs +29/−0
• src/Database/PostgreSQL/PQTypes/ExtrasOptions.hs +16/−0
• src/Database/PostgreSQL/PQTypes/Migrate.hs +0/−4
• test/Main.hs +85/−23

@@ -1,3 +1,7 @@+# hpqtypes-extras-1.6.0.0 (2018-01-25)+* Introduce `checkPKPresence` to enforce primary keys on all tables supplied to `checkDatabase`+* Introduce an options data type, `ExtrasOptions`+ # hpqtypes-extras-1.5.0.1 (2018-01-09) * Changed `getDBTableNames` to only schemas explicitly in search path, rather   than an exclusion list. Affects table version and unknown tables checks.

@@ -1,5 +1,5 @@ name:                hpqtypes-extras-version:             1.5.0.1+version:             1.6.0.0 synopsis:            Extra utilities for hpqtypes library description:         The following extras for hpqtypes library:                      .@@ -32,6 +32,7 @@   ghc-options: -Wall    exposed-modules: Database.PostgreSQL.PQTypes.Checks+                 , Database.PostgreSQL.PQTypes.ExtrasOptions                  , Database.PostgreSQL.PQTypes.Migrate                  , Database.PostgreSQL.PQTypes.Model                  , Database.PostgreSQL.PQTypes.Model.Check@@ -54,6 +55,7 @@                , bytestring                , containers                , cryptohash+               , data-default                , exceptions                , fields-json                , hpqtypes >= 1.5.0

@@ -5,8 +5,10 @@   , createTable   , createDomain +  -- * Options+  , ExtrasOptions(..)+   -- * Migrations-  , MigrateOptions(..)   , migrateDatabase   ) where @@ -28,6 +30,7 @@ import qualified Data.List as L import qualified Data.Text as T +import Database.PostgreSQL.PQTypes.ExtrasOptions import Database.PostgreSQL.PQTypes.Checks.Util import Database.PostgreSQL.PQTypes.Migrate import Database.PostgreSQL.PQTypes.Model@@ -43,15 +46,15 @@ -- | Run migrations and check the database structure. migrateDatabase   :: (MonadDB m, MonadLog m, MonadThrow m)-  => [MigrateOptions] -> [Extension] -> [Domain] -> [Table] -> [Migration m]+  => ExtrasOptions -> [Extension] -> [Domain] -> [Table] -> [Migration m]   -> m ()-migrateDatabase options extensions domains tables migrations = do+migrateDatabase options@ExtrasOptions{..} extensions domains tables migrations = do   setDBTimeZoneToUTC   mapM_ checkExtension extensions   -- 'checkDBConsistency' also performs migrations.   checkDBConsistency options domains (tableVersions : tables) migrations   resultCheck =<< checkDomainsStructure domains-  resultCheck =<< checkDBStructure (tableVersions : tables)+  resultCheck =<< checkDBStructure options (tableVersions : tables)   resultCheck =<< checkTablesWereDropped migrations   resultCheck =<< checkUnknownTables tables   resultCheck =<< checkExistenceOfVersionsForTables (tableVersions : tables)@@ -63,25 +66,25 @@ -- needs to be migrated. Will do a full check of DB structure. checkDatabase   :: forall m . (MonadDB m, MonadLog m, MonadThrow m)-  => [Domain] -> [Table] -> m ()-checkDatabase = checkDatabase_ False+  => ExtrasOptions -> [Domain] -> [Table] -> m ()+checkDatabase options = checkDatabase_ options False  -- | Same as 'checkDatabase', but will not failed if there are -- additional tables in database. checkDatabaseAllowUnknownTables   :: forall m . (MonadDB m, MonadLog m, MonadThrow m)-  => [Domain] -> [Table] -> m ()-checkDatabaseAllowUnknownTables = checkDatabase_ True+  => ExtrasOptions -> [Domain] -> [Table] -> m ()+checkDatabaseAllowUnknownTables options = checkDatabase_ options True  checkDatabase_   :: forall m . (MonadDB m, MonadLog m, MonadThrow m)-  => Bool -> [Domain] -> [Table] -> m ()-checkDatabase_ allowUnknownTables domains tables = do+  => ExtrasOptions -> Bool -> [Domain] -> [Table] -> m ()+checkDatabase_ options allowUnknownTables domains tables = do   tablesWithVersions <- getTableVersions tables    resultCheck $ checkVersions tablesWithVersions   resultCheck =<< checkDomainsStructure domains-  resultCheck =<< checkDBStructure (tableVersions : tables)+  resultCheck =<< checkDBStructure options (tableVersions : tables)   when (not $ allowUnknownTables) $ do     resultCheck =<< checkUnknownTables tables     resultCheck =<< checkExistenceOfVersionsForTables (tableVersions : tables)@@ -274,8 +277,8 @@  -- | Checks whether database is consistent. checkDBStructure :: forall m. (MonadDB m, MonadThrow m)-                 => [Table] -> m ValidationResult-checkDBStructure tables = fmap mconcat . forM tables $ \table ->+                 => ExtrasOptions -> [Table] -> m ValidationResult+checkDBStructure options tables = fmap mconcat . forM tables $ \table ->   -- final checks for table structure, we do this   -- both when creating stuff and when migrating   topMessage "table" (tblNameText table) <$> checkTableStructure table@@ -381,6 +384,9 @@         checkPrimaryKey mdef mpk = mconcat [             checkEquality "PRIMARY KEY" def (map fst pk)           , checkNames (const (pkName tblName)) pk+          , if (eoEnforcePKs options)+            then checkPKPresence tblName mdef mpk+            else mempty           ]           where             def = maybeToList mdef@@ -416,7 +422,7 @@ --     the 'tables' list checkDBConsistency   :: forall m. (MonadDB m, MonadLog m, MonadThrow m)-  => [MigrateOptions] -> [Domain] -> [Table] -> [Migration m]+  => ExtrasOptions -> [Domain] -> [Table] -> [Migration m]   -> m () checkDBConsistency options domains tables migrations = do   -- Check the validity of the migrations list.@@ -639,7 +645,7 @@         forM_ migrationsToRun $ \mgr -> do           runMigration mgr -          when (ForceCommitAfterEveryMigration `elem` options) $ do+          when (eoForceCommit options) $ do             logInfo_ $ "Forcing commit after migraton"               <> " and starting new transaction..."             commit

@@ -6,6 +6,7 @@   tblNameString,   checkEquality,   checkNames,+  checkPKPresence,   tableHasLess,   tableHasMore,   arrListTable@@ -84,6 +85,34 @@           , unRawSQL name           , ")."           ]]++-- | Check presence of primary key on the named table. We cover all the cases so+-- this could be used standalone, but note that the those where the table source+-- definition and the table in the database differ in this respect is also+-- covered by @checkEquality@.+checkPKPresence :: RawSQL ()+                -- ^ The name of the table to check for presence of primary key+              -> Maybe PrimaryKey+                -- ^ A possible primary key gotten from the table data structure+              -> Maybe (PrimaryKey, RawSQL ())+                -- ^ A possible primary key as retrieved from database along+                -- with its name+              -> ValidationResult+checkPKPresence tableName mdef mpk =+  case (mdef, mpk) of+    (Nothing, Nothing) -> valRes [noSrc, noTbl]+    (Nothing, Just _)  -> valRes [noSrc]+    (Just _, Nothing)  -> valRes [noTbl]+    _                  -> mempty+  where+    noSrc = "no source definition"+    noTbl = "no table definition"+    valRes msgs =+        ValidationResult [+          mconcat [ "Table ", unRawSQL tableName+                  , " has no primary key defined "+                  , " (" <> (mintercalate ", " msgs) <> ")"]]+  tableHasLess :: Show t => Text -> t -> Text tableHasLess ptype missing =

@@ -0,0 +1,16 @@+module Database.PostgreSQL.PQTypes.ExtrasOptions (+  ExtrasOptions(..)+  ) where+import Data.Default++data ExtrasOptions =+    ExtrasOptions+    {+      eoForceCommit :: Bool+    -- ^ Force commit after every migration+    , eoEnforcePKs :: Bool+    -- ^ Validate that every handled table has a primary key+    } deriving Eq++instance Default ExtrasOptions where+    def = ExtrasOptions False False

@@ -1,5 +1,4 @@ module Database.PostgreSQL.PQTypes.Migrate (-  MigrateOptions(..),   createDomain,   createTable,   createTableConstraints@@ -12,9 +11,6 @@ import Database.PostgreSQL.PQTypes.Checks.Util import Database.PostgreSQL.PQTypes.Model import Database.PostgreSQL.PQTypes.SQL.Builder--data MigrateOptions = ForceCommitAfterEveryMigration-  deriving Eq  createDomain :: MonadDB m => Domain -> m () createDomain dom@Domain{..} = do

@@ -397,14 +397,41 @@                     , dropTableMigration tableFlash                     ] +schema6Tables :: [Table]+schema6Tables =+          [ tableBankSchema1+          , tableBadGuySchema1+          , tableRobberySchema1+          , tableParticipatedInRobberySchema1+              { tblVersion = (tblVersion tableParticipatedInRobberySchema1) + 1,+                tblPrimaryKey = Nothing }+          , tableWitnessSchema1+          , tableWitnessedRobberySchema1+          ]++schema6Migrations :: (MonadDB m) => Migration m+schema6Migrations =+    Migration+    {+      mgrTableName = tblName tableParticipatedInRobberySchema1+    , mgrFrom = tblVersion tableParticipatedInRobberySchema1+    , mgrAction = StandardMigration $ do+                    runQuery_ $ ("ALTER TABLE participated_in_robbery DROP CONSTRAINT " <>+                                 "pk__participated_in_robbery" :: RawSQL ())+    }++ type TestM a = DBT (LogT IO) a  createTablesSchema1 :: (String -> TestM ()) -> TestM () createTablesSchema1 step = do+  let extrasOptions = def+      extensions    = []+      domains       = []   step "Creating the database (schema version 1)..."-  migrateDatabase {- options -} [] {- extensions -} [] {- domains -} []+  migrateDatabase extrasOptions extensions domains     schema1Tables schema1Migrations-  checkDatabase {- domains -} [] schema1Tables+  checkDatabase extrasOptions domains schema1Tables  testDBSchema1 :: (String -> TestM ()) -> TestM ([Int64], [Int64]) testDBSchema1 step = do@@ -488,18 +515,24 @@  migrateDBToSchema2 :: (String -> TestM ()) -> TestM () migrateDBToSchema2 step = do+  let extrasOptions = def+      extensions    = []+      domains       = []   step "Migrating the database (schema version 1 -> schema version 2)..."-  migrateDatabase {- options -} [] {- extensions -} [] {- domains -} []+  migrateDatabase extrasOptions extensions domains     schema2Tables schema2Migrations-  checkDatabase {- domains -} [] schema2Tables+  checkDatabase extrasOptions domains schema2Tables  -- | Hacky version of 'migrateDBToSchema2' used by 'migrationTest3'. migrateDBToSchema2Hacky :: (String -> TestM ()) -> TestM () migrateDBToSchema2Hacky step = do+  let extrasOptions = def+      extensions    = []+      domains       = []   step "Hackily migrating the database (schema version 1 -> schema version 2)..."-  migrateDatabase {- options -} [] {- extensions -} [] {- domains -} []+  migrateDatabase extrasOptions extensions domains     schema2Tables schema2Migrations'-  checkDatabase {- domains -} [] schema2Tables+  checkDatabase extrasOptions domains schema2Tables     where       schema2Migrations' = createTableMigration tableFlash : schema2Migrations @@ -541,10 +574,13 @@  migrateDBToSchema3 :: (String -> TestM ()) -> TestM () migrateDBToSchema3 step = do+  let extrasOptions = def+      extensions    = []+      domains       = []   step "Migrating the database (schema version 2 -> schema version 3)..."-  migrateDatabase {- options -} [] {- extensions -} [] {- domains -} []+  migrateDatabase extrasOptions extensions domains     schema3Tables schema3Migrations-  checkDatabase {- domains -} [] schema3Tables+  checkDatabase extrasOptions domains schema3Tables  testDBSchema3 :: (String -> TestM ()) -> [Int64] -> [Int64] -> TestM () testDBSchema3 step badGuyIds robberyIds = do@@ -589,10 +625,13 @@  migrateDBToSchema4 :: (String -> TestM ()) -> TestM () migrateDBToSchema4 step = do+  let extrasOptions = def+      extensions    = []+      domains       = []   step "Migrating the database (schema version 3 -> schema version 4)..."-  migrateDatabase {- options -} [] {- extensions -} [] {- domains -} []+  migrateDatabase extrasOptions extensions domains     schema4Tables schema4Migrations-  checkDatabase {- domains -} [] schema4Tables+  checkDatabase extrasOptions domains schema4Tables  testDBSchema4 :: (String -> TestM ()) -> TestM () testDBSchema4 step = do@@ -611,10 +650,13 @@  migrateDBToSchema5 :: (String -> TestM ()) -> TestM () migrateDBToSchema5 step = do+  let extrasOptions = def+      extensions    = []+      domains       = []   step "Migrating the database (schema version 4 -> schema version 5)..."-  migrateDatabase {- options -} [] {- extensions -} [] {- domains -} []+  migrateDatabase extrasOptions extensions domains     schema5Tables schema5Migrations-  checkDatabase {- domains -} [] schema5Tables+  checkDatabase extrasOptions domains schema5Tables  testDBSchema5 :: (String -> TestM ()) -> TestM () testDBSchema5 step = do@@ -677,37 +719,57 @@   createTablesSchema1 step   let currentSchema   = schema1Tables       differentSchema = schema5Tables-+      extrasOptions = def { eoEnforcePKs = True }   assertNoException "checkDatabase should run fine for consistent DB" $-    checkDatabase [] currentSchema+    checkDatabase extrasOptions [] currentSchema   assertNoException "checkDatabaseAllowUnknownTables runs fine for consistent DB" $-    checkDatabaseAllowUnknownTables [] currentSchema+    checkDatabaseAllowUnknownTables extrasOptions [] currentSchema   assertException "checkDatabase should throw exception for wrong scheme" $-    checkDatabase [] differentSchema+    checkDatabase extrasOptions [] differentSchema   assertException ("checkDatabaseAllowUnknownTables "                    ++ "should throw exception for wrong scheme") $-    checkDatabaseAllowUnknownTables [] differentSchema+    checkDatabaseAllowUnknownTables extrasOptions [] differentSchema    runSQL_ "INSERT INTO table_versions (name, version) VALUES ('unknown_table', 0)"   assertException "checkDatabase throw when extra entry in 'table_versions'" $-    checkDatabase [] currentSchema+    checkDatabase extrasOptions [] currentSchema   assertNoException ("checkDatabaseAllowUnknownTables "                      ++ "accepts extra entry in 'table_versions'") $-    checkDatabaseAllowUnknownTables [] currentSchema+    checkDatabaseAllowUnknownTables 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 [] currentSchema+    checkDatabase extrasOptions [] currentSchema   assertNoException "checkDatabaseAllowUnknownTables accepts unknown table" $-    checkDatabaseAllowUnknownTables [] currentSchema+    checkDatabaseAllowUnknownTables extrasOptions [] currentSchema    runSQL_ "INSERT INTO table_versions (name, version) VALUES ('unknown_table', 0)"   assertException "checkDatabase should throw with unknown table" $-    checkDatabase [] currentSchema+    checkDatabase extrasOptions [] currentSchema   assertNoException ("checkDatabaseAllowUnknownTables "                      ++ "accepts unknown tables with version") $-    checkDatabaseAllowUnknownTables [] currentSchema+    checkDatabaseAllowUnknownTables extrasOptions [] currentSchema++  freshTestDB    step++  let schema1TablesWithMissingPK = schema6Tables+      schema1MigrationsWithMissingPK = schema6Migrations+      withMissingPKSchema = schema1TablesWithMissingPK+      optionsNoPKCheck = def { eoEnforcePKs = False }+      optionsWithPKCheck = def { eoEnforcePKs = True }++  step "Recreating the database (schema version 1, one table is missing PK)..."++  migrateDatabase optionsNoPKCheck [] [] schema1TablesWithMissingPK [schema1MigrationsWithMissingPK]+  checkDatabase optionsNoPKCheck [] withMissingPKSchema++  assertException ("checkDatabase should throw when PK missing from table " <>+                   "'participated_in_robbery' and check is enabled") $+    checkDatabase optionsWithPKCheck [] withMissingPKSchema+  assertNoException ("checkDatabase should not throw when PK missing from table " <>+                     "'participated_in_robbery' and check is disabled") $+    checkDatabase optionsNoPKCheck [] withMissingPKSchema    freshTestDB step