diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,19 @@ +# hpqtypes-extras-1.20.0.0 (2026-06-10) +* Drop `crypton` dependency in favor of `ppad-ripemd160`. +* Add support for customizing trigger functions. +* Adds a `Function` datatype and a `defaultTriggerFunction` backwards-compatible + trigger function helper. +* Remove `Read` instance of `IndexMethod`. +* Add support for the `NUMERIC` column type. +* Fix getting the row estimate for `ModifyColumnMigration` if a table with the + same name is present in multiple schemas. +* Add support for renaming an existing local index during a migration that + creates index concurrently. +* Fix two bugs in overlapping indexes check (not excluding local indexes + properly and query failure when the table doesn't exist). +* Drop redundant table name from `CreateIndexConcurrentlyMigration`, + `DropIndexConcurrentlyMigration` and `ModifyColumnMigration`. + # hpqtypes-extras-1.19.0.0 (2025-11-27) * Compatibility with `hpqtypes` >= 0.13.0.0. diff --git a/hpqtypes-extras.cabal b/hpqtypes-extras.cabal --- a/hpqtypes-extras.cabal +++ b/hpqtypes-extras.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: hpqtypes-extras -version: 1.19.0.0 +version: 1.20.0.0 synopsis: Extra utilities for hpqtypes library description: The following extras for hpqtypes library: . @@ -20,7 +20,7 @@ copyright: Scrive AB category: Database build-type: Simple -tested-with: GHC == { 9.2.8, 9.4.8, 9.6.7, 9.8.4, 9.10.3, 9.12.2, 9.14.1 } +tested-with: GHC == { 9.2.8, 9.4.8, 9.6.7, 9.8.4, 9.10.3, 9.12.4, 9.14.1 } Source-repository head Type: git @@ -71,6 +71,7 @@ , Database.PostgreSQL.PQTypes.Model.EnumType , Database.PostgreSQL.PQTypes.Model.Extension , Database.PostgreSQL.PQTypes.Model.ForeignKey + , Database.PostgreSQL.PQTypes.Model.Function , Database.PostgreSQL.PQTypes.Model.Index , Database.PostgreSQL.PQTypes.Model.Migration , Database.PostgreSQL.PQTypes.Model.PrimaryKey @@ -83,18 +84,18 @@ , Database.PostgreSQL.PQTypes.Utils.NubList build-depends: base >= 4.16 && < 5 - , hpqtypes >= 1.13.0.0 , base16-bytestring >= 0.1 , bytestring >= 0.10 , containers >= 0.5 - , crypton >= 0.32 , exceptions >= 0.10 , extra >= 1.6.17 - , memory >= 0.18 + , hpqtypes >= 1.13.0.0 + , log-base >= 0.11 , mtl >= 2.2 + , ppad-ripemd160 >= 0.1.4 , text >= 1.2 , text-show >= 3.7 - , log-base >= 0.11 + , attoparsec >= 0.14.4 default-language: Haskell2010 default-extensions: 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 @@ -508,18 +508,18 @@ checkDatabaseComposites = mconcat . (`map` dbCompositeTypes) $ \dbComposite -> let cname = unRawSQL $ ctName dbComposite in case cname `M.lookup` compositeMap of - Just columns -> - topMessage "composite type" cname $ - checkColumns 1 columns (ctColumns dbComposite) - 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" - ] + Just columns -> + topMessage "composite type" cname $ + checkColumns 1 columns (ctColumns dbComposite) + 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 @@ -596,18 +596,18 @@ sqlWhere "a.atthasdef" sqlWhere "a.attnum > 0" sqlWhere "NOT a.attisdropped" - sqlWhereEqSql "a.attrelid" $ sqlGetTableID table + sqlWhereEqSql "a.attrelid" $ sqlGetTableID tblName sqlOrderBy "a.attnum" desc <- fetchMany fetchTableColumn isAbove15 <- checkVersionIsAtLeast15 -- get info about constraints from pg_catalog - pk <- sqlGetPrimaryKey table - runQuery_ $ sqlGetChecks table + pk <- sqlGetPrimaryKey tblName + runQuery_ $ sqlGetChecks tblName checks <- fetchMany fetchTableCheck - runQuery_ $ sqlGetIndexes isAbove15 table + runQuery_ $ sqlGetIndexes isAbove15 tblName Nothing indexes <- fetchMany fetchTableIndex - runQuery_ $ sqlGetForeignKeys table + runQuery_ $ sqlGetForeignKeys tblName fkeys <- fetchMany fetchForeignKey triggers <- getDBTriggers tblName checkedOverlaps <- checkOverlappingIndexes tblName @@ -657,8 +657,8 @@ validateDefaults $ colDefault d == colDefault c || ( isNothing (colDefault d) - && (T.isPrefixOf "nextval('" . unRawSQL <$> colDefault c) - == Just True + && (T.isPrefixOf "nextval('" . unRawSQL <$> colDefault c) + == Just True ) , validateNullables $ colNullable d == colNullable c , checkColumns (n + 1) defs cols @@ -800,14 +800,13 @@ go fk = let columns = map unRawSQL (fkColumns fk) in if coveredFK fk allCoverage - then mempty - else validationError $ mconcat ["\n ● Foreign key '(", T.intercalate "," columns, ")' is missing an index"] + then mempty + else validationError $ mconcat ["\n ● Foreign key '(", T.intercalate "," columns, ")' is missing an index"] - checkTriggers :: [Trigger] -> [(Trigger, RawSQL ())] -> ValidationResult + checkTriggers :: [Trigger] -> [Trigger] -> ValidationResult checkTriggers defs triggers = - mapValidationResult id mapErrs $ checkEquality "TRIGGERs" defs' triggers + mapValidationResult id mapErrs $ checkEquality "TRIGGERs" defs triggers where - defs' = map (\t -> (t, triggerFunctionMakeName $ triggerName t)) defs mapErrs [] = [] mapErrs errmsgs = errmsgs @@ -951,8 +950,10 @@ [ mgrs | mgrs <- migrationsByTable, any isDropTableMigration mgrs ] invalidMigrationLists = - [ mgrs | mgrs <- dropMigrationLists, (not . isDropTableMigration . last $ mgrs) - || (length . filter isDropTableMigration $ mgrs) > 1 + [ mgrs + | mgrs <- dropMigrationLists + , (not . isDropTableMigration . last $ mgrs) + || (length . filter isDropTableMigration $ mgrs) > 1 ] unless (null invalidMigrationLists) $ do @@ -1100,8 +1101,8 @@ let ret = reverse additionalMigrations' grps = L.groupBy ((==) `on` mgrTableName) ret in if any ((/=) 0 . mgrFrom . head) grps - then [] - else ret + then [] + else ret -- Also there's no point in adding these extra migrations if -- we're not running any migrations to begin with. migrationsToRun = @@ -1125,23 +1126,43 @@ mgrDropTableMode runQuery_ $ sqlDelete "table_versions" $ do sqlWhereEq "name" (T.unpack . unRawSQL $ mgrTableName) - CreateIndexConcurrentlyMigration tname idx -> do + CreateIndexConcurrentlyMigration mLocalIndexName idx -> do logMigration + indexSet <- case mLocalIndexName of + Nothing -> pure False + Just localIndexName -> do + isAbove15 <- checkVersionIsAtLeast15 + runQuery_ $ sqlGetIndexes isAbove15 mgrTableName (Just localIndexName) + fetchMaybe fetchTableIndex >>= \case + Nothing -> do + logInfo_ "Local index not found" + pure False + Just (localIdx, _) -> do + when (localIdx /= idx) $ do + logInfo "Local index doesn't match the definition" $ + object + [ "index_local" .= show localIdx + , "index_definition" .= show idx + ] + error "Indexes don't match" + logInfo_ "Local index found, renaming" + runQuery_ $ "ALTER INDEX" <+> localIndexName <+> "RENAME TO" <+> indexName mgrTableName idx + pure True -- We're in auto transaction mode (as ensured at the beginning of -- 'checkDBConsistency'), so we need to issue explicit SQL commit, -- because using 'commit' function automatically starts another -- transaction. We don't want that as concurrent creation of index -- won't run inside a transaction. - unsafeWithoutTransaction $ do + unless indexSet . unsafeWithoutTransaction $ do -- If migration was run before but creation of an index failed, index -- will be left in the database in an inactive state, so when we -- rerun, we need to remove it first (see -- https://www.postgresql.org/docs/9.6/sql-createindex.html for more -- information). - runQuery_ $ "DROP INDEX CONCURRENTLY IF EXISTS" <+> indexName tname idx - runQuery_ (sqlCreateIndexConcurrently tname idx) + runQuery_ $ "DROP INDEX CONCURRENTLY IF EXISTS" <+> indexName mgrTableName idx + runQuery_ (sqlCreateIndexConcurrently mgrTableName idx) updateTableVersion - DropIndexConcurrentlyMigration tname idx -> do + DropIndexConcurrentlyMigration idx -> do logMigration -- We're in auto transaction mode (as ensured at the beginning of -- 'checkDBConsistency'), so we need to issue explicit SQL commit, @@ -1149,9 +1170,9 @@ -- transaction. We don't want that as concurrent dropping of index -- won't run inside a transaction. unsafeWithoutTransaction $ do - runQuery_ (sqlDropIndexConcurrently tname idx) + runQuery_ (sqlDropIndexConcurrently mgrTableName idx) updateTableVersion - ModifyColumnMigration tableName cursorSql updateSql batchSize -> do + ModifyColumnMigration cursorSql updateSql batchSize -> do logMigration when (batchSize < 1000) $ do error "Batch size cannot be less than 1000" @@ -1174,7 +1195,7 @@ -- arbitrary, but a reasonable ballpark estimate: it more or less -- makes sure we keep dead records in the 10% envelope and the table -- doesn't grow too much during the operation. - vacuumThreshold <- max 1000 . fromIntegral . (`div` 20) <$> getRowEstimate tableName + vacuumThreshold <- max 1000 . fromIntegral . (`div` 20) <$> getRowEstimate mgrTableName let cursorLoop processed = do cursorFetch_ cursor (CD_Forward batchSize) primaryKeys <- fetchMany id @@ -1185,7 +1206,7 @@ bracket_ (runSQL_ "COMMIT") (runSQL_ "BEGIN") - (runQuery_ $ "VACUUM" <+> tableName) + (runQuery_ $ "VACUUM" <+> mgrTableName) cursorLoop 0 else do commit @@ -1212,7 +1233,10 @@ getRowEstimate tableName = do runQuery_ . sqlSelect "pg_class" $ do sqlResult "reltuples::integer" - sqlWhereEq "relname" $ unRawSQL tableName + -- If tables with the same name are present in multiple schemas, + -- casting the name to regclass resolves the ambiguity using search + -- path priority. + sqlWhere $ "oid =" unRawSQL tableName <> "::regclass" fetchOne runIdentity runMigrations :: [(Text, Int32)] -> m () @@ -1412,25 +1436,25 @@ -- *** TABLE STRUCTURE *** -sqlGetTableID :: Table -> SQL -sqlGetTableID table = parenthesize . toSQLCommand $ +sqlGetTableID :: RawSQL () -> SQL +sqlGetTableID tableName = parenthesize . toSQLCommand $ sqlSelect "pg_catalog.pg_class c" $ do sqlResult "c.oid" sqlLeftJoinOn "pg_catalog.pg_namespace n" "n.oid = c.relnamespace" - sqlWhereEq "c.relname" $ tblNameString table + sqlWhereEq "c.relname" $ unRawSQL tableName sqlWhere "pg_catalog.pg_table_is_visible(c.oid)" -- *** PRIMARY KEY *** sqlGetPrimaryKey :: (MonadDB m, MonadThrow m) - => Table + => RawSQL () -> m (Maybe (PrimaryKey, RawSQL ())) -sqlGetPrimaryKey table = do +sqlGetPrimaryKey tableName = do (mColumnNumbers :: Maybe [Int16]) <- do runQuery_ . sqlSelect "pg_catalog.pg_constraint" $ do sqlResult "conkey" - sqlWhereEqSql "conrelid" (sqlGetTableID table) + sqlWhereEqSql "conrelid" $ sqlGetTableID tableName sqlWhereEq "contype" 'p' fetchMaybe $ unArray1 . runIdentity @@ -1442,14 +1466,14 @@ runQuery_ . sqlSelect "pk_columns" $ do sqlWith "key_series" . sqlSelect "pg_constraint as c2" $ do sqlResult "unnest(c2.conkey) as k" - sqlWhereEqSql "c2.conrelid" $ sqlGetTableID table + sqlWhereEqSql "c2.conrelid" $ sqlGetTableID tableName sqlWhereEq "c2.contype" 'p' sqlWith "pk_columns" . sqlSelect "key_series" $ do sqlJoinOn "pg_catalog.pg_attribute as a" "a.attnum = key_series.k" sqlResult "a.attname::text as column_name" sqlResult "key_series.k as column_order" - sqlWhereEqSql "a.attrelid" $ sqlGetTableID table + sqlWhereEqSql "a.attrelid" $ sqlGetTableID tableName sqlResult "pk_columns.column_name" sqlWhereEq "pk_columns.column_order" k @@ -1458,7 +1482,7 @@ runQuery_ . sqlSelect "pg_catalog.pg_constraint as c" $ do sqlWhereEq "c.contype" 'p' - sqlWhereEqSql "c.conrelid" $ sqlGetTableID table + sqlWhereEqSql "c.conrelid" $ sqlGetTableID tableName sqlResult "c.conname::text" sqlResult $ Data.String.fromString @@ -1466,34 +1490,34 @@ join <$> fetchMaybe fetchPrimaryKey -fetchPrimaryKey :: (String, Array1 String) -> Maybe (PrimaryKey, RawSQL ()) +fetchPrimaryKey :: (Text, Array1 Text) -> Maybe (PrimaryKey, RawSQL ()) fetchPrimaryKey (name, Array1 columns) = - (,unsafeSQL name) - <$> pkOnColumns (map unsafeSQL columns) + (,rawSQL name ()) + <$> pkOnColumns (map (`rawSQL` ()) columns) -- *** CHECKS *** -sqlGetChecks :: Table -> SQL -sqlGetChecks table = toSQLCommand . sqlSelect "pg_catalog.pg_constraint c" $ do +sqlGetChecks :: RawSQL () -> SQL +sqlGetChecks tableName = toSQLCommand . sqlSelect "pg_catalog.pg_constraint c" $ do sqlResult "c.conname::text" sqlResult "regexp_replace(pg_get_constraintdef(c.oid, true), \ \'CHECK \\((.*)\\)', '\\1') AS body" -- check body sqlResult "c.convalidated" -- validated? sqlWhereEq "c.contype" 'c' - sqlWhereEqSql "c.conrelid" $ sqlGetTableID table + sqlWhereEqSql "c.conrelid" $ sqlGetTableID tableName -fetchTableCheck :: (String, String, Bool) -> Check +fetchTableCheck :: (Text, Text, Bool) -> Check fetchTableCheck (name, condition, validated) = Check - { chkName = unsafeSQL name - , chkCondition = unsafeSQL condition + { chkName = rawSQL name () + , chkCondition = rawSQL condition () , chkValidated = validated } -- *** INDEXES *** -sqlGetIndexes :: Bool -> Table -> SQL -sqlGetIndexes nullsNotDistinctSupported table = toSQLCommand . sqlSelect "pg_catalog.pg_class c" $ do +sqlGetIndexes :: Bool -> RawSQL () -> Maybe (RawSQL ()) -> SQL +sqlGetIndexes nullsNotDistinctSupported tableName mname = toSQLCommand . sqlSelect "pg_catalog.pg_class c" $ do sqlResult "c.relname::text" -- index name sqlResult $ "ARRAY(" <> selectCoordinates "0" "i.indnkeyatts" <> ")" -- array of key columns in the index sqlResult $ "ARRAY(" <> selectCoordinates "i.indnkeyatts" "i.indnatts" <> ")" -- array of included columns in the index @@ -1514,8 +1538,9 @@ -- weren't successfully built by it) are marked as invalid, so we don't want -- to consider them at a time. sqlWhere "i.indisvalid" - sqlWhereEqSql "i.indrelid" $ sqlGetTableID table + sqlWhereEqSql "i.indrelid" $ sqlGetTableID tableName sqlWhereIsNULL "r.contype" -- fetch only "pure" indexes + forM_ mname $ sqlWhereEq "c.relname" . unRawSQL where -- Get all coordinates of the index. selectCoordinates start end = @@ -1531,24 +1556,27 @@ ] fetchTableIndex - :: (String, Array1 String, Array1 String, String, Bool, Bool, Maybe String) + :: (Text, Array1 Text, Array1 Text, Text, Bool, Bool, Maybe Text) -> (TableIndex, RawSQL ()) fetchTableIndex (name, Array1 keyColumns, Array1 includeColumns, method, unique, nullsNotDistinct, mconstraint) = ( TableIndex - { idxColumns = map (indexColumn . unsafeSQL) keyColumns - , idxInclude = map unsafeSQL includeColumns - , idxMethod = read method + { idxColumns = map (indexColumn . (`rawSQL` ())) keyColumns + , idxInclude = map (`rawSQL` ()) includeColumns + , idxMethod = case method of + "gin" -> GIN + "btree" -> BTree + _ -> error $ "unexpected index method: " ++ T.unpack method , idxUnique = unique - , idxWhere = unsafeSQL <$> mconstraint + , idxWhere = (`rawSQL` ()) <$> mconstraint , idxNotDistinctNulls = nullsNotDistinct } - , unsafeSQL name + , rawSQL name () ) -- *** FOREIGN KEYS *** -sqlGetForeignKeys :: Table -> SQL -sqlGetForeignKeys table = toSQLCommand +sqlGetForeignKeys :: RawSQL () -> SQL +sqlGetForeignKeys tableName = toSQLCommand . sqlSelect "pg_catalog.pg_constraint r" $ do sqlResult "r.conname::text" -- fk name @@ -1572,7 +1600,7 @@ sqlResult "r.condeferred" -- initially deferred? sqlResult "r.convalidated" -- validated? sqlJoinOn "pg_catalog.pg_class c" "c.oid = r.confrelid" - sqlWhereEqSql "r.conrelid" $ sqlGetTableID table + sqlWhereEqSql "r.conrelid" $ sqlGetTableID tableName sqlWhereEq "r.contype" 'f' where unnestWithOrdinality :: RawSQL () -> SQL @@ -1584,7 +1612,7 @@ <> ", 1) AS n" fetchForeignKey - :: (String, Array1 String, String, Array1 String, Char, Char, Bool, Bool, Bool) + :: (Text, Array1 Text, Text, Array1 Text, Char, Char, Bool, Bool, Bool) -> (ForeignKey, RawSQL ()) fetchForeignKey ( name @@ -1598,16 +1626,16 @@ , validated ) = ( ForeignKey - { fkColumns = map unsafeSQL columns - , fkRefTable = unsafeSQL reftable - , fkRefColumns = map unsafeSQL refcolumns + { fkColumns = map (`rawSQL` ()) columns + , fkRefTable = rawSQL reftable () + , fkRefColumns = map (`rawSQL` ()) refcolumns , fkOnUpdate = charToForeignKeyAction on_update , fkOnDelete = charToForeignKeyAction on_delete , fkDeferrable = deferrable , fkDeferred = deferred , fkValidated = validated } - , unsafeSQL name + , rawSQL name () ) where charToForeignKeyAction c = case c of 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 @@ -203,11 +203,16 @@ -- can differ even if the predicate is the same), ignore functional indexes at the same time -- as that would make this query very ugly " indexdata1 AS (SELECT *" - , " , ((regexp_match(pg_get_indexdef(indexrelid)" + , " , ((regexp_match(pg_get_indexdef(i.indexrelid)" , " , 'WHERE (.*)$')))[1] AS preddef" - , " FROM pg_index" - , " WHERE indexprs IS NULL" - , " AND indrelid = '" <> raw tableName <> "'::regclass)" + , " FROM pg_index i JOIN pg_class c ON i.indexrelid = c.oid" + , " WHERE i.indexprs IS NULL" + , " AND NOT c.relname ILIKE 'local_%'" + , -- Use to_regclass instead of '...'::regclass: both respect the search + -- path, but the cast throws if the table doesn't exist whereas + -- to_regclass returns NULL, so the query yields no rows (e.g. when + -- checking an invalid schema with missing tables). + " AND i.indrelid = to_regclass('" <> raw tableName <> "'))" , -- add the rest of metadata and do the join " , indexdata2 AS (SELECT t1.*" , " , pg_get_indexdef(t1.indexrelid) AS contained" @@ -224,12 +229,9 @@ , " SELECT contained" , " , contains" , " FROM indexdata2" - , " JOIN pg_class c ON (c.oid = indexdata2.indexrelid)" , -- The indexes are the same or the "other" is larger than us " WHERE (colotherindex = colindex" , " OR colotherindex LIKE colindex || '+%')" - , -- and this is not a local index - " AND NOT c.relname ILIKE 'local_%'" , -- and we have the same predicate " AND other_preddef IS NOT DISTINCT FROM preddef" , -- and either the other is unique (so better than us) or none of us is unique diff --git a/src/Database/PostgreSQL/PQTypes/Model/ColumnType.hs b/src/Database/PostgreSQL/PQTypes/Model/ColumnType.hs --- a/src/Database/PostgreSQL/PQTypes/Model/ColumnType.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/ColumnType.hs @@ -3,8 +3,11 @@ , columnTypeToSQL ) where +import Data.Attoparsec.Text qualified as A +import Data.Functor import Data.Text qualified as T import Database.PostgreSQL.PQTypes +import TextShow data ColumnType = BigIntT @@ -25,6 +28,7 @@ | XmlT | ArrayT !ColumnType | CustomT !(RawSQL ()) + | NumericT !(Maybe (Int, Int)) deriving (Eq, Ord, Show) instance PQFormat ColumnType where @@ -50,9 +54,27 @@ "timestamp with time zone" -> TimestampWithZoneT "tsvector" -> TSVectorT "xml" -> XmlT - tname - | "[]" `T.isSuffixOf` tname -> ArrayT . parseType $ T.take (T.length tname - 2) tname - | otherwise -> CustomT $ rawSQL tname () + tname -> case parseNumeric tname of + Just t -> t + Nothing + | "[]" `T.isSuffixOf` tname -> ArrayT . parseType $ T.take (T.length tname - 2) tname + | otherwise -> CustomT $ rawSQL tname () + parseNumeric :: T.Text -> Maybe ColumnType + parseNumeric tname = + let inParens p = A.string "(" *> p <* A.string ")" + comma = A.string "," $> () + precisionAndScale = Just <$> inParens ((,) <$> (A.decimal <* comma) <*> A.signed A.decimal) + precisionOnly = Just . (,0) <$> inParens A.decimal + numericParser = + NumericT + <$> ( A.string "numeric" + *> A.choice + [ precisionAndScale + , precisionOnly + , pure Nothing + ] + ) + in either (const Nothing) Just $ A.parseOnly numericParser tname columnTypeToSQL :: ColumnType -> RawSQL () columnTypeToSQL BigIntT = "BIGINT" @@ -73,3 +95,5 @@ columnTypeToSQL XmlT = "XML" columnTypeToSQL (ArrayT t) = columnTypeToSQL t <> "[]" columnTypeToSQL (CustomT tname) = tname +columnTypeToSQL (NumericT Nothing) = rawSQL "NUMERIC" () +columnTypeToSQL (NumericT (Just (precision, scale))) = rawSQL ("NUMERIC(" <> showt precision <> "," <> showt scale <> ")") () diff --git a/src/Database/PostgreSQL/PQTypes/Model/EnumType.hs b/src/Database/PostgreSQL/PQTypes/Model/EnumType.hs --- a/src/Database/PostgreSQL/PQTypes/Model/EnumType.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/EnumType.hs @@ -2,6 +2,7 @@ ( EnumType (..) , sqlCreateEnum , sqlDropEnum + , sqlAddEnumValue ) where import Data.Monoid.Utils @@ -30,3 +31,7 @@ -- | Make SQL query that drops a composite type. sqlDropEnum :: RawSQL () -> RawSQL () sqlDropEnum = ("DROP TYPE" <+>) + +-- | Add a value to an enum type +sqlAddEnumValue :: RawSQL () -> RawSQL () -> RawSQL () +sqlAddEnumValue enumName value = "ALTER TYPE " <> enumName <> " ADD VALUE '" <> value <> "'" diff --git a/src/Database/PostgreSQL/PQTypes/Model/Function.hs b/src/Database/PostgreSQL/PQTypes/Model/Function.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/PQTypes/Model/Function.hs @@ -0,0 +1,67 @@ +module Database.PostgreSQL.PQTypes.Model.Function where + +import Data.Map.Strict qualified as M +import Data.Monoid.Utils +import Data.Text qualified as T +import Database.PostgreSQL.PQTypes + +data Function = Function + { fnName :: RawSQL () + -- ^ Name of the function it can be referenced with. + , fnBody :: RawSQL () + -- ^ The body of the function. + , fnReturns :: RawSQL () + -- ^ The return type of the function. + , fnSecurity :: Security + -- ^ Indicates with which privileges the function is executed with. By default + -- this is usually the caller (INVOKER). The alternative is DEFINER, where the + -- function is executed under the user that owns, not calls, it. + , fnConfigurationParameters :: M.Map T.Text (RawSQL ()) + -- ^ Functions allow setting configuration parameters during the execution of + -- the function. This corresponds to the SET clause in CREATE FUNCTION. See + -- the following: + -- - https://www.postgresql.org/docs/current/sql-createfunction.html + -- - https://www.postgresql.org/docs/current/sql-set.html + } + deriving (Show, Eq) + +data Security = Invoker | Definer + deriving (Show, Eq) + +-- | Turn the function into a SQL statement. +-- +-- NB: If an existing function has the same name, it is replaced. +-- +-- @since 1.20.0.0 +sqlCreateFunction :: Function -> RawSQL () +sqlCreateFunction Function {..} = + "CREATE OR REPLACE FUNCTION" + <+> fnName + <> "()" + <+> returns + <+> "AS $$" + <> fnBody + <> "$$" + <+> "LANGUAGE PLPGSQL" + <+> "VOLATILE" + <+> security + <+> "RETURNS NULL ON NULL INPUT" + <+> searchPath + <> ";" + where + returns = "RETURNS" <+> fnReturns + security = case fnSecurity of + Invoker -> "SECURITY INVOKER" + Definer -> "SECURITY DEFINER" + searchPath = + foldr + (\(param, value) prev -> "SET" <+> unsafeSQL (T.unpack param) <+> "=" <+> value <+> prev) + (unsafeSQL "") + $ M.toList fnConfigurationParameters + +-- | Build an SQL statement for dropping a function. +-- +-- @since 1.20.0.0 +sqlDropFunction :: Function -> RawSQL () +sqlDropFunction Function {..} = + "DROP FUNCTION" <+> fnName <+> "RESTRICT" diff --git a/src/Database/PostgreSQL/PQTypes/Model/Index.hs b/src/Database/PostgreSQL/PQTypes/Model/Index.hs --- a/src/Database/PostgreSQL/PQTypes/Model/Index.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/Index.hs @@ -20,8 +20,7 @@ , sqlDropIndexConcurrently ) where -import Crypto.Hash qualified as H -import Data.ByteArray qualified as BA +import Crypto.Hash.RIPEMD160 qualified as RIPEMD160 import Data.ByteString.Base16 qualified as B16 import Data.ByteString.Char8 qualified as BS import Data.Char @@ -66,6 +65,16 @@ instance IsString IndexColumn where fromString s = IndexColumn (fromString s) Nothing +-- | Build an 'IndexColumn' from a column name. +-- +-- If the column name is a non-reserved keyword in PostgreSQL it must be given +-- double-quoted, e.g. +-- +-- @timestamp@ -> @\"\\\"timestamp\\\"\"@ +-- +-- PostgreSQL stores the index definition with the keyword quoted, so the column +-- name passed here has to match that exactly or the database consistency check +-- will report a mismatch. indexColumn :: RawSQL () -> IndexColumn indexColumn col = IndexColumn col Nothing @@ -78,16 +87,7 @@ data IndexMethod = BTree | GIN - deriving (Eq, Ord) - -instance Show IndexMethod where - show BTree = "btree" - show GIN = "gin" - -instance Read IndexMethod where - readsPrec _ (map toLower -> "btree") = [(BTree, "")] - readsPrec _ (map toLower -> "gin") = [(GIN, "")] - readsPrec _ _ = [] + deriving (Eq, Ord, Show) tblIndex :: TableIndex tblIndex = @@ -176,6 +176,7 @@ asText f = flip rawSQL () . f . unRawSQL -- See http://www.postgresql.org/docs/9.4/static/sql-syntax-lexical.html#SQL-SYNTAX-IDENTIFIERS. -- Remove all unallowed characters and replace them by at most one adjacent dollar sign. + -- NB: This allows the behavior as described in @indexColumn@. sanitize = T.pack . foldr go [] . T.unpack where go c acc = @@ -191,8 +192,7 @@ T.decodeUtf8 . B16.encode . BS.take 10 - . BA.convert - . H.hash @_ @H.RIPEMD160 + . RIPEMD160.hash . T.encodeUtf8 -- | Create an index. Warning: if the affected table is large, this will prevent diff --git a/src/Database/PostgreSQL/PQTypes/Model/Migration.hs b/src/Database/PostgreSQL/PQTypes/Model/Migration.hs --- a/src/Database/PostgreSQL/PQTypes/Model/Migration.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/Migration.hs @@ -46,21 +46,23 @@ DropTableMigration DropTableMode | -- | Migration for creating an index concurrently. CreateIndexConcurrentlyMigration - (RawSQL ()) - -- ^ Table name + (Maybe (RawSQL ())) + -- ^ Optional name of the local index that, if exists, will be renamed to + -- the desired index instead of creating it from scratch. + -- + -- - If the index doesn't exist, the migration will proceed as usual and + -- create the index from scratch. + -- + -- - If the index exists and its structure doesn't match the desired + -- index, the migration will abort with an error. TableIndex -- ^ Index | -- | Migration for dropping an index concurrently. DropIndexConcurrentlyMigration - (RawSQL ()) - -- ^ Table name TableIndex -- ^ Index | -- | Migration for modifying columns. Parameters are: -- - -- Name of the table that the cursor is associated with. It has to be the same as in the - -- cursor SQL, see the second parameter. - -- -- SQL providing a list of primary keys from the associated table that will be used for the cursor. -- -- Function that takes a batch of primary keys provided by the cursor SQL and runs an arbitrary computation @@ -74,7 +76,7 @@ -- 2. Unzip them into a tuple of lists in Haskell. -- 3. Pass the lists to PostgreSQL as separate parameters and zip them back in the SQL, -- see https://stackoverflow.com/questions/12414750/is-there-something-like-a-zip-function-in-postgresql-that-combines-two-arrays for more details. - forall t. FromRow t => ModifyColumnMigration (RawSQL ()) SQL ([t] -> m ()) Int + forall t. FromRow t => ModifyColumnMigration SQL ([t] -> m ()) Int -- | Migration object. data Migration m diff --git a/src/Database/PostgreSQL/PQTypes/Model/Trigger.hs b/src/Database/PostgreSQL/PQTypes/Model/Trigger.hs --- a/src/Database/PostgreSQL/PQTypes/Model/Trigger.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/Trigger.hs @@ -19,6 +19,7 @@ , getDBTriggers -- * Trigger functions + , defaultTriggerFunction , sqlCreateTriggerFunction , sqlDropTriggerFunction , triggerFunctionMakeName @@ -30,12 +31,16 @@ import Data.Bits (testBit) import Data.Foldable qualified as F import Data.Int +import Data.Map qualified as M +import Data.Maybe import Data.Monoid.Utils import Data.Set (Set) import Data.Set qualified as Set import Data.Text (Text) +import Data.Text qualified as T import Data.Text qualified as Text import Database.PostgreSQL.PQTypes +import Database.PostgreSQL.PQTypes.Model.Function import Database.PostgreSQL.PQTypes.SQL.Builder -- | Timing for a regular trigger. @@ -105,19 +110,11 @@ , triggerWhen :: Maybe (RawSQL ()) -- ^ The condition that specifies whether the trigger should fire. Corresponds to the -- @WHEN ( __condition__ )@ in the trigger definition. - , triggerFunction :: RawSQL () + , triggerFunction :: Function -- ^ The function to execute when the trigger fires. -- The function is declared as taking no arguments and returning type @trigger@. } - deriving (Show) - -instance Eq Trigger where - t1 == t2 = - triggerTable t1 == triggerTable t2 - && triggerName t1 == triggerName t2 - && triggerKind t1 == triggerKind t2 - && triggerEvents t1 == triggerEvents t2 - && triggerWhen t1 == triggerWhen t2 + deriving (Show, Eq) -- Function source code is not guaranteed to be equal, so we ignore it. @@ -189,7 +186,7 @@ TriggerConstraint Deferrable -> "DEFERRABLE" TriggerConstraint DeferrableInitiallyDeferred -> "DEFERRABLE INITIALLY DEFERRED" trgWhen = maybe "" (\w -> "WHEN (" <+> w <+> ")") triggerWhen - trgFunction = triggerFunctionMakeName triggerName + trgFunction = fnName triggerFunction -- | Build an SQL statement that drops a trigger. -- @@ -212,8 +209,7 @@ -- @since 1.15.0 createTrigger :: MonadDB m => Trigger -> m () createTrigger trigger = do - -- TODO: Use 'withTransaction' here? That would mean adding MonadMask... - runQuery_ $ sqlCreateTriggerFunction trigger + runQuery_ $ sqlCreateFunction (triggerFunction trigger) runQuery_ $ sqlCreateTrigger trigger -- | Drop the trigger from the database. @@ -223,9 +219,8 @@ dropTrigger trigger = do -- First, drop the trigger, as it is dependent on the function. See the comment in -- 'sqlDropTrigger'. - -- TODO: Use 'withTransaction' here? That would mean adding MonadMask... runQuery_ $ sqlDropTrigger trigger - runQuery_ $ sqlDropTriggerFunction trigger + runQuery_ $ sqlDropFunction (triggerFunction trigger) -- | Get all noninternal triggers from the database. -- @@ -240,7 +235,7 @@ -- originally typed. -- -- @since 1.15.0 -getDBTriggers :: forall m. MonadDB m => RawSQL () -> m [(Trigger, RawSQL ())] +getDBTriggers :: forall m. MonadDB m => RawSQL () -> m [Trigger] getDBTriggers tableName = do runQuery_ . sqlSelect "pg_trigger t" $ do sqlResult "t.tgname::text" -- name @@ -254,27 +249,48 @@ -- result. sqlResult "pg_get_triggerdef(t.oid, true)::text" sqlResult "p.proname::text" - sqlResult "p.prosrc" -- text + sqlResult "trim(p.prosrc)" -- text + sqlResult "p.prosecdef" -- bool => true = SECURITY DEFINER, false = SECURITY INVOKER + sqlResult "fn_rettype.typname::text" + sqlResult "p.proconfig::text[]" sqlResult "c.relname::text" sqlJoinOn "pg_proc p" "t.tgfoid = p.oid" sqlJoinOn "pg_class c" "c.oid = t.tgrelid" + sqlJoinOn "pg_type fn_rettype" "fn_rettype.oid = p.prorettype" sqlWhereEq "t.tgisinternal" False sqlWhereEq "c.relname" $ unRawSQL tableName fetchMany getTrigger where - getTrigger :: (String, Int16, Bool, Bool, Bool, String, String, String, String) -> (Trigger, RawSQL ()) - getTrigger (tgname, tgtype, tgconstraint, tgdeferrable, tginitdeferrable, triggerdef, proname, prosrc, tblName) = + getTrigger :: (String, Int16, Bool, Bool, Bool, String, String, String, Bool, String, Maybe (Array1 Text), String) -> Trigger + getTrigger (tgname, tgtype, tgconstraint, tgdeferrable, tginitdeferrable, triggerdef, proname, prosrc, prosecdef, prorettype, proconfig, tblName) = ( Trigger { triggerTable = tableName' , triggerName = triggerBaseName (unsafeSQL tgname) tableName' , triggerKind = tgrKind , triggerEvents = trgEvents , triggerWhen = tgrWhen - , triggerFunction = unsafeSQL prosrc + , triggerFunction = + Function + { fnName = unsafeSQL proname + , fnBody = unsafeSQL prosrc + , fnReturns = unsafeSQL prorettype + , fnSecurity = + if prosecdef + then Definer + else Invoker + , fnConfigurationParameters = + M.fromList . mapMaybe parseFnConfigurationParameter $ + maybe [] unArray1 proconfig + } } - , unsafeSQL proname ) where + -- Parses "config_name=value" strings into tuples ("config_name", value) + parseFnConfigurationParameter s + | [configName, value] <- T.splitOn "=" s = + Just (configName, unsafeSQL $ T.unpack value) + | otherwise = Nothing + tableName' :: RawSQL () tableName' = unsafeSQL tblName @@ -282,8 +298,8 @@ parseBetween left right = let (prefix, match) = Text.breakOnEnd left $ Text.pack triggerdef in if Text.null prefix - then Nothing - else Just $ (rawSQL . fst $ Text.breakOn right match) () + then Nothing + else Just $ (rawSQL . fst $ Text.breakOn right match) () -- Get the WHEN part of the query. Anything between WHEN and EXECUTE is what we -- want. The Postgres' grammar guarantees that WHEN and EXECUTE are always next to @@ -352,16 +368,20 @@ -- @since 1.15.0.0 sqlCreateTriggerFunction :: Trigger -> RawSQL () sqlCreateTriggerFunction Trigger {..} = - "CREATE FUNCTION" - <+> triggerFunctionMakeName triggerName - <> "()" - <+> "RETURNS TRIGGER" - <+> "AS $$" - <+> triggerFunction - <+> "$$" - <+> "LANGUAGE PLPGSQL" - <+> "VOLATILE" - <+> "RETURNS NULL ON NULL INPUT" + sqlCreateFunction triggerFunction + +-- | Backwards compatible helper for using pre-1.20.0.0 trigger functions +-- +-- @since 1.20.0.0 +defaultTriggerFunction :: RawSQL () -> RawSQL () -> Function +defaultTriggerFunction triggerName functionBody = + Function + { fnName = triggerFunctionMakeName triggerName + , fnBody = functionBody + , fnReturns = "trigger" + , fnSecurity = Invoker + , fnConfigurationParameters = mempty + } -- | Build an SQL statement for dropping a trigger function. -- diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -21,6 +21,8 @@ import Log import Log.Backend.StandardOutput +import Data.Map qualified as M +import Database.PostgreSQL.PQTypes.Model.Function import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.Options @@ -37,6 +39,12 @@ optionName = return "connection-string" optionHelp = return "Postgres connection string" +testExtrasOptions :: ExtrasOptions +testExtrasOptions = + defaultExtrasOptions + { eoCheckOverlappingIndexes = True + } + -- Simple example schemata inspired by the one in -- < http://www.databaseanswers.org/data_models/bank_robberies/index.htm> -- @@ -117,11 +125,11 @@ , tblColumns = tblColumns tableBankSchema3 ++ [ tblColumn - { colName = "cash" - , colType = IntegerT - , colNullable = False - , colDefault = Just "0" - } + { colName = "cash" + , colType = IntegerT + , colNullable = False + , colDefault = Just "0" + } ] } @@ -145,19 +153,33 @@ , mgrFrom = 3 , mgrAction = CreateIndexConcurrentlyMigration - (tblName tableBankSchema3) + (Just "local_idx_doesnt_exist") ((indexOnColumn "name") {idxInclude = ["id", "location"]}) } +tableBankMigration5thrd :: MonadDB m => Migration m +tableBankMigration5thrd = + Migration + { mgrTableName = tblName tableBankSchema3 + , mgrFrom = 4 + , mgrAction = + CreateIndexConcurrentlyMigration + (Just localBankIndexToRename) + (indexOnColumns ["id", "name"]) + } + tableBankSchema5 :: Table tableBankSchema5 = tableBankSchema4 - { tblVersion = tblVersion tableBankSchema4 + 2 + { tblVersion = tblVersion tableBankSchema4 + 3 , tblColumns = filter (\c -> colName c /= "cash") (tblColumns tableBankSchema4) - , tblIndexes = [(indexOnColumn "name") {idxInclude = ["id", "location"]}] + , tblIndexes = + [ (indexOnColumn "name") {idxInclude = ["id", "location"]} + , indexOnColumns ["id", "name"] + ] } tableBadGuySchema1 :: Table @@ -555,6 +577,7 @@ ++ [ createTableMigration tableFlash , tableBankMigration5fst , tableBankMigration5snd + , tableBankMigration5thrd , dropTableMigration tableFlash ] @@ -587,17 +610,25 @@ type TestM a = DBT (LogT IO) a +localBankIndexToRename :: RawSQL () +localBankIndexToRename = "local_idx_bank_id_name" + createTablesSchema1 :: (String -> TestM ()) -> TestM () createTablesSchema1 step = do let definitions = tableDefsWithPgCrypto schema1Tables step "Creating the database (schema version 1)..." - migrateDatabase defaultExtrasOptions definitions schema1Migrations + migrateDatabase testExtrasOptions definitions schema1Migrations - -- Add a local index that shouldn't trigger validation errors. - runSQL_ "CREATE INDEX local_idx_bank_name ON bank(name)" + -- Add local indexes that shouldn't trigger validation (in particular overlap, + -- both "is included in" and "includes" case) errors. + runSQL_ "CREATE INDEX local_idx__bank__id ON bank(id)" + runSQL_ "CREATE INDEX local_idx__bank__id__name__location ON bank(id,name,location)" - checkDatabase defaultExtrasOptions definitions + -- Add a local index that will be renamed during a migration later. + runQuery_ $ "CREATE INDEX" <+> localBankIndexToRename <+> "ON bank(id, name)" + checkDatabase testExtrasOptions definitions + testDBSchema1 :: (String -> TestM ()) -> TestM ([UUID], [UUID]) testDBSchema1 step = do step "Running test queries (schema version 1)..." @@ -890,10 +921,10 @@ let definitions = tableDefsWithPgCrypto schema2Tables step "Migrating the database (schema version 1 -> schema version 2)..." migrateDatabase - defaultExtrasOptions + testExtrasOptions definitions schema2Migrations - checkDatabase defaultExtrasOptions definitions + checkDatabase testExtrasOptions definitions -- | Hacky version of 'migrateDBToSchema2' used by 'migrationTest3'. migrateDBToSchema2Hacky :: (String -> TestM ()) -> TestM () @@ -903,10 +934,10 @@ "Hackily migrating the database (schema version 1 \ \-> schema version 2)..." migrateDatabase - defaultExtrasOptions + testExtrasOptions definitions schema2Migrations' - checkDatabase defaultExtrasOptions definitions + checkDatabase testExtrasOptions definitions where schema2Migrations' = createTableMigration tableFlash : schema2Migrations @@ -962,10 +993,10 @@ let definitions = tableDefsWithPgCrypto schema3Tables step "Migrating the database (schema version 2 -> schema version 3)..." migrateDatabase - defaultExtrasOptions + testExtrasOptions definitions schema3Migrations - checkDatabase defaultExtrasOptions definitions + checkDatabase testExtrasOptions definitions testDBSchema3 :: (String -> TestM ()) -> [UUID] -> [UUID] -> TestM () testDBSchema3 step badGuyIds robberyIds = do @@ -1027,10 +1058,10 @@ let definitions = tableDefsWithPgCrypto schema4Tables step "Migrating the database (schema version 3 -> schema version 4)..." migrateDatabase - defaultExtrasOptions + testExtrasOptions definitions schema4Migrations - checkDatabase defaultExtrasOptions definitions + checkDatabase testExtrasOptions definitions testDBSchema4 :: (String -> TestM ()) -> TestM () testDBSchema4 step = do @@ -1055,8 +1086,8 @@ migrateDBToSchema5 step = do let definitions = tableDefsWithPgCrypto schema5Tables step "Migrating the database (schema version 4 -> schema version 5)..." - migrateDatabase defaultExtrasOptions definitions schema5Migrations - checkDatabase defaultExtrasOptions definitions + migrateDatabase testExtrasOptions definitions schema5Migrations + checkDatabase testExtrasOptions definitions testDBSchema5 :: (String -> TestM ()) -> TestM () testDBSchema5 step = do @@ -1120,19 +1151,20 @@ , triggerEvents = Set.fromList [TriggerInsert] , triggerWhen = Nothing , triggerFunction = - "begin" - <+> " perform true;" - <+> " return null;" - <+> "end;" + defaultTriggerFunction "trigger_1" $ + "begin" + <+> " return null;" + <+> "end;" } bankTrigger2 :: Trigger bankTrigger2 = bankTrigger1 { triggerFunction = - "begin" - <+> " return null;" - <+> "end;" + defaultTriggerFunction "trigger_1" $ + "begin" + <+> " return null;" + <+> "end;" } bankTrigger3 :: Trigger @@ -1144,12 +1176,59 @@ , triggerEvents = Set.fromList [TriggerInsert, TriggerUpdateOf [unsafeSQL "location"]] , triggerWhen = Nothing , triggerFunction = - "begin" - <+> " perform true;" - <+> " return null;" - <+> "end;" + defaultTriggerFunction "trigger_3" $ + "begin" + <+> " return null;" + <+> "end;" } +bankTrigger4 :: Trigger +bankTrigger4 = + Trigger + { triggerTable = "bank" + , triggerName = "trigger_4" + , triggerKind = TriggerConstraint DeferrableInitiallyDeferred + , triggerEvents = Set.fromList [TriggerInsert, TriggerUpdateOf [unsafeSQL "location"]] + , triggerWhen = Nothing + , triggerFunction = + Function + { fnName = "trigger_4_fun" + , fnSecurity = Definer + , fnConfigurationParameters = mempty + , fnReturns = "trigger" + , fnBody = + mconcat + [ "BEGIN" + , " RETURN NULL;" + , "END;" + ] + } + } + +bankTrigger5 :: Trigger +bankTrigger5 = + bankTrigger5WithWhiteSpace + { triggerFunction = + (triggerFunction bankTrigger5WithWhiteSpace) + { fnBody = rawSQL (T.strip (unRawSQL (fnBody (triggerFunction bankTrigger5WithWhiteSpace)))) () + } + } + +bankTrigger5WithWhiteSpace :: Trigger +bankTrigger5WithWhiteSpace = + Trigger + { triggerTable = "bank" + , triggerName = "trigger_5" + , triggerKind = TriggerConstraint NotDeferrable + , triggerEvents = Set.fromList [TriggerInsert] + , triggerWhen = Nothing + , triggerFunction = + defaultTriggerFunction "trigger_5" $ + " begin" + <+> " return null;" + <+> "end; " + } + bankTrigger2Proper :: Trigger bankTrigger2Proper = bankTrigger2 {triggerName = "trigger_2"} @@ -1199,6 +1278,36 @@ verify [bankTrigger1] True do + -- Test that we always pull trigger function bodies with stripped whitespace + -- from the database. This means that table definitions with unnecessary whitespace + -- get nudged to remove them. + let msg = "test succeeds validation with whitespaces in trigger definition" + ts = + [ tableBankSchema1 + { tblVersion = 2 + , tblTriggers = [bankTrigger5] + } + ] + ms = [createTriggerMigration 1 bankTrigger5WithWhiteSpace] + triggerStep msg $ do + assertNoException msg $ migrate ts ms + verify [bankTrigger5] True + + do + -- Validates the above by checking if it correctly fails validation if + -- whitespace is seen in a trigger Haskell definition. + let msg = "test fails validation with whitespaces in trigger definition" + ts = + [ tableBankSchema1 + { tblVersion = 2 + , tblTriggers = [bankTrigger5WithWhiteSpace] + } + ] + ms = [createTriggerMigration 1 bankTrigger5WithWhiteSpace] + triggerStep msg $ do + assertException msg $ migrate ts ms + + do -- Attempt to create the same triggers twice. Should fail with a DBException saying -- that function already exists. let msg = "database exception is raised if trigger is created twice" @@ -1429,6 +1538,37 @@ triggerStep msg $ do assertNoException msg $ migrate ts ms verify [trg] True + + do + -- Test that we can create custom trigger functions _and_ read them back + -- for validation. + let trigger = bankTrigger4 + modTrigger f t = t {triggerFunction = f (triggerFunction trigger)} + triggerModifiers = + [ modTrigger (\fn -> fn {fnSecurity = Definer}) + , modTrigger (\fn -> fn {fnSecurity = Invoker}) + , modTrigger (\fn -> fn {fnConfigurationParameters = mempty}) + , modTrigger (\fn -> fn {fnConfigurationParameters = M.singleton "search_path" "pg_catalog"}) + ] + forM_ (zip [1 :: Int ..] (map (\f -> f trigger) triggerModifiers)) $ \(i, trg) -> do + let i' = show i + idSQL = rawSQL (T.pack (show i)) () + msg = "successfully create trigger with custom functions: " <> i' + trg' = + trg + { triggerName = triggerName trg <> idSQL + , triggerFunction = (triggerFunction trg) {fnName = fnName (triggerFunction trg) <> idSQL} + } + ts = + [ tableBankSchema1 + { tblVersion = 2 + , tblTriggers = [trg'] + } + ] + ms = [createTriggerMigration 1 trg'] + triggerStep msg $ do + assertNoException msg $ migrate ts ms + verify [trg'] True where triggerStep msg rest = do recreateTriggerDB @@ -1437,14 +1577,14 @@ migrate tables migrations = do let definitions = tableDefsWithPgCrypto tables - migrateDatabase defaultExtrasOptions definitions migrations - checkDatabase defaultExtrasOptions definitions + migrateDatabase testExtrasOptions definitions migrations + checkDatabase testExtrasOptions definitions -- Verify that the given triggers are (not) present in the database. verify :: (MonadIO m, MonadDB m, HasCallStack) => [Trigger] -> Bool -> m () verify triggers present = do dbTriggers <- getDBTriggers "bank" - let trgs = map fst dbTriggers + let trgs = dbTriggers ok = all (`elem` trgs) triggers err = "Triggers " <> (if present then "" else "not ") <> "present in the database." trans = if present then id else not @@ -1485,8 +1625,8 @@ where migrate tables migrations = do let definitions = tableDefsWithPgCrypto tables - migrateDatabase defaultExtrasOptions definitions migrations - checkDatabase defaultExtrasOptions definitions + migrateDatabase testExtrasOptions definitions migrations + checkDatabase testExtrasOptions definitions testPass = do step "create the initial database" migrate [tableBankSchema1] [createTableMigration tableBankSchema1] @@ -1539,8 +1679,8 @@ where migrate tables migrations = do let definitions = tableDefsWithPgCrypto tables - migrateDatabase defaultExtrasOptions definitions migrations - checkDatabase defaultExtrasOptions definitions + migrateDatabase testExtrasOptions definitions migrations + checkDatabase testExtrasOptions definitions testPass = do step "create the initial database" migrate [tableBadGuySchema1, tableCartelSchema1] [createTableMigration tableBadGuySchema1, createTableMigration tableCartelSchema1] @@ -1662,7 +1802,7 @@ } currentSchema = schema1Tables differentSchema = schema5Tables - extrasOptions = defaultExtrasOptions {eoEnforcePKs = True} + extrasOptions = testExtrasOptions {eoEnforcePKs = True} extrasOptionsWithUnknownObjects = extrasOptions {eoObjectsValidationMode = AllowUnknownObjects} runQuery_ $ sqlCreateComposite composite @@ -1728,11 +1868,11 @@ let withMissingPKSchema = schema6Tables schema1MigrationsWithMissingPK = schema6Migrations optionsNoPKCheck = - defaultExtrasOptions + testExtrasOptions { eoEnforcePKs = False } optionsWithPKCheck = - defaultExtrasOptions + testExtrasOptions { eoEnforcePKs = True } @@ -1831,8 +1971,8 @@ freshTestDB step step "Creating the database (schema version 1)..." - migrateDatabase defaultExtrasOptions (tableDefsWithPgCrypto [table1]) [createTableMigration table1] - checkDatabase defaultExtrasOptions (tableDefsWithPgCrypto [table1]) + migrateDatabase testExtrasOptions (tableDefsWithPgCrypto [table1]) [createTableMigration table1] + checkDatabase testExtrasOptions (tableDefsWithPgCrypto [table1]) step "Populating the 'bank' table..." runQuery_ . sqlInsert "bank" $ do @@ -1847,8 +1987,8 @@ forM_ (zip4 tables migrations steps assertions) $ \(table, migration, step', assertion) -> do step step' - migrateDatabase defaultExtrasOptions (tableDefsWithPgCrypto [table]) [migration] - checkDatabase defaultExtrasOptions (tableDefsWithPgCrypto [table]) + migrateDatabase testExtrasOptions (tableDefsWithPgCrypto [table]) [migration] + checkDatabase testExtrasOptions (tableDefsWithPgCrypto [table]) uncurry assertNoException assertion freshTestDB step @@ -1926,7 +2066,7 @@ Migration { mgrTableName = "bank" , mgrFrom = 2 - , mgrAction = ModifyColumnMigration "bank" cursorSql copyColumnSql 1000 + , mgrAction = ModifyColumnMigration cursorSql copyColumnSql 1000 } copyColumnSql :: MonadDB m => [Identity UUID] -> m () copyColumnSql primaryKeys = @@ -1948,7 +2088,7 @@ Migration { mgrTableName = "bank" , mgrFrom = 4 - , mgrAction = ModifyColumnMigration "bank" cursorSql modifyColumnSql 1000 + , mgrAction = ModifyColumnMigration cursorSql modifyColumnSql 1000 } modifyColumnSql :: MonadDB m => [Identity UUID] -> m () modifyColumnSql primaryKeys = @@ -1987,16 +2127,16 @@ step "Create database with two tables, no foreign key checking" do - let options = defaultExtrasOptions + let options = testExtrasOptions migrateDatabase options (tableDefsWithPgCrypto [table1, table2]) [createTableMigration table1, createTableMigration table2] - checkDatabase defaultExtrasOptions (tableDefsWithPgCrypto [table1, table2]) + checkDatabase testExtrasOptions (tableDefsWithPgCrypto [table1, table2]) step "Create database with two tables, with foreign key checking" do - let options = defaultExtrasOptions {eoCheckForeignKeysIndexes = True} + let options = testExtrasOptions {eoCheckForeignKeysIndexes = True} assertException "Foreign keys are missing" $ migrateDatabase options @@ -2005,7 +2145,7 @@ step "Table is missing several foreign key indexes" do - let options = defaultExtrasOptions {eoCheckForeignKeysIndexes = True} + let options = testExtrasOptions {eoCheckForeignKeysIndexes = True} assertException "Foreign keys are missing" $ migrateDatabase options @@ -2014,7 +2154,7 @@ step "Multi column indexes covering a FK pass the checks" do - let options = defaultExtrasOptions {eoCheckForeignKeysIndexes = True} + let options = testExtrasOptions {eoCheckForeignKeysIndexes = True} migrateDatabase options (tableDefsWithPgCrypto [table4]) @@ -2026,7 +2166,7 @@ checkDatabase options (tableDefsWithPgCrypto [table4]) step "Multi column indexes not covering a FK fail the checks" do - let options = defaultExtrasOptions {eoCheckForeignKeysIndexes = True} + let options = testExtrasOptions {eoCheckForeignKeysIndexes = True} assertException "Foreign keys are missing" $ migrateDatabase options @@ -2125,7 +2265,7 @@ step "Migration is correct if not checking for overlapping indexes" do - let options = defaultExtrasOptions {eoCheckOverlappingIndexes = False} + let options = testExtrasOptions {eoCheckOverlappingIndexes = False} migrateDatabase options definitions @@ -2133,7 +2273,7 @@ step "Migration invalid when flagging overlapping indexes" do - let options = defaultExtrasOptions {eoCheckOverlappingIndexes = True} + let options = testExtrasOptions {eoCheckOverlappingIndexes = True} assertException "Some indexes are overlapping" $ migrateDatabase options @@ -2167,10 +2307,10 @@ do let definitions = tableDefsWithPgCrypto [nullTableTest1, nullTableTest2] migrateDatabase - defaultExtrasOptions + testExtrasOptions definitions [createTableMigration nullTableTest1, createTableMigration nullTableTest2] - checkDatabase defaultExtrasOptions definitions + checkDatabase testExtrasOptions definitions step "Insert two NULLs on a column with a default UNIQUE index" do @@ -2307,16 +2447,16 @@ step "Create a database with an enum" migrateDatabase - defaultExtrasOptions + testExtrasOptions (emptyDbDefinitions {dbEnums = [enum1]}) [] step "Check the database" - checkDatabase defaultExtrasOptions (emptyDbDefinitions {dbEnums = [enum1]}) + checkDatabase testExtrasOptions (emptyDbDefinitions {dbEnums = [enum1]}) step "Check the database with missing enum" do - report <- checkDatabaseWithReport defaultExtrasOptions (emptyDbDefinitions {dbEnums = [enum1, enum2]}) + report <- checkDatabaseWithReport testExtrasOptions (emptyDbDefinitions {dbEnums = [enum1, enum2]}) liftIO $ assertEqual "Missing enum2 should be reported" @@ -2325,7 +2465,7 @@ step "Check the database with reordered enum" do - report <- checkDatabaseWithReport defaultExtrasOptions (emptyDbDefinitions {dbEnums = [enum1misorder]}) + report <- checkDatabaseWithReport testExtrasOptions (emptyDbDefinitions {dbEnums = [enum1misorder]}) liftIO $ assertEqual "Order mismatch should be reported" @@ -2338,7 +2478,7 @@ step "Check the database with mismatching enum" do - report <- checkDatabaseWithReport defaultExtrasOptions (emptyDbDefinitions {dbEnums = [enum1mismatch]}) + report <- checkDatabaseWithReport testExtrasOptions (emptyDbDefinitions {dbEnums = [enum1mismatch]}) liftIO $ assertEqual "DB mismatch should be reported" @@ -2347,7 +2487,7 @@ step "Check the database with extra enum values" do - report <- checkDatabaseWithReport defaultExtrasOptions (emptyDbDefinitions {dbEnums = [enum1missing]}) + report <- checkDatabaseWithReport testExtrasOptions (emptyDbDefinitions {dbEnums = [enum1missing]}) liftIO $ assertEqual "Extra values in the DB enum should be reported" @@ -2416,6 +2556,79 @@ ] } +numericColumnTypeTestTable :: Table +numericColumnTypeTestTable = + tblTable + { tblName = "unicorns" + , tblVersion = 1 + , tblColumns = + [ tblColumn + { colName = "id" + , colType = UuidT + , colNullable = False + , colDefault = Just "gen_random_uuid()" + } + , tblColumn + { colName = "balance" + , colType = NumericT (Just (1000, 0)) + , colCollation = Nothing + , colNullable = False + } + , tblColumn + { colName = "employees" + , colType = NumericT (Just (5, 0)) + , colCollation = Nothing + , colNullable = False + } + , tblColumn + { colName = "baz" + , colType = NumericT (Just (5, -32)) + , colCollation = Nothing + , colNullable = False + } + , tblColumn + { colName = "foo" + , colType = NumericT (Just (5, 2)) + , colCollation = Nothing + , colNullable = False + } + , tblColumn + { colName = "bar" + , colType = NumericT Nothing + , colCollation = Nothing + , colNullable = False + } + ] + , tblPrimaryKey = pkOnColumn "id" + , tblTriggers = [] + } + +numericColumnTypeTestMigration :: MonadDB m => Migration m +numericColumnTypeTestMigration = + let tableName = tblName numericColumnTypeTestTable + in Migration + { mgrTableName = tableName + , mgrFrom = 0 + , mgrAction = StandardMigration $ do + runQuery_ + $ sqlAlterTable + tableName + $ sqlAddColumn <$> tblColumns numericColumnTypeTestTable + } + +numericColumnTypeTest :: ConnectionSourceM (LogT IO) -> TestTree +numericColumnTypeTest connSource = + testCaseSteps' "NUMERIC column test" connSource $ \step -> do + freshTestDB step + + let dbDefinitions = emptyDbDefinitions {dbTables = [numericColumnTypeTestTable]} + + step "run the migration" + migrateDatabase testExtrasOptions dbDefinitions [numericColumnTypeTestMigration] + + step "check database" + checkDatabase testExtrasOptions dbDefinitions + main :: IO () main = do defaultMainWithIngredients ings $ @@ -2426,23 +2639,24 @@ } ConnectionSource connSource = simpleSource connSettings in testGroup - "DB tests" - [ migrationTest1 connSource - , migrationTest2 connSource - , migrationTest3 connSource - , migrationTest4 connSource - , migrationTest5 connSource - , triggerTests connSource - , sqlWithTests connSource - , unionTests connSource - , unionAllTests connSource - , sqlWithRecursiveTests connSource - , foreignKeyIndexesTests connSource - , overlapingIndexesTests connSource - , nullsNotDistinctTests connSource - , sqlAnyAllTests - , enumTest connSource - ] + "DB tests" + [ migrationTest1 connSource + , migrationTest2 connSource + , migrationTest3 connSource + , migrationTest4 connSource + , migrationTest5 connSource + , triggerTests connSource + , sqlWithTests connSource + , unionTests connSource + , unionAllTests connSource + , sqlWithRecursiveTests connSource + , foreignKeyIndexesTests connSource + , overlapingIndexesTests connSource + , nullsNotDistinctTests connSource + , sqlAnyAllTests + , enumTest connSource + , numericColumnTypeTest connSource + ] where ings = includingOptions [Option (Proxy :: Proxy ConnectionString)]