hpqtypes-extras 1.19.0.0 → 1.20.0.0

raw patch · 11 files changed

+605/−226 lines, 11 filesdep +attoparsecdep +ppad-ripemd160dep −cryptondep −memoryPVP ok

version bump matches the API change (PVP)

Dependencies added: attoparsec, ppad-ripemd160

Dependencies removed: crypton, memory

API changes (from Hackage documentation)

Files

• CHANGELOG.md +16/−0
• hpqtypes-extras.cabal +7/−6
• src/Database/PostgreSQL/PQTypes/Checks.hs +101/−73
• src/Database/PostgreSQL/PQTypes/Checks/Util.hs +9/−7
• src/Database/PostgreSQL/PQTypes/Model/ColumnType.hs +27/−3
• src/Database/PostgreSQL/PQTypes/Model/EnumType.hs +5/−0
• src/Database/PostgreSQL/PQTypes/Model/Function.hs +67/−0
• src/Database/PostgreSQL/PQTypes/Model/Index.hs +14/−14
• src/Database/PostgreSQL/PQTypes/Model/Migration.hs +10/−8
• src/Database/PostgreSQL/PQTypes/Model/Trigger.hs +53/−33
• test/Main.hs +296/−82

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

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

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

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

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

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

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

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

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

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

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