From 172aa249b8351ac8b685d7540aa9b9f3e29d3283 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20Jano=C5=A1=C3=ADk?= Date: Wed, 8 Jan 2025 20:37:07 +0100 Subject: [PATCH] Rudimentary enum support --- .stylish-haskell.yaml | 203 --------------- CHANGELOG.md | 3 + hpqtypes-extras.cabal | 1 + src/Database/PostgreSQL/PQTypes/Checks.hs | 177 +++++++++---- .../PostgreSQL/PQTypes/Checks/Util.hs | 5 + src/Database/PostgreSQL/PQTypes/Model.hs | 2 + .../PostgreSQL/PQTypes/Model/EnumType.hs | 32 +++ .../PostgreSQL/PQTypes/Model/Migration.hs | 5 +- test/Main.hs | 246 +++++++++--------- 9 files changed, 299 insertions(+), 375 deletions(-) delete mode 100644 .stylish-haskell.yaml create mode 100644 src/Database/PostgreSQL/PQTypes/Model/EnumType.hs diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml deleted file mode 100644 index ea2084c..0000000 --- a/.stylish-haskell.yaml +++ /dev/null @@ -1,203 +0,0 @@ -# stylish-haskell configuration file -# ================================== - -# The stylish-haskell tool is mainly configured by specifying steps. These steps -# are a list, so they have an order, and one specific step may appear more than -# once (if needed). Each file is processed by these steps in the given order. -steps: - # Convert some ASCII sequences to their Unicode equivalents. This is disabled - # by default. - # - unicode_syntax: - # # In order to make this work, we also need to insert the UnicodeSyntax - # # language pragma. If this flag is set to true, we insert it when it's - # # not already present. You may want to disable it if you configure - # # language extensions using some other method than pragmas. Default: - # # true. - # add_language_pragma: true - - # Align the right hand side of some elements. This is quite conservative - # and only applies to statements where each element occupies a single - # line. - - simple_align: - cases: true - top_level_patterns: true - records: true - - # Import cleanup - - imports: - # There are different ways we can align names and lists. - # - # - global: Align the import names and import list throughout the entire - # file. - # - # - file: Like global, but don't add padding when there are no qualified - # imports in the file. - # - # - group: Only align the imports per group (a group is formed by adjacent - # import lines). - # - # - none: Do not perform any alignment. - # - # Default: global. - align: none - - # Folowing options affect only import list alignment. - # - # List align has following options: - # - # - after_alias: Import list is aligned with end of import including - # 'as' and 'hiding' keywords. - # - # > import qualified Data.List as List (concat, foldl, foldr, head, - # > init, last, length) - # - # - with_alias: Import list is aligned with start of alias or hiding. - # - # > import qualified Data.List as List (concat, foldl, foldr, head, - # > init, last, length) - # - # - new_line: Import list starts always on new line. - # - # > import qualified Data.List as List - # > (concat, foldl, foldr, head, init, last, length) - # - # Default: after_alias - list_align: after_alias - - # Long list align style takes effect when import is too long. This is - # determined by 'columns' setting. - # - # - inline: This option will put as much specs on same line as possible. - # - # - new_line: Import list will start on new line. - # - # - new_line_multiline: Import list will start on new line when it's - # short enough to fit to single line. Otherwise it'll be multiline. - # - # - multiline: One line per import list entry. - # Type with contructor list acts like single import. - # - # > import qualified Data.Map as M - # > ( empty - # > , singleton - # > , ... - # > , delete - # > ) - # - # Default: inline - long_list_align: inline - - # Align empty list (importing instances) - # - # Empty list align has following options - # - # - inherit: inherit list_align setting - # - # - right_after: () is right after the module name: - # - # > import Vector.Instances () - # - # Default: inherit - empty_list_align: inherit - - # List padding determines indentation of import list on lines after import. - # This option affects 'long_list_align'. - # - # - : constant value - # - # - module_name: align under start of module name. - # Useful for 'file' and 'group' align settings. - list_padding: 4 - - # Separate lists option affects formating of import list for type - # or class. The only difference is single space between type and list - # of constructors, selectors and class functions. - # - # - true: There is single space between Foldable type and list of it's - # functions. - # - # > import Data.Foldable (Foldable (fold, foldl, foldMap)) - # - # - false: There is no space between Foldable type and list of it's - # functions. - # - # > import Data.Foldable (Foldable(fold, foldl, foldMap)) - # - # Default: true - separate_lists: true - - # Language pragmas - - language_pragmas: - # We can generate different styles of language pragma lists. - # - # - vertical: Vertical-spaced language pragmas, one per line. - # - # - compact: A more compact style. - # - # - compact_line: Similar to compact, but wrap each line with - # `{-#LANGUAGE #-}'. - # - # Default: vertical. - style: vertical - - # Align affects alignment of closing pragma brackets. - # - # - true: Brackets are aligned in same collumn. - # - # - false: Brackets are not aligned together. There is only one space - # between actual import and closing bracket. - # - # Default: true - align: true - - # stylish-haskell can detect redundancy of some language pragmas. If this - # is set to true, it will remove those redundant pragmas. Default: true. - remove_redundant: true - - # Replace tabs by spaces. This is disabled by default. - # - tabs: - # # Number of spaces to use for each tab. Default: 8, as specified by the - # # Haskell report. - # spaces: 8 - - # Remove trailing whitespace - - trailing_whitespace: {} - -# A common setting is the number of columns (parts of) code will be wrapped -# to. Different steps take this into account. Default: 80. -columns: 80 - -# By default, line endings are converted according to the OS. You can override -# preferred format here. -# -# - native: Native newline format. CRLF on Windows, LF on other OSes. -# -# - lf: Convert to LF ("\n"). -# -# - crlf: Convert to CRLF ("\r\n"). -# -# Default: native. -newline: native - -# Sometimes, language extensions are specified in a cabal file or from the -# command line instead of using language pragmas in the file. stylish-haskell -# needs to be aware of these, so it can parse the file correctly. -# -# No language extensions are enabled by default. -language_extensions: - - BangPatterns - - DeriveDataTypeable - - ExistentialQuantification - - FlexibleContexts - - GeneralizedNewtypeDeriving - - LambdaCase - - MultiWayIf - - MultiParamTypeClasses - - OverloadedStrings - - RankNTypes - - RecordWildCards - - ScopedTypeVariables - - StandaloneDeriving - - TupleSections - - TypeFamilies - - UndecidableInstances diff --git a/CHANGELOG.md b/CHANGELOG.md index c20ca35..8a9f072 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,9 +1,12 @@ # hpqtypes-extras-1.17.0.0 (2023-??-??) +* Grouped some parameters of `migrateDatabase` and `checkDatabase` into a + `DatabaseDefinitions` record type. * Add an optional check that all foreign keys have an index. * Add support for NULLS NOT DISTINCT in unique indexes. * Add `sqlAll` and `sqlAny` to allow creating `SQL` expressions with nested `AND` and `OR` conditions. * Add `SqlWhereAll` and `SqlWhereAny` so they can be used in signatures. +* Add rudimentary support for enum types. # hpqtypes-extras-1.16.4.4 (2023-08-23) * Switch from `cryptonite` to `crypton`. diff --git a/hpqtypes-extras.cabal b/hpqtypes-extras.cabal index 549a216..2c42d20 100644 --- a/hpqtypes-extras.cabal +++ b/hpqtypes-extras.cabal @@ -64,6 +64,7 @@ library , Database.PostgreSQL.PQTypes.Model.ColumnType , Database.PostgreSQL.PQTypes.Model.CompositeType , Database.PostgreSQL.PQTypes.Model.Domain + , Database.PostgreSQL.PQTypes.Model.EnumType , Database.PostgreSQL.PQTypes.Model.Extension , Database.PostgreSQL.PQTypes.Model.ForeignKey , Database.PostgreSQL.PQTypes.Model.Index diff --git a/src/Database/PostgreSQL/PQTypes/Checks.hs b/src/Database/PostgreSQL/PQTypes/Checks.hs index eb6f122..398a6c9 100644 --- a/src/Database/PostgreSQL/PQTypes/Checks.hs +++ b/src/Database/PostgreSQL/PQTypes/Checks.hs @@ -1,6 +1,11 @@ module Database.PostgreSQL.PQTypes.Checks - ( -- * Checks - checkDatabase + ( -- * Definitions + DatabaseDefinitions (..) + , emptyDbDefinitions + + -- * Checks + , checkDatabase + , checkDatabaseWithReport , createTable , createDomain @@ -11,13 +16,19 @@ module Database.PostgreSQL.PQTypes.Checks -- * Migrations , migrateDatabase + + -- * Internals for tests + , ValidationResult + , validationError + , validationInfo ) where import Control.Arrow ((&&&)) import Control.Concurrent (threadDelay) import Control.Monad import Control.Monad.Catch -import Control.Monad.Reader +import Control.Monad.Except +import Control.Monad.Writer as W import Data.Foldable (foldMap') import Data.Function import Data.Int @@ -47,36 +58,48 @@ headExc :: String -> [a] -> a headExc s [] = error s headExc _ (x : _) = x +data DatabaseDefinitions = DatabaseDefinitions + { dbExtensions :: [Extension] + , dbComposites :: [CompositeType] + , dbEnums :: [EnumType] + , dbDomains :: [Domain] + , dbTables :: [Table] + } + +emptyDbDefinitions :: DatabaseDefinitions +emptyDbDefinitions = DatabaseDefinitions [] [] [] [] [] + ---------------------------------------- -- | Run migrations and check the database structure. migrateDatabase :: (MonadIO m, MonadDB m, MonadLog m, MonadMask m) => ExtrasOptions - -> [Extension] - -> [CompositeType] - -> [Domain] - -> [Table] + -> DatabaseDefinitions -> [Migration m] -> m () migrateDatabase options - extensions - composites - domains - tables + DatabaseDefinitions + { dbExtensions = extensions + , dbComposites = composites + , dbEnums = enums + , dbDomains = domains + , dbTables = tables + } migrations = do setDBTimeZoneToUTC mapM_ checkExtension extensions tablesWithVersions <- getTableVersions (tableVersions : tables) -- 'checkDBConsistency' also performs migrations. - checkDBConsistency options domains tablesWithVersions migrations + checkDBConsistency options domains enums tablesWithVersions migrations resultCheck =<< checkCompositesStructure tablesWithVersions CreateCompositesIfDatabaseEmpty (eoObjectsValidationMode options) composites + resultCheck =<< checkEnumTypes enums resultCheck =<< checkDomainsStructure domains resultCheck =<< checkDBStructure options tablesWithVersions resultCheck =<< checkTablesWereDropped migrations @@ -93,47 +116,66 @@ migrateDatabase -- | Run checks on the database structure and whether the database needs to be -- migrated. Will do a full check of DB structure. +checkDatabaseWithReport + :: forall m + . (MonadDB m, MonadLog m, MonadThrow m) + => ExtrasOptions + -> DatabaseDefinitions + -> m ValidationResult +checkDatabaseWithReport + options + DatabaseDefinitions + { dbExtensions = _ -- We currently don't check extensions + , dbComposites = composites + , dbEnums = enums + , dbDomains = domains + , dbTables = tables + } = execWriterT $ do + (_, report) <- W.listen $ do + tablesWithVersions <- getTableVersions (tableVersions : tables) + tell $ checkVersions options tablesWithVersions + tell + =<< checkCompositesStructure + tablesWithVersions + DontCreateComposites + (eoObjectsValidationMode options) + composites + tell =<< checkEnumTypes enums + tell =<< checkDomainsStructure domains + tell =<< checkDBStructure options tablesWithVersions + when (eoObjectsValidationMode options == DontAllowUnknownObjects) $ do + tell =<< checkUnknownTables tables + tell =<< checkExistenceOfVersionsForTables (tableVersions : tables) + + -- Check initial setups only after database structure is considered + -- consistent as before that some of the checks may fail internally. + unless (resultHasErrors report) $ + tell =<< lift (checkInitialSetups tables) + where + checkInitialSetups :: [Table] -> m ValidationResult + checkInitialSetups = fmap mconcat . mapM checkInitialSetup' + + checkInitialSetup' :: Table -> m ValidationResult + checkInitialSetup' t@Table {..} = case tblInitialSetup of + Nothing -> return mempty + Just is -> + checkInitialSetup is >>= \case + True -> return mempty + False -> + return . validationError $ + "Initial setup for table '" + <> tblNameText t + <> "' is not valid" + +-- | An equivalent to `checkDatabaseWithReport opts dbDefs >>= resultCheck`. checkDatabase :: forall m . (MonadDB m, MonadLog m, MonadThrow m) => ExtrasOptions - -> [CompositeType] - -> [Domain] - -> [Table] + -> DatabaseDefinitions -> m () -checkDatabase options composites domains tables = do - tablesWithVersions <- getTableVersions (tableVersions : tables) - resultCheck $ checkVersions options tablesWithVersions - resultCheck - =<< checkCompositesStructure - tablesWithVersions - DontCreateComposites - (eoObjectsValidationMode options) - composites - resultCheck =<< checkDomainsStructure domains - resultCheck =<< checkDBStructure options tablesWithVersions - when (eoObjectsValidationMode options == DontAllowUnknownObjects) $ do - resultCheck =<< checkUnknownTables tables - resultCheck =<< checkExistenceOfVersionsForTables (tableVersions : tables) - - -- Check initial setups only after database structure is considered - -- consistent as before that some of the checks may fail internally. - resultCheck =<< checkInitialSetups tables - where - checkInitialSetups :: [Table] -> m ValidationResult - checkInitialSetups = fmap mconcat . mapM checkInitialSetup' - - checkInitialSetup' :: Table -> m ValidationResult - checkInitialSetup' t@Table {..} = case tblInitialSetup of - Nothing -> return mempty - Just is -> - checkInitialSetup is >>= \case - True -> return mempty - False -> - return . validationError $ - "Initial setup for table '" - <> tblNameText t - <> "' is not valid" +checkDatabase options dbDefinitions = + checkDatabaseWithReport options dbDefinitions >>= resultCheck -- | Return SQL fragment of current catalog within quotes currentCatalog :: (MonadDB m, MonadThrow m) => m (RawSQL ()) @@ -340,6 +382,40 @@ checkDomainsStructure defs = fmap mconcat . forM defs $ \def -> do <+> T.pack (show $ attr def) <> ")" +checkEnumTypes + :: (MonadDB m, MonadThrow m) + => [EnumType] + -> m ValidationResult +checkEnumTypes defs = fmap mconcat . forM defs $ \def -> do + runQuery_ . sqlSelect "pg_catalog.pg_type t" $ do + sqlResult "t.typname::text" -- name + sqlResult + "ARRAY(SELECT e.enumlabel::text FROM pg_catalog.pg_enum e WHERE e.enumtypid = t.oid ORDER BY e.enumsortorder)" -- values + sqlWhereEq "t.typname" $ unRawSQL $ etName def + enum <- fetchMaybe $ + \(enumName, enumValues) -> + EnumType + { etName = unsafeSQL enumName + , etValues = map unsafeSQL $ unArray1 enumValues + } + return $ case enum of + Just e + | e /= def -> + validationError $ + "Enum '" + <> unRawSQL (etName e) + <> "' does not match (database:" + <+> T.pack (show . map unRawSQL $ etValues e) + <> ", definition:" + <+> T.pack (show . map unRawSQL $ etValues def) + <> ")" + | otherwise -> mempty + Nothing -> + validationError $ + "Enum '" + <> unRawSQL (etName def) + <> "' doesn't exist in the database" + -- | Check that the tables that must have been dropped are actually -- missing from the DB. checkTablesWereDropped @@ -748,10 +824,11 @@ checkDBConsistency . (MonadIO m, MonadDB m, MonadLog m, MonadMask m) => ExtrasOptions -> [Domain] + -> [EnumType] -> TablesWithVersions -> [Migration m] -> m () -checkDBConsistency options domains tablesWithVersions migrations = do +checkDBConsistency options domains enums tablesWithVersions migrations = do autoTransaction <- tsAutoTransaction <$> getTransactionSettings unless autoTransaction $ do error "checkDBConsistency: tsAutoTransaction setting needs to be True" @@ -876,6 +953,8 @@ checkDBConsistency options domains tablesWithVersions migrations = do createDBSchema = do logInfo_ "Creating domains..." mapM_ createDomain domains + logInfo_ "Creating enums..." + mapM_ (runQuery_ . sqlCreateEnum) enums -- Create all tables with no constraints first to allow cyclic references. logInfo_ "Creating tables..." mapM_ (createTable False) tables diff --git a/src/Database/PostgreSQL/PQTypes/Checks/Util.hs b/src/Database/PostgreSQL/PQTypes/Checks/Util.hs index 00f9372..21a776e 100644 --- a/src/Database/PostgreSQL/PQTypes/Checks/Util.hs +++ b/src/Database/PostgreSQL/PQTypes/Checks/Util.hs @@ -7,6 +7,7 @@ module Database.PostgreSQL.PQTypes.Checks.Util , mapValidationResult , validationErrorsToInfos , resultCheck + , resultHasErrors , topMessage , tblNameText , tblNameString @@ -39,6 +40,7 @@ data ValidationResult = ValidationResult { vrInfos :: [Text] , vrErrors :: [Text] } + deriving (Show, Eq) validationError :: Text -> ValidationResult validationError err = mempty {vrErrors = [err]} @@ -79,6 +81,9 @@ topMessage objtype objname vr@ValidationResult {..} = : es ) +resultHasErrors :: ValidationResult -> Bool +resultHasErrors ValidationResult {..} = not $ null vrErrors + -- | Log all messages in a 'ValidationResult', and fail if any of them -- were errors. resultCheck diff --git a/src/Database/PostgreSQL/PQTypes/Model.hs b/src/Database/PostgreSQL/PQTypes/Model.hs index f2569d9..e6c9387 100644 --- a/src/Database/PostgreSQL/PQTypes/Model.hs +++ b/src/Database/PostgreSQL/PQTypes/Model.hs @@ -3,6 +3,7 @@ module Database.PostgreSQL.PQTypes.Model , module Database.PostgreSQL.PQTypes.Model.ColumnType , module Database.PostgreSQL.PQTypes.Model.CompositeType , module Database.PostgreSQL.PQTypes.Model.Domain + , module Database.PostgreSQL.PQTypes.Model.EnumType , module Database.PostgreSQL.PQTypes.Model.Extension , module Database.PostgreSQL.PQTypes.Model.ForeignKey , module Database.PostgreSQL.PQTypes.Model.Index @@ -16,6 +17,7 @@ import Database.PostgreSQL.PQTypes.Model.Check import Database.PostgreSQL.PQTypes.Model.ColumnType import Database.PostgreSQL.PQTypes.Model.CompositeType import Database.PostgreSQL.PQTypes.Model.Domain +import Database.PostgreSQL.PQTypes.Model.EnumType import Database.PostgreSQL.PQTypes.Model.Extension import Database.PostgreSQL.PQTypes.Model.ForeignKey import Database.PostgreSQL.PQTypes.Model.Index diff --git a/src/Database/PostgreSQL/PQTypes/Model/EnumType.hs b/src/Database/PostgreSQL/PQTypes/Model/EnumType.hs new file mode 100644 index 0000000..7f385f5 --- /dev/null +++ b/src/Database/PostgreSQL/PQTypes/Model/EnumType.hs @@ -0,0 +1,32 @@ +module Database.PostgreSQL.PQTypes.Model.EnumType + ( EnumType (..) + , sqlCreateEnum + , sqlDropEnum + ) where + +import Data.Monoid.Utils +import Data.Text qualified as T +import Database.PostgreSQL.PQTypes + +data EnumType = EnumType + { etName :: !(RawSQL ()) + , etValues :: ![RawSQL ()] + } + deriving (Eq, Ord, Show) + +-- | Make SQL query that creates an enum type. +sqlCreateEnum :: EnumType -> RawSQL () +sqlCreateEnum EnumType {..} = + smconcat + [ "CREATE TYPE" + , etName + , "AS ENUM (" + , mintercalate ", " $ map quotedValue etValues + , ")" + ] + where + quotedValue v = rawSQL ("'" <> T.replace "'" "''" (unRawSQL v) <> "'" :: T.Text) () + +-- | Make SQL query that drops a composite type. +sqlDropEnum :: RawSQL () -> RawSQL () +sqlDropEnum = ("DROP TYPE" <+>) diff --git a/src/Database/PostgreSQL/PQTypes/Model/Migration.hs b/src/Database/PostgreSQL/PQTypes/Model/Migration.hs index 87bb063..3e58729 100644 --- a/src/Database/PostgreSQL/PQTypes/Model/Migration.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/Migration.hs @@ -7,13 +7,12 @@ -- 'Database.PostgreSQL.PQTypes.Checks.migrateDatabase': -- -- @ --- tables :: [Table] --- tables = ... +-- definitions = emptyDbDefinitions { ... } -- -- migrations :: [Migration] -- migrations = ... -- --- migrateDatabase options extensions domains tables migrations +-- migrateDatabase options definitions migrations -- @ -- -- Migrations are run strictly in the order specified in the migrations diff --git a/test/Main.hs b/test/Main.hs index 44bb289..fa63fef 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -18,6 +18,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.EnumType import Database.PostgreSQL.PQTypes.Model.ForeignKey import Database.PostgreSQL.PQTypes.Model.Index import Database.PostgreSQL.PQTypes.Model.Migration @@ -596,22 +597,14 @@ type TestM a = DBT (LogT IO) a createTablesSchema1 :: (String -> TestM ()) -> TestM () createTablesSchema1 step = do - let extensions = ["pgcrypto"] - composites = [] - domains = [] + let definitions = tableDefsWithPgCrypto schema1Tables step "Creating the database (schema version 1)..." - migrateDatabase - defaultExtrasOptions - extensions - domains - composites - schema1Tables - schema1Migrations + migrateDatabase defaultExtrasOptions definitions schema1Migrations -- Add a local index that shouldn't trigger validation errors. runSQL_ "CREATE INDEX local_idx_bank_name ON bank(name)" - checkDatabase defaultExtrasOptions composites domains schema1Tables + checkDatabase defaultExtrasOptions definitions testDBSchema1 :: (String -> TestM ()) -> TestM ([UUID], [UUID]) testDBSchema1 step = do @@ -902,36 +895,26 @@ testDBSchema1 step = do migrateDBToSchema2 :: (String -> TestM ()) -> TestM () migrateDBToSchema2 step = do - let extensions = ["pgcrypto"] - composites = [] - domains = [] + let definitions = tableDefsWithPgCrypto schema2Tables step "Migrating the database (schema version 1 -> schema version 2)..." migrateDatabase defaultExtrasOptions {eoLockTimeoutMs = Just 1000} - extensions - composites - domains - schema2Tables + definitions schema2Migrations - checkDatabase defaultExtrasOptions composites domains schema2Tables + checkDatabase defaultExtrasOptions definitions -- | Hacky version of 'migrateDBToSchema2' used by 'migrationTest3'. migrateDBToSchema2Hacky :: (String -> TestM ()) -> TestM () migrateDBToSchema2Hacky step = do - let extensions = ["pgcrypto"] - composites = [] - domains = [] + let definitions = tableDefsWithPgCrypto schema2Tables step "Hackily migrating the database (schema version 1 \ \-> schema version 2)..." migrateDatabase defaultExtrasOptions - extensions - composites - domains - schema2Tables + definitions schema2Migrations' - checkDatabase defaultExtrasOptions composites domains schema2Tables + checkDatabase defaultExtrasOptions definitions where schema2Migrations' = createTableMigration tableFlash : schema2Migrations @@ -984,18 +967,13 @@ testDBSchema2 step badGuyIds robberyIds = do migrateDBToSchema3 :: (String -> TestM ()) -> TestM () migrateDBToSchema3 step = do - let extensions = ["pgcrypto"] - composites = [] - domains = [] + let definitions = tableDefsWithPgCrypto schema3Tables step "Migrating the database (schema version 2 -> schema version 3)..." migrateDatabase defaultExtrasOptions - extensions - composites - domains - schema3Tables + definitions schema3Migrations - checkDatabase defaultExtrasOptions composites domains schema3Tables + checkDatabase defaultExtrasOptions definitions testDBSchema3 :: (String -> TestM ()) -> [UUID] -> [UUID] -> TestM () testDBSchema3 step badGuyIds robberyIds = do @@ -1054,18 +1032,13 @@ testDBSchema3 step badGuyIds robberyIds = do migrateDBToSchema4 :: (String -> TestM ()) -> TestM () migrateDBToSchema4 step = do - let extensions = ["pgcrypto"] - composites = [] - domains = [] + let definitions = tableDefsWithPgCrypto schema4Tables step "Migrating the database (schema version 3 -> schema version 4)..." migrateDatabase defaultExtrasOptions - extensions - composites - domains - schema4Tables + definitions schema4Migrations - checkDatabase defaultExtrasOptions composites domains schema4Tables + checkDatabase defaultExtrasOptions definitions testDBSchema4 :: (String -> TestM ()) -> TestM () testDBSchema4 step = do @@ -1088,18 +1061,10 @@ testDBSchema4 step = do migrateDBToSchema5 :: (String -> TestM ()) -> TestM () migrateDBToSchema5 step = do - let extensions = ["pgcrypto"] - composites = [] - domains = [] + let definitions = tableDefsWithPgCrypto schema5Tables step "Migrating the database (schema version 4 -> schema version 5)..." - migrateDatabase - defaultExtrasOptions - extensions - composites - domains - schema5Tables - schema5Migrations - checkDatabase defaultExtrasOptions composites domains schema5Tables + migrateDatabase defaultExtrasOptions definitions schema5Migrations + checkDatabase defaultExtrasOptions definitions testDBSchema5 :: (String -> TestM ()) -> TestM () testDBSchema5 step = do @@ -1474,8 +1439,9 @@ testTriggers step = do rest migrate tables migrations = do - migrateDatabase defaultExtrasOptions ["pgcrypto"] [] [] tables migrations - checkDatabase defaultExtrasOptions [] [] tables + let definitions = tableDefsWithPgCrypto tables + migrateDatabase defaultExtrasOptions definitions migrations + checkDatabase defaultExtrasOptions definitions -- Verify that the given triggers are (not) present in the database. verify :: (MonadIO m, MonadDB m, HasCallStack) => [Trigger] -> Bool -> m () @@ -1521,8 +1487,9 @@ testSqlWith step = do testPass where migrate tables migrations = do - migrateDatabase defaultExtrasOptions ["pgcrypto"] [] [] tables migrations - checkDatabase defaultExtrasOptions [] [] tables + let definitions = tableDefsWithPgCrypto tables + migrateDatabase defaultExtrasOptions definitions migrations + checkDatabase defaultExtrasOptions definitions testPass = do step "create the initial database" migrate [tableBankSchema1] [createTableMigration tableBankSchema1] @@ -1574,8 +1541,9 @@ testSqlWithRecursive step = do testPass where migrate tables migrations = do - migrateDatabase defaultExtrasOptions ["pgcrypto"] [] [] tables migrations - checkDatabase defaultExtrasOptions [] [] tables + let definitions = tableDefsWithPgCrypto tables + migrateDatabase defaultExtrasOptions definitions migrations + checkDatabase defaultExtrasOptions definitions testPass = do step "create the initial database" migrate [tableBadGuySchema1, tableCartelSchema1] [createTableMigration tableBadGuySchema1, createTableMigration tableCartelSchema1] @@ -1703,56 +1671,65 @@ migrationTest2 connSource = runQuery_ $ sqlCreateComposite composite assertNoException "checkDatabase should run fine for consistent DB" $ - checkDatabase extrasOptions [composite] [] currentSchema + checkDatabase extrasOptions $ + emptyDbDefinitions {dbComposites = [composite], dbTables = currentSchema} assertException "checkDatabase fails if composite type definition is not provided" $ - checkDatabase extrasOptions [] [] currentSchema + checkDatabase extrasOptions $ + emptyDbDefinitions {dbTables = currentSchema} assertNoException "checkDatabaseAllowUnknownTables runs fine \ \for consistent DB" - $ checkDatabase extrasOptionsWithUnknownObjects [composite] [] currentSchema + $ checkDatabase extrasOptionsWithUnknownObjects + $ emptyDbDefinitions {dbComposites = [composite], dbTables = currentSchema} assertNoException "checkDatabaseAllowUnknownTables runs fine \ \for consistent DB with unknown composite type in the database" - $ checkDatabase extrasOptionsWithUnknownObjects [] [] currentSchema + $ checkDatabase extrasOptionsWithUnknownObjects + $ emptyDbDefinitions {dbTables = currentSchema} assertException "checkDatabase should throw exception for wrong schema" $ - checkDatabase extrasOptions [] [] differentSchema + checkDatabase extrasOptions emptyDbDefinitions {dbTables = differentSchema} assertException "checkDatabaseAllowUnknownObjects \ \should throw exception for wrong scheme" - $ checkDatabase extrasOptionsWithUnknownObjects [] [] differentSchema + $ checkDatabase extrasOptionsWithUnknownObjects emptyDbDefinitions {dbTables = differentSchema} runSQL_ "INSERT INTO table_versions (name, version) \ \VALUES ('unknown_table', 0)" assertException "checkDatabase throw when extra entry in 'table_versions'" $ - checkDatabase extrasOptions [] [] currentSchema + checkDatabase extrasOptions $ + emptyDbDefinitions {dbTables = currentSchema} assertNoException "checkDatabaseAllowUnknownObjects \ \accepts extra entry in 'table_versions'" - $ checkDatabase extrasOptionsWithUnknownObjects [] [] currentSchema + $ checkDatabase extrasOptionsWithUnknownObjects + $ emptyDbDefinitions {dbTables = 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 + checkDatabase extrasOptions $ + emptyDbDefinitions {dbTables = currentSchema} assertNoException "checkDatabaseAllowUnknownObjects accepts unknown table" $ - checkDatabase extrasOptionsWithUnknownObjects [] [] currentSchema + checkDatabase extrasOptionsWithUnknownObjects $ + emptyDbDefinitions {dbTables = currentSchema} runSQL_ "INSERT INTO table_versions (name, version) \ \VALUES ('unknown_table', 0)" assertException "checkDatabase should throw with unknown table" $ - checkDatabase extrasOptions [] [] currentSchema + checkDatabase extrasOptions $ + emptyDbDefinitions {dbTables = currentSchema} assertNoException "checkDatabaseAllowUnknownObjects \ \accepts unknown tables with version" - $ checkDatabase extrasOptionsWithUnknownObjects [] [] currentSchema + $ checkDatabase extrasOptionsWithUnknownObjects + $ emptyDbDefinitions {dbTables = currentSchema} freshTestDB step - let schema1TablesWithMissingPK = schema6Tables + let withMissingPKSchema = schema6Tables schema1MigrationsWithMissingPK = schema6Migrations - withMissingPKSchema = schema1TablesWithMissingPK optionsNoPKCheck = defaultExtrasOptions { eoEnforcePKs = False @@ -1766,21 +1743,20 @@ migrationTest2 connSource = migrateDatabase optionsNoPKCheck - ["pgcrypto"] - [] - [] - schema1TablesWithMissingPK + (tableDefsWithPgCrypto withMissingPKSchema) [schema1MigrationsWithMissingPK] - checkDatabase optionsNoPKCheck [] [] withMissingPKSchema + checkDatabase optionsNoPKCheck (tableDefsWithPgCrypto withMissingPKSchema) assertException "checkDatabase should throw when PK missing from table \ \'participated_in_robbery' and check is enabled" - $ checkDatabase optionsWithPKCheck [] [] withMissingPKSchema + $ checkDatabase optionsWithPKCheck + $ emptyDbDefinitions {dbTables = withMissingPKSchema} assertNoException "checkDatabase should not throw when PK missing from table \ \'participated_in_robbery' and check is disabled" - $ checkDatabase optionsNoPKCheck [] [] withMissingPKSchema + $ checkDatabase optionsNoPKCheck + $ emptyDbDefinitions {dbTables = withMissingPKSchema} freshTestDB step @@ -1858,8 +1834,8 @@ migrationTest5 connSource = freshTestDB step step "Creating the database (schema version 1)..." - migrateDatabase defaultExtrasOptions ["pgcrypto"] [] [] [table1] [createTableMigration table1] - checkDatabase defaultExtrasOptions [] [] [table1] + migrateDatabase defaultExtrasOptions (tableDefsWithPgCrypto [table1]) [createTableMigration table1] + checkDatabase defaultExtrasOptions (tableDefsWithPgCrypto [table1]) step "Populating the 'bank' table..." runQuery_ . sqlInsert "bank" $ do @@ -1877,8 +1853,8 @@ migrationTest5 connSource = forM_ (zip4 tables migrations steps assertions) $ \(table, migration, step', assertion) -> do step step' - migrateDatabase defaultExtrasOptions ["pgcrypto"] [] [] [table] [migration] - checkDatabase defaultExtrasOptions [] [] [table] + migrateDatabase defaultExtrasOptions (tableDefsWithPgCrypto [table]) [migration] + checkDatabase defaultExtrasOptions (tableDefsWithPgCrypto [table]) uncurry assertNoException assertion freshTestDB step @@ -2020,12 +1996,9 @@ foreignKeyIndexesTests connSource = let options = defaultExtrasOptions migrateDatabase options - ["pgcrypto"] - [] - [] - [table1, table2] + (tableDefsWithPgCrypto [table1, table2]) [createTableMigration table1, createTableMigration table2] - checkDatabase defaultExtrasOptions [] [] [table1, table2] + checkDatabase defaultExtrasOptions (tableDefsWithPgCrypto [table1, table2]) step "Create database with two tables, with foreign key checking" do @@ -2033,10 +2006,7 @@ foreignKeyIndexesTests connSource = assertException "Foreign keys are missing" $ migrateDatabase options - ["pgcrypto"] - [] - [] - [table1, table2] + (tableDefsWithPgCrypto [table1, table2]) [createTableMigration table1, createTableMigration table2] step "Table is missing several foreign key indexes" @@ -2045,10 +2015,7 @@ foreignKeyIndexesTests connSource = assertException "Foreign keys are missing" $ migrateDatabase options - ["pgcrypto"] - [] - [] - [table1, table2, table3] + (tableDefsWithPgCrypto [table1, table2, table3]) [createTableMigration table1, createTableMigration table2, createTableMigration table3] step "Multi column indexes covering a FK pass the checks" @@ -2056,26 +2023,20 @@ foreignKeyIndexesTests connSource = let options = defaultExtrasOptions {eoCheckForeignKeysIndexes = True} migrateDatabase options - ["pgcrypto"] - [] - [] - [table4] + (tableDefsWithPgCrypto [table4]) [ dropTableMigration table1 , dropTableMigration table2 , dropTableMigration table3 , createTableMigration table4 ] - checkDatabase options [] [] [table4] + checkDatabase options (tableDefsWithPgCrypto [table4]) step "Multi column indexes not covering a FK fail the checks" do let options = defaultExtrasOptions {eoCheckForeignKeysIndexes = True} assertException "Foreign keys are missing" $ migrateDatabase options - ["pgcrypto"] - [] - [] - [table5] + (tableDefsWithPgCrypto [table5]) [ dropTableMigration table4 , createTableMigration table5 ] @@ -2166,15 +2127,14 @@ overlapingIndexesTests connSource = do testCaseSteps' "Overlapping indexes tests" connSource $ \step -> do freshTestDB step + let definitions = tableDefsWithPgCrypto [table1] + step "Migration is correct if not checking for overlapping indexes" do let options = defaultExtrasOptions {eoCheckOverlappingIndexes = False} migrateDatabase options - ["pgcrypto"] - [] - [] - [table1] + definitions [createTableMigration table1] step "Migration invalid when flagging overlapping indexes" @@ -2183,10 +2143,7 @@ overlapingIndexesTests connSource = do assertException "Some indexes are overlapping" $ migrateDatabase options - ["pgcrypto"] - [] - [] - [table1] + definitions [createTableMigration table1] where table1 :: Table @@ -2214,14 +2171,12 @@ nullsNotDistinctTests connSource = do step "Create a database with indexes" do + let definitions = tableDefsWithPgCrypto [nullTableTest1, nullTableTest2] migrateDatabase defaultExtrasOptions - ["pgcrypto"] - [] - [] - [nullTableTest1, nullTableTest2] + definitions [createTableMigration nullTableTest1, createTableMigration nullTableTest2] - checkDatabase defaultExtrasOptions [] [] [nullTableTest1, nullTableTest2] + checkDatabase defaultExtrasOptions definitions step "Insert two NULLs on a column with a default UNIQUE index" do @@ -2351,6 +2306,52 @@ sqlAnyAllTests = (show $ toSQLCommand a) (show $ toSQLCommand b) +enumTest :: ConnectionSourceM (LogT IO) -> TestTree +enumTest connSource = + testCaseSteps' "Enum tests" connSource $ \step -> do + freshTestDB step + + step "Create a database with an enum" + migrateDatabase + defaultExtrasOptions + (emptyDbDefinitions {dbEnums = [enum1]}) + [] + + step "Check the database" + checkDatabase defaultExtrasOptions (emptyDbDefinitions {dbEnums = [enum1]}) + + step "Check the database with missing enum" + do + report <- checkDatabaseWithReport defaultExtrasOptions (emptyDbDefinitions {dbEnums = [enum1, enum2]}) + liftIO $ + assertEqual + "Missing enum2 should be reported" + (validationError "Enum 'enum2' doesn't exist in the database") + report + + step "Check the database with reordered enum" + do + report <- checkDatabaseWithReport defaultExtrasOptions (emptyDbDefinitions {dbEnums = [enum1misorder]}) + liftIO $ + assertEqual + "Missing enum2 should be reported" + (validationError "Enum 'enum1' does not match (database: [\"enum-100\",\"enum-101\"], definition: [\"enum-101\",\"enum-100\"])") + report + + step "Check the database with mismatching enum" + do + report <- checkDatabaseWithReport defaultExtrasOptions (emptyDbDefinitions {dbEnums = [enum1mismatch]}) + liftIO $ + assertEqual + "Missing enum2 should be reported" + (validationError "Enum 'enum1' does not match (database: [\"enum-100\",\"enum-101\"], definition: [\"enum-100\",\"enum-102\"])") + report + where + enum1 = EnumType {etName = "enum1", etValues = ["enum-100", "enum-101"]} + enum2 = EnumType {etName = "enum2", etValues = ["enum-200", "enum-201", "enum-202"]} + enum1misorder = EnumType {etName = "enum1", etValues = ["enum-101", "enum-100"]} + enum1mismatch = EnumType {etName = "enum1", etValues = ["enum-100", "enum-102"]} + assertNoException :: String -> TestM () -> TestM () assertNoException t = eitherExc @@ -2384,6 +2385,10 @@ testCaseSteps' testName connSource f = runDBT connSource defaultTransactionSettings $ f step +tableDefsWithPgCrypto :: [Table] -> DatabaseDefinitions +tableDefsWithPgCrypto tables = + emptyDbDefinitions {dbTables = tables, dbExtensions = ["pgcrypto"]} + main :: IO () main = do defaultMainWithIngredients ings $ @@ -2409,6 +2414,7 @@ main = do , overlapingIndexesTests connSource , nullsNotDistinctTests connSource , sqlAnyAllTests + , enumTest connSource ] where ings =