diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/hpqtypes-extras.cabal b/hpqtypes-extras.cabal --- a/hpqtypes-extras.cabal +++ b/hpqtypes-extras.cabal @@ -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 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 @@ -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 diff --git a/src/Database/PostgreSQL/PQTypes/Checks/Util.hs b/src/Database/PostgreSQL/PQTypes/Checks/Util.hs --- a/src/Database/PostgreSQL/PQTypes/Checks/Util.hs +++ b/src/Database/PostgreSQL/PQTypes/Checks/Util.hs @@ -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 = diff --git a/src/Database/PostgreSQL/PQTypes/ExtrasOptions.hs b/src/Database/PostgreSQL/PQTypes/ExtrasOptions.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/PQTypes/ExtrasOptions.hs @@ -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 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 @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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