From 623a1fe601e39ffcf3dc195579d9eb0ac38b9763 Mon Sep 17 00:00:00 2001 From: sheaf Date: Sat, 21 Mar 2026 10:22:46 +0100 Subject: [PATCH 1/2] beam-migrate: CREATE INDEX support This commit adds functionality to add secondary indices to a database to speed up queries. The user-facing API consists of the 'addTableIndex' function, and the helper 'selectorColumnName' function. Backend support goes via the new typeclass 'IsSql92CreateDropIndexSyntax', with support in both the SQLite and Postgres backends. --- beam-migrate/ChangeLog.md | 8 ++ beam-migrate/Database/Beam/Migrate/Actions.hs | 62 ++++++++++++++- beam-migrate/Database/Beam/Migrate/Backend.hs | 3 - beam-migrate/Database/Beam/Migrate/Checks.hs | 50 +++++++++++- .../Database/Beam/Migrate/SQL/SQL92.hs | 56 ++++++++++++- .../Database/Beam/Migrate/SQL/Types.hs | 3 + beam-migrate/Database/Beam/Migrate/Types.hs | 6 ++ .../Beam/Migrate/Types/CheckedEntities.hs | 79 +++++++++++++++++++ beam-postgres/ChangeLog.md | 9 +++ .../Database/Beam/Postgres/CustomTypes.hs | 3 - .../Database/Beam/Postgres/Migrate.hs | 51 +++++++++++- .../Database/Beam/Postgres/Syntax.hs | 32 +++++++- .../Database/Beam/Postgres/Test/Migrate.hs | 55 ++++++++++++- beam-sqlite/ChangeLog.md | 8 ++ beam-sqlite/Database/Beam/Sqlite/Migrate.hs | 29 ++++++- beam-sqlite/Database/Beam/Sqlite/Syntax.hs | 32 +++++++- .../test/Database/Beam/Sqlite/Test/Migrate.hs | 45 +++++++++++ 17 files changed, 514 insertions(+), 17 deletions(-) diff --git a/beam-migrate/ChangeLog.md b/beam-migrate/ChangeLog.md index 47b7c5988..dcee2268c 100644 --- a/beam-migrate/ChangeLog.md +++ b/beam-migrate/ChangeLog.md @@ -1,5 +1,13 @@ # Unreleased +## Added features + +* Added support for declaring secondary indices on tables. User API is the + `addTableIndex` function, `selectorColumnName` and `foreignKeyColumns` helpers. + Backend support goes through new `IsSql92CreateDropIndexSyntax` (which carries + a per-backend `Sql92CreateIndexOptionsSyntax` data family) and + `IsSql92UniqueIndexSyntax` (for index uniqueness constraints). + ## Updated dependencies * Updated the upper bound on `parallel` to include `parallel-3.3.0.0` diff --git a/beam-migrate/Database/Beam/Migrate/Actions.hs b/beam-migrate/Database/Beam/Migrate/Actions.hs index 5552c17a5..bc821dce5 100644 --- a/beam-migrate/Database/Beam/Migrate/Actions.hs +++ b/beam-migrate/Database/Beam/Migrate/Actions.hs @@ -1,6 +1,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE RecordWildCards #-} @@ -83,6 +84,8 @@ module Database.Beam.Migrate.Actions , addColumnProvider , addColumnNullProvider , dropColumnNullProvider + , createIndexActionProvider + , dropIndexActionProvider , defaultActionProvider , defaultSchemaActionProvider @@ -112,7 +115,6 @@ import qualified Data.Sequence as Seq import Data.Text (Text) import qualified Data.Text as T import Data.Typeable -import Data.Semigroup import GHC.Generics @@ -273,6 +275,10 @@ dropTableWeight = 100 addColumnWeight = 1 dropColumnWeight = 1 +createIndexWeight, dropIndexWeight :: Int +createIndexWeight = 200 +dropIndexWeight = 50 + -- | Proceeds only if no predicate matches the given pattern. See the -- implementation of 'dropTableActionProvider' for an example of usage. ensuringNot_ :: Alternative m => [ a ] -> m () @@ -517,6 +523,60 @@ dropColumnNullProvider = ActionProvider provider (Seq.singleton (MigrationCommand cmd MigrationKeepsData)) ("Drop not null constraint for " <> colNm <> " on " <> qnameAsText tblNm) 100) +-- | Action provider for @CREATE INDEX@ actions. +-- +-- Generates a @CREATE INDEX@ command whenever the destination schema contains +-- a 'TableHasIndex' predicate that is not satisfied in the current state. +createIndexActionProvider :: forall be + . ( BeamMigrateOnlySqlBackend be + , IsSql92UniqueIndexSyntax (BeamSqlBackendSyntax be) ) + => ActionProvider be +createIndexActionProvider = ActionProvider provider + where + provider :: ActionProviderFn be + provider findPreConditions findPostConditions = + do (idxP@(TableHasIndex { hasIndex_table = postTblNm, hasIndex_name = idxNm + , hasIndex_columns = idxCols, hasIndex_opts = idxOpts }) + :: TableHasIndex be) <- findPostConditions + -- Ensure this index doesn't already exist + ensuringNot_ $ + do (TableHasIndex { hasIndex_table = preTblNm, hasIndex_name = idxNm' } + :: TableHasIndex be) <- findPreConditions + guard (preTblNm == postTblNm && idxNm' == idxNm) + -- Ensure the target table already exists + TableExistsPredicate tblNm' <- findPreConditions + guard (tblNm' == postTblNm) + + let cmd = createIndexCmd idxNm (qnameAsTableName postTblNm) idxCols idxOpts + pure (PotentialAction mempty (HS.singleton (p idxP)) + (Seq.singleton (MigrationCommand cmd MigrationKeepsData)) + ("Create index " <> idxNm <> " on " <> qnameAsText postTblNm) + createIndexWeight) + +-- | Action provider for @DROP INDEX@ actions. +dropIndexActionProvider :: forall be + . ( BeamMigrateOnlySqlBackend be + , IsSql92UniqueIndexSyntax (BeamSqlBackendSyntax be) ) + => ActionProvider be +dropIndexActionProvider = ActionProvider provider + where + provider :: ActionProviderFn be + provider findPreConditions findPostConditions = + do (idxP@(TableHasIndex { hasIndex_table = preTblNm, hasIndex_name = idxNm }) + :: TableHasIndex be) <- findPreConditions + ensuringNot_ $ + do (TableHasIndex { hasIndex_table = postTblNm, hasIndex_name = idxNm' } + :: TableHasIndex be) <- findPostConditions + guard (preTblNm == postTblNm && idxNm' == idxNm) + + let cmd = dropIndexCmd idxNm + pure (PotentialAction (HS.singleton (p idxP)) mempty + -- Dropping a secondary index doesn't lose data, as the index + -- can be recalculated. + (Seq.singleton (MigrationCommand cmd MigrationKeepsData)) + ("Drop index " <> idxNm <> " on " <> qnameAsText preTblNm) + dropIndexWeight) + -- | Default action providers for any SQL92 compliant syntax. -- -- In particular, this provides edges consisting of the following statements: diff --git a/beam-migrate/Database/Beam/Migrate/Backend.hs b/beam-migrate/Database/Beam/Migrate/Backend.hs index dc1c18122..e2b62f208 100644 --- a/beam-migrate/Database/Beam/Migrate/Backend.hs +++ b/beam-migrate/Database/Beam/Migrate/Backend.hs @@ -54,9 +54,6 @@ import Database.Beam.Haskell.Syntax import Control.Applicative import qualified Control.Monad.Fail as Fail -#if ! MIN_VERSION_base(4,11,0) -import Data.Semigroup -#endif import Data.Text (Text) import Data.Time diff --git a/beam-migrate/Database/Beam/Migrate/Checks.hs b/beam-migrate/Database/Beam/Migrate/Checks.hs index e778af6b2..03b907c87 100644 --- a/beam-migrate/Database/Beam/Migrate/Checks.hs +++ b/beam-migrate/Database/Beam/Migrate/Checks.hs @@ -4,6 +4,7 @@ -- | Defines common 'DatabasePredicate's that are shared among backends module Database.Beam.Migrate.Checks where +import Database.Beam.Backend.SQL (BeamSqlBackendSyntax) import Database.Beam.Backend.SQL.SQL92 import Database.Beam.Migrate.SQL.SQL92 import Database.Beam.Migrate.SQL.Types @@ -13,6 +14,7 @@ import Database.Beam.Migrate.Types.Predicates import Data.Aeson ((.:), (.=), withObject, object) import Data.Aeson.Types (Parser, Value) import Data.Hashable (Hashable(..)) +import qualified Data.List.NonEmpty as NE (NonEmpty) import Data.Text (Text) import Data.Typeable (Typeable, cast) @@ -111,6 +113,39 @@ instance ( Typeable be, BeamMigrateOnlySqlBackend be | Just (TableHasColumn tblNm' colNm' _ :: TableHasColumn be) <- cast p' = tblNm' == tblNm && colNm' == colNm | otherwise = False +-- | Asserts that the given table has a secondary index with the given name +-- covering the given columns (in order). Create these predicates with +-- 'Database.Beam.Migrate.Types.CheckedEntities.addTableIndex'. +data TableHasIndex be + = TableHasIndex + { hasIndex_table :: QualifiedName -- ^ table name + , hasIndex_name :: Text -- ^ index name + , hasIndex_columns :: NE.NonEmpty Text -- ^ ordered column names + , hasIndex_opts :: BeamSqlBackendIndexSyntax be -- ^ index options (e.g. uniqueness) + } deriving Generic +deriving instance Show (BeamSqlBackendIndexSyntax be) => Show (TableHasIndex be) +deriving instance Eq (BeamSqlBackendIndexSyntax be) => Eq (TableHasIndex be) +instance Hashable (BeamSqlBackendIndexSyntax be) => Hashable (TableHasIndex be) +instance ( Typeable be + , IsSql92UniqueIndexSyntax (BeamSqlBackendSyntax be) ) => + DatabasePredicate (TableHasIndex be) where + englishDescription (TableHasIndex { hasIndex_table = tbl, hasIndex_name = nm + , hasIndex_columns = cols, hasIndex_opts = opts }) = + (if indexIsUnique opts then "Unique index " else "Index ") <> + show nm <> " on table " <> show tbl <> " covering columns " <> show cols + + predicateSpecificity _ = PredicateSpecificityAllBackends + + serializePredicate (TableHasIndex { hasIndex_table = tbl, hasIndex_name = nm + , hasIndex_columns = cols, hasIndex_opts = opts }) = + object [ "has-index" .= object [ "table" .= tbl, "name" .= nm + , "columns" .= cols + , "options" .= serializeIndexOptions opts ] ] + + predicateCascadesDropOn (TableHasIndex { hasIndex_table = tblNm }) p' + | Just (TableExistsPredicate tblNm') <- cast p' = tblNm' == tblNm + | otherwise = False + -- | Asserts that the given table has a primary key made of the given columns. -- The order of the columns is significant. data TableHasPrimaryKey @@ -139,12 +174,14 @@ instance DatabasePredicate TableHasPrimaryKey where beamCheckDeserializers :: forall be . ( Typeable be, BeamMigrateOnlySqlBackend be - , HasDataTypeCreatedCheck (BeamMigrateSqlBackendDataTypeSyntax be) ) + , HasDataTypeCreatedCheck (BeamMigrateSqlBackendDataTypeSyntax be) + , IsSql92UniqueIndexSyntax (BeamSqlBackendSyntax be) ) => BeamDeserializers be beamCheckDeserializers = mconcat [ beamDeserializer (const deserializeSchemaExistsPredicate) , beamDeserializer (const deserializeTableExistsPredicate) , beamDeserializer (const deserializeTableHasPrimaryKeyPredicate) + , beamDeserializer (const deserializeTableHasIndexPredicate) , beamDeserializer deserializeTableHasColumnPredicate , beamDeserializer deserializeTableColumnHasConstraintPredicate ] @@ -166,6 +203,17 @@ beamCheckDeserializers = mconcat (withObject "TableHasPrimaryKey" $ \v' -> SomeDatabasePredicate <$> (TableHasPrimaryKey <$> v' .: "table" <*> v' .: "columns")) + deserializeTableHasIndexPredicate :: Value -> Parser SomeDatabasePredicate + deserializeTableHasIndexPredicate = + withObject "TableHasIndex" $ \v -> + v .: "has-index" >>= + (withObject "TableHasIndex" $ \v' -> + SomeDatabasePredicate <$> + fmap (id @(TableHasIndex be)) + (TableHasIndex <$> v' .: "table" <*> v' .: "name" + <*> v' .: "columns" + <*> (deserializeIndexOptions =<< v' .: "options"))) + deserializeTableHasColumnPredicate :: BeamDeserializers be' -> Value -> Parser SomeDatabasePredicate deserializeTableHasColumnPredicate d = diff --git a/beam-migrate/Database/Beam/Migrate/SQL/SQL92.hs b/beam-migrate/Database/Beam/Migrate/SQL/SQL92.hs index 930bddc0a..b70fa86c5 100644 --- a/beam-migrate/Database/Beam/Migrate/SQL/SQL92.hs +++ b/beam-migrate/Database/Beam/Migrate/SQL/SQL92.hs @@ -11,13 +11,12 @@ module Database.Beam.Migrate.SQL.SQL92 where import Database.Beam.Backend.SQL.SQL92 import Data.Aeson (Value) +import Data.Aeson.Types (Parser) import Data.Hashable import Data.Kind (Type) +import qualified Data.List.NonEmpty as NE (NonEmpty) import Data.Text (Text) import Data.Typeable -#if ! MIN_VERSION_base(4,11,0) -import Data.Semigroup -#endif -- * Convenience type synonyms @@ -240,3 +239,54 @@ class Sql92SerializableDataTypeSyntax dataType where -- | 'IsSql92ColumnConstraintDefinitionSyntax'es that can be serialized to JSON class Sql92SerializableConstraintDefinitionSyntax constraint where serializeConstraint :: constraint -> Value + +-- | Syntax extension for @CREATE INDEX@ and @DROP INDEX@ DDL commands. +-- +-- @CREATE INDEX@ is not part of SQL92 proper, but is a widely supported +-- extension. +class ( IsSql92DdlCommandSyntax syntax + , Show (Sql92CreateIndexOptionsSyntax syntax) + , Eq (Sql92CreateIndexOptionsSyntax syntax) + , Hashable (Sql92CreateIndexOptionsSyntax syntax) + ) => IsSql92CreateDropIndexSyntax syntax where + data family Sql92CreateIndexOptionsSyntax syntax + + -- | Render a @CREATE INDEX@ command. + createIndexCmd + :: Text -- ^ index name + -> Sql92CreateTableTableNameSyntax (Sql92DdlCommandCreateTableSyntax syntax) + -- ^ table name + -> NE.NonEmpty Text -- ^ ordered column names + -> Sql92CreateIndexOptionsSyntax syntax -- ^ index options + -> syntax + + -- | Render a @DROP INDEX@ command. + dropIndexCmd + :: Text -- ^ index name + -> syntax + + -- | Default options for @CREATE INDEX@ + defaultIndexOptions + :: Sql92CreateIndexOptionsSyntax syntax + + -- | Serialize index options to a JSON 'Value', for predicate storage. + serializeIndexOptions :: Sql92CreateIndexOptionsSyntax syntax -> Value + -- | Deserialize index options from the JSON 'Value' produced by + -- 'serializeIndexOptions'. + deserializeIndexOptions :: Value -> Parser (Sql92CreateIndexOptionsSyntax syntax) + +-- | Class for index syntaxes that support the SQL @UNIQUE@ modifier. +-- +-- Backends implementing 'IsSql92CreateDropIndexSyntax' should also implement +-- this class to expose uniqueness as a portable concept, while still allowing +-- their 'Sql92CreateIndexOptionsSyntax' to carry additional backend-specific +-- options (e.g. index type, partial-index predicates). +class IsSql92CreateDropIndexSyntax syntax => IsSql92UniqueIndexSyntax syntax where + + -- | Update index options by setting the uniqueness + setUniqueIndexOptions :: Bool -- ^ unique? + -> Sql92CreateIndexOptionsSyntax syntax + -> Sql92CreateIndexOptionsSyntax syntax + + -- | Query whether an index is unique, as specified in the index options. + indexIsUnique :: Sql92CreateIndexOptionsSyntax syntax -> Bool diff --git a/beam-migrate/Database/Beam/Migrate/SQL/Types.hs b/beam-migrate/Database/Beam/Migrate/SQL/Types.hs index 086cb80d6..e7e928ea8 100644 --- a/beam-migrate/Database/Beam/Migrate/SQL/Types.hs +++ b/beam-migrate/Database/Beam/Migrate/SQL/Types.hs @@ -18,6 +18,7 @@ module Database.Beam.Migrate.SQL.Types , BeamSqlBackendMatchTypeSyntax , BeamSqlBackendReferentialActionSyntax , BeamSqlBackendConstraintAttributesSyntax + , BeamSqlBackendIndexSyntax ) where import Database.Beam.Migrate.Types.Predicates @@ -91,3 +92,5 @@ type BeamSqlBackendReferentialActionSyntax be = Sql92DdlCommandReferentialActionSyntax (BeamSqlBackendSyntax be) type BeamSqlBackendConstraintAttributesSyntax be = Sql92DdlCommandConstraintAttributesSyntax (BeamSqlBackendSyntax be) +type BeamSqlBackendIndexSyntax be + = Sql92CreateIndexOptionsSyntax (BeamSqlBackendSyntax be) \ No newline at end of file diff --git a/beam-migrate/Database/Beam/Migrate/Types.hs b/beam-migrate/Database/Beam/Migrate/Types.hs index 0e971a98f..6f3f7230b 100644 --- a/beam-migrate/Database/Beam/Migrate/Types.hs +++ b/beam-migrate/Database/Beam/Migrate/Types.hs @@ -24,6 +24,11 @@ module Database.Beam.Migrate.Types , modifyCheckedTable , checkedTableModification + , addTableIndex + , selectorColumnName + , foreignKeyColumns + + , IsSql92CreateDropIndexSyntax(..) -- * Predicates , DatabasePredicate(..) @@ -50,6 +55,7 @@ module Database.Beam.Migrate.Types , migrateScript, evaluateDatabase, stepNames ) where import Database.Beam.Backend.SQL +import Database.Beam.Migrate.SQL.SQL92 import Database.Beam.Migrate.Types.CheckedEntities import Database.Beam.Migrate.Types.Predicates import Control.Monad.Free.Church diff --git a/beam-migrate/Database/Beam/Migrate/Types/CheckedEntities.hs b/beam-migrate/Database/Beam/Migrate/Types/CheckedEntities.hs index cd301e8bc..f8a9b6bdb 100644 --- a/beam-migrate/Database/Beam/Migrate/Types/CheckedEntities.hs +++ b/beam-migrate/Database/Beam/Migrate/Types/CheckedEntities.hs @@ -8,6 +8,8 @@ import Database.Beam.Backend.SQL import Database.Beam.Schema.Tables import Database.Beam.Migrate.Checks +import Database.Beam.Migrate.SQL.SQL92 +import Database.Beam.Migrate.SQL.Types (BeamSqlBackendIndexSyntax) import Database.Beam.Migrate.Generics.Tables import Database.Beam.Migrate.Types.Predicates @@ -16,6 +18,7 @@ import Control.Monad.Writer import Control.Monad.Identity import Data.Kind (Constraint, Type) +import qualified Data.List.NonEmpty as NE (NonEmpty, nonEmpty) import Data.Maybe import Data.Monoid import Data.Proxy @@ -219,6 +222,82 @@ modifyCheckedTable renamer modFields = , dbTableSettings = fields'}) tblChecks fieldChecks') extraChecks +-- | Lift a field accessor into a column-name reference, for use with +-- 'addTableIndex'. +-- +-- See also 'foreignKeyColumns'. +selectorColumnName :: (tbl (TableField tbl) -> TableField tbl a) + -> tbl (TableField tbl) + -> Text +selectorColumnName f = (^. fieldName) . f + +-- | Expand a foreign-key accessor into its constituent column-name references, +-- for use with 'addTableIndex'. +-- +-- Example: +-- +-- @ +-- data UserT f = User +-- { userId :: C f Int32 +-- , userName :: C f Text +-- } +-- instance Table UserT where +-- newtype PrimaryKey UserT f = UserId (C f Int32) +-- primaryKey (User {userId = i}) = UserId i +-- data OrderT f = Order +-- { orderUser :: PrimaryKey UserT f +-- , orderDate :: C f Day +-- } +-- @ +-- +-- @ +-- addTableIndex "idx_orders_user" indexOptions +-- (\\t -> foreignKeyColumns orderUser t) +-- @ +-- +-- Can be combined with 'selectorColumnName' for composite indices. +foreignKeyColumns :: Beamable (PrimaryKey ref) + => (tbl (TableField tbl) -> PrimaryKey ref (TableField tbl)) + -> tbl (TableField tbl) + -> NE.NonEmpty Text +foreignKeyColumns f t = + case NE.nonEmpty $ allBeamValues (\(Columnar' field) -> field ^. fieldName) pkey of + Nothing -> error $ "foreignKeyColumns: foreign key has no fields" + Just cols -> cols + where + pkey = f t + +-- | Automatically extracts all column names from a table's primary key +primaryKeyColumns :: Table tbl => tbl (TableField tbl) -> NE.NonEmpty Text +primaryKeyColumns tbl = + case NE.nonEmpty $ allBeamValues (\(Columnar' field) -> field ^. fieldName) (primaryKey tbl) of + Nothing -> error "primaryKeyColumns: primary key has no fields" + Just cols -> cols + +-- | Declare a secondary index on a checked table entity. +-- +-- Example: +-- +-- @ +-- addTableIndex "table_index" uniqueIndexOptions +-- (\\t -> selectorColumnName tableField1 t NE.:| [selectorColumnName tableField2 t]) +-- @ +addTableIndex :: forall be tbl db + . ( Typeable be + , IsSql92UniqueIndexSyntax (BeamSqlBackendSyntax be) ) + => Text -- ^ SQL index name + -> BeamSqlBackendIndexSyntax be -- ^ index options (e.g. 'nonUniqueIndexOptions', 'uniqueIndexOptions') + -> (tbl (TableField tbl) -> NE.NonEmpty Text) -- ^ column names to index (use 'selectorColumnName') + -> EntityModification (CheckedDatabaseEntity be db) be (TableEntity tbl) +addTableIndex idxNm opts getCols = + EntityModification $ Endo $ + \(CheckedDatabaseEntity (CheckedDatabaseTable dt tblChecks fieldChecks) extraChecks) -> + let cols = getCols (dbTableSettings dt) + idxCheck = TableCheck $ \ tblNm _flds -> + Just (SomeDatabasePredicate (TableHasIndex tblNm idxNm cols opts :: TableHasIndex be)) + in CheckedDatabaseEntity (CheckedDatabaseTable dt (tblChecks ++ [idxCheck]) fieldChecks) + extraChecks + -- | Produce a table field modification that does nothing -- -- Most commonly supplied as the second argument to 'modifyCheckedTable' when diff --git a/beam-postgres/ChangeLog.md b/beam-postgres/ChangeLog.md index 0e49c175f..ae2fc6ef0 100644 --- a/beam-postgres/ChangeLog.md +++ b/beam-postgres/ChangeLog.md @@ -1,3 +1,12 @@ +# Unreleased + +## Added features + +* Add support for creating secondary indices, supporting both `CREATE INDEX` and + `CREATE UNIQUE INDEX`. `getDbConstraintsForSchemas` now discovers user-created + secondary indices via `pg_index` (excluding primary keys and + constraint-backing indices). + # 0.5.4.4 ## Added features diff --git a/beam-postgres/Database/Beam/Postgres/CustomTypes.hs b/beam-postgres/Database/Beam/Postgres/CustomTypes.hs index 9e4ecf736..12605331a 100644 --- a/beam-postgres/Database/Beam/Postgres/CustomTypes.hs +++ b/beam-postgres/Database/Beam/Postgres/CustomTypes.hs @@ -40,9 +40,6 @@ import qualified Data.ByteString.Char8 as BC import Data.Functor.Const import qualified Data.HashSet as HS import Data.Proxy (Proxy(..)) -#if !MIN_VERSION_base(4,11,0) -import Data.Semigroup -#endif import Data.Text (Text) import qualified Data.Text.Encoding as TE diff --git a/beam-postgres/Database/Beam/Postgres/Migrate.hs b/beam-postgres/Database/Beam/Postgres/Migrate.hs index d337bd1d3..51d086716 100644 --- a/beam-postgres/Database/Beam/Postgres/Migrate.hs +++ b/beam-postgres/Database/Beam/Postgres/Migrate.hs @@ -31,7 +31,8 @@ module Database.Beam.Postgres.Migrate ) where import Database.Beam.Backend.SQL -import Database.Beam.Migrate.Actions (defaultActionProvider, defaultSchemaActionProvider) +import Database.Beam.Migrate.Actions (defaultActionProvider, defaultSchemaActionProvider, + createIndexActionProvider, dropIndexActionProvider) import qualified Database.Beam.Migrate.Backend as Tool import qualified Database.Beam.Migrate.Checks as Db import qualified Database.Beam.Migrate.SQL as Db @@ -65,6 +66,7 @@ import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.Char8 as BCL import qualified Data.HashMap.Strict as HM import Data.Int +import qualified Data.List.NonEmpty as NE (nonEmpty) import Data.Maybe import Data.String import qualified Data.Text as T @@ -102,6 +104,8 @@ migrationBackend = Tool.BeamMigrationBackend , Tool.backendActionProvider = mconcat [ defaultActionProvider , defaultSchemaActionProvider + , createIndexActionProvider + , dropIndexActionProvider , pgExtensionActionProvider , pgCustomEnumActionProvider ] @@ -402,6 +406,49 @@ getDbConstraintsForSchemas subschemas conn = -- Recall that schema of the form 'pg_' are Postgres internal tables that should not be taken into account , "WHERE nspname NOT LIKE '%pg_%' AND c.relkind='r' AND i.indisprimary GROUP BY nspname, relname, i.indrelid" ])) + -- Collect user-created secondary indices. + -- + -- Excludes: + -- - primary keys + -- - indices that back a constraint (i.e. those created implicitly by UNIQUE/EXCLUDE) + -- - expression indices e.g. CREATE INDEX ON users (LOWER(email)) + secondaryIndices <- + mapMaybe (\(schema, tblNm, idxNm, isUniq, cols) -> + case NE.nonEmpty (V.toList cols) of + Nothing -> Nothing + Just colsNE -> + Just $ + Db.SomeDatabasePredicate + (Db.TableHasIndex (Db.QualifiedName schema tblNm) idxNm colsNE + (Db.setUniqueIndexOptions isUniq Db.defaultIndexOptions) + :: Db.TableHasIndex Postgres)) <$> + Pg.query_ conn (fromString (unlines + [ -- NULL out 'public' since it is the implicit default schema in Postgres + "SELECT NULLIF(ns.nspname, 'public'), c.relname, i.relname, ix.indisunique," + -- re-aggregate column names in index-key order (see ORDINALITY below) + , " array_agg(a.attname ORDER BY k.n ASC)" + , "FROM pg_index ix" + , "JOIN pg_class c ON c.oid = ix.indrelid" + , "JOIN pg_class i ON i.oid = ix.indexrelid" + , "JOIN pg_namespace ns ON ns.oid = c.relnamespace" + -- ORDINALITY allows retaining ordering of index columns + , "CROSS JOIN unnest(ix.indkey) WITH ORDINALITY k(attid, n)" + , "JOIN pg_attribute a ON a.attnum = k.attid AND a.attrelid = ix.indrelid" + -- only regular tables (not views, sequences, etc.) + , "WHERE c.relkind = 'r'" + -- exclude Postgres system schemas + , " AND ns.nspname NOT LIKE 'pg_%'" + , " AND ns.nspname != 'information_schema'" + -- exclude primary key indices + , " AND NOT ix.indisprimary" + -- exclude indices created implicitly by a UNIQUE or EXCLUDE constraint + , " AND NOT EXISTS (SELECT 1 FROM pg_constraint con WHERE con.conindid = ix.indexrelid)" + -- exclude expression indices: a key column number of 0 means that + -- position is an expression (e.g. lower(col)) rather than a plain + -- column reference, which TableHasIndex cannot represent + , " AND NOT EXISTS (SELECT 1 FROM unnest(ix.indkey) AS k(attnum) WHERE k.attnum = 0)" + , "GROUP BY ns.nspname, c.relname, i.relname, ix.indisunique" ])) + let enumerations = map (\(enumNm, _, options) -> Db.SomeDatabasePredicate (PgHasEnum enumNm (V.toList options))) enumerationData @@ -409,7 +456,7 @@ getDbConstraintsForSchemas subschemas conn = map (\(Pg.Only extname) -> Db.SomeDatabasePredicate (PgHasExtension extname)) <$> Pg.query_ conn "SELECT extname from pg_extension" - pure (tblsExist ++ columnChecks ++ primaryKeys ++ enumerations ++ extensions) + pure (tblsExist ++ columnChecks ++ primaryKeys ++ secondaryIndices ++ enumerations ++ extensions) -- * Postgres-specific data types diff --git a/beam-postgres/Database/Beam/Postgres/Syntax.hs b/beam-postgres/Database/Beam/Postgres/Syntax.hs index 59925d04e..c94fa5ab9 100644 --- a/beam-postgres/Database/Beam/Postgres/Syntax.hs +++ b/beam-postgres/Database/Beam/Postgres/Syntax.hs @@ -46,6 +46,7 @@ module Database.Beam.Postgres.Syntax , PgAlterTableSyntax(..), PgAlterTableActionSyntax(..), PgAlterColumnActionSyntax(..) + , PgWindowFrameSyntax(..), PgWindowFrameBoundsSyntax(..), PgWindowFrameBoundSyntax(..) , PgSelectLockingClauseSyntax(..) @@ -97,7 +98,7 @@ import Control.Monad (guard) import Control.Monad.Free import Control.Monad.Free.Church -import Data.Aeson (Value, object, (.=)) +import Data.Aeson (Value, object, withObject, (.=), (.:)) import Data.Bits import Data.ByteString (ByteString) import Data.ByteString.Builder (Builder, doubleDec, floatDec, byteString, char8, toLazyByteString) @@ -110,6 +111,7 @@ import Data.Coerce import Data.Functor.Classes import Data.Hashable import Data.Int +import qualified Data.List.NonEmpty as NE (toList) import Data.Maybe import Data.Scientific (Scientific) import Data.String (IsString(..), fromString) @@ -427,6 +429,34 @@ instance IsSql92DdlCommandSyntax PgCommandSyntax where dropTableCmd = PgCommandSyntax PgCommandTypeDdl . coerce alterTableCmd = PgCommandSyntax PgCommandTypeDdl . coerce +instance IsSql92CreateDropIndexSyntax PgCommandSyntax where + newtype instance Sql92CreateIndexOptionsSyntax PgCommandSyntax = + PgIndexOptions { pgIndexUnique :: Bool } + deriving (Show, Eq, Hashable) + + defaultIndexOptions = PgIndexOptions { pgIndexUnique = False } + + createIndexCmd idxNm tblNm cols opts = + PgCommandSyntax PgCommandTypeDdl $ + emit (if pgIndexUnique opts then "CREATE UNIQUE INDEX " else "CREATE INDEX ") <> + pgQuotedIdentifier idxNm <> + emit " ON " <> fromPgTableName tblNm <> + pgParens (pgSepBy (emit ", ") (NE.toList $ fmap pgQuotedIdentifier cols)) + + dropIndexCmd idxNm = + PgCommandSyntax PgCommandTypeDdl (emit "DROP INDEX " <> pgQuotedIdentifier idxNm) + + serializeIndexOptions opts = + object ["unique" .= pgIndexUnique opts] + + deserializeIndexOptions = + withObject "PgIndexOptions" $ \v -> + PgIndexOptions <$> v .: "unique" + +instance IsSql92UniqueIndexSyntax PgCommandSyntax where + setUniqueIndexOptions u opts = opts { pgIndexUnique = u } + indexIsUnique opts = pgIndexUnique opts + instance IsSql92SchemaNameSyntax PgSchemaNameSyntax where schemaName s = PgSchemaNameSyntax (pgQuotedIdentifier s) diff --git a/beam-postgres/test/Database/Beam/Postgres/Test/Migrate.hs b/beam-postgres/test/Database/Beam/Postgres/Test/Migrate.hs index 07a4180df..9275f7c20 100644 --- a/beam-postgres/test/Database/Beam/Postgres/Test/Migrate.hs +++ b/beam-postgres/test/Database/Beam/Postgres/Test/Migrate.hs @@ -10,8 +10,12 @@ import Database.Beam.Migrate import Database.Beam.Migrate.Simple import Data.ByteString (ByteString) +import Data.Int (Int32) +import qualified Data.List.NonEmpty as NE import Data.Text (Text) +import qualified Database.PostgreSQL.Simple as Pg + import Test.Tasty import Test.Tasty.HUnit @@ -25,6 +29,8 @@ tests postgresConn = , extensionVerification postgresConn , createTableWithSchemaWorks postgresConn , dropSchemaWorks postgresConn + , indexVerification postgresConn + , uniqueIndexVerification postgresConn ] data CharT f @@ -136,4 +142,51 @@ dropSchemaWorks pgConn = verifySchema migrationBackend db >>= \case VerificationFailed failures -> fail ("Verification failed: " ++ show failures) - VerificationSucceeded -> pure () \ No newline at end of file + VerificationSucceeded -> pure () + +-- Shared table type for index tests + +newtype IdxT f = IdxT + { _idx_value :: C f Int32 + } deriving (Generic, Beamable) + +instance Table IdxT where + newtype PrimaryKey IdxT f = IdxPk (C f Int32) + deriving (Generic, Beamable) + primaryKey = IdxPk . _idx_value + +data IdxDb entity = IdxDb + { _idx_tbl :: entity (TableEntity IdxT) + } deriving (Generic, Database Postgres) + +-- | Verifies that 'verifySchema' correctly detects a secondary index +indexVerification :: IO ByteString -> TestTree +indexVerification pgConn = + testCase "verifySchema correctly detects a secondary index" $ + withTestPostgres "db_index" pgConn $ \conn -> do + Pg.execute_ conn "CREATE TABLE idx_tbl (idx_value integer NOT NULL PRIMARY KEY)" + Pg.execute_ conn "CREATE INDEX idx_tbl_value ON idx_tbl (idx_value)" + let db :: CheckedDatabaseSettings Postgres IdxDb + db = defaultMigratableDbSettings `withDbModification` + (dbModification @_ @Postgres) + { _idx_tbl = addTableIndex "idx_tbl_value" defaultIndexOptions + (\t -> selectorColumnName _idx_value t NE.:| []) } + runBeamPostgres conn (verifySchema migrationBackend db) >>= \case + VerificationSucceeded -> return () + VerificationFailed failures -> fail ("Verification failed: " ++ show failures) + +-- | Verifies that 'verifySchema' correctly detects a UNIQUE secondary index +uniqueIndexVerification :: IO ByteString -> TestTree +uniqueIndexVerification pgConn = + testCase "verifySchema correctly detects a UNIQUE secondary index" $ + withTestPostgres "db_unique_index" pgConn $ \conn -> do + Pg.execute_ conn "CREATE TABLE idx_tbl (idx_value integer NOT NULL PRIMARY KEY)" + Pg.execute_ conn "CREATE UNIQUE INDEX idx_tbl_value_uniq ON idx_tbl (idx_value)" + let db :: CheckedDatabaseSettings Postgres IdxDb + db = defaultMigratableDbSettings `withDbModification` + (dbModification @_ @Postgres) + { _idx_tbl = addTableIndex "idx_tbl_value_uniq" (setUniqueIndexOptions True defaultIndexOptions) + (\t -> selectorColumnName _idx_value t NE.:| []) } + runBeamPostgres conn (verifySchema migrationBackend db) >>= \case + VerificationSucceeded -> return () + VerificationFailed failures -> fail ("Verification failed: " ++ show failures) \ No newline at end of file diff --git a/beam-sqlite/ChangeLog.md b/beam-sqlite/ChangeLog.md index 31944837a..2e6c8c049 100644 --- a/beam-sqlite/ChangeLog.md +++ b/beam-sqlite/ChangeLog.md @@ -1,3 +1,11 @@ +# Unreleased + +## Added features + +* Add support for creating secondary indices (`CREATE INDEX` and + `CREATE UNIQUE INDEX`), including discovering user-created secondary indices + via `PRAGMA index_list` / `PRAGMA index_info`. + # 0.5.6.0 ## Performance optimizations diff --git a/beam-sqlite/Database/Beam/Sqlite/Migrate.hs b/beam-sqlite/Database/Beam/Sqlite/Migrate.hs index bc0a7c137..30149d8f6 100644 --- a/beam-sqlite/Database/Beam/Sqlite/Migrate.hs +++ b/beam-sqlite/Database/Beam/Sqlite/Migrate.hs @@ -41,6 +41,7 @@ import qualified Data.ByteString.Lazy.Char8 as BL import Data.Char (isSpace) import Data.Int (Int64) import Data.List (sortBy) +import qualified Data.List.NonEmpty as NE (nonEmpty) import Data.Maybe (mapMaybe, isJust) import Data.Monoid (Endo(..)) import Data.Ord (comparing) @@ -64,6 +65,8 @@ mkCustomMigrationBackend extraParser = , Tool.backendFileExtension = "sqlite.sql" , Tool.backendConvertToHaskell = sqlitePredConverter , Tool.backendActionProvider = Db.defaultActionProvider + <> Db.createIndexActionProvider + <> Db.dropIndexActionProvider , Tool.backendRunSqlScript = runSqlScript , Tool.backendWithTransaction = \(SqliteM go) -> @@ -320,8 +323,32 @@ getDbConstraints extraParser = pkPred = case pkColumns of [] -> [] _ -> [ Db.SomeDatabasePredicate (Db.TableHasPrimaryKey tblName pkColumns) ] + + -- Collect user-created secondary indices (origin = 'c') for this table. + -- SQLite's PRAGMA index_list returns (seq, name, unique, origin, partial). + -- PRAGMA index_info returns (seqno, cid, name) ordered by seqno. + idxRows <- query_ conn (fromString ("PRAGMA index_list('" <> T.unpack tblNameStr <> "')") + ) :: IO [(Int, T.Text, Int, T.Text, Int)] + idxPreds <- fmap concat . forM idxRows $ + \(_, idxNm, isUniq, origin, _) -> + if origin /= T.pack "c" + then pure [] + else do + colRows <- query_ conn (fromString ("PRAGMA index_info('" <> T.unpack idxNm <> "')") + ) :: IO [(Int, Int, T.Text)] + let cols = map (\(_, _, nm) -> nm) $ + sortBy (comparing (\(seqno, _, _) -> seqno)) colRows + pure $ + case NE.nonEmpty cols of + Nothing -> [] + Just colsNE -> + [ Db.SomeDatabasePredicate + (Db.TableHasIndex tblName idxNm colsNE + (Db.setUniqueIndexOptions (isUniq /= (0 :: Int)) Db.defaultIndexOptions) + :: Db.TableHasIndex Sqlite) ] + pure ( [ Db.SomeDatabasePredicate (Db.TableExistsPredicate tblName) ] - ++ pkPred ++ columnPreds ) + ++ pkPred ++ columnPreds ++ idxPreds ) pure tblPreds diff --git a/beam-sqlite/Database/Beam/Sqlite/Syntax.hs b/beam-sqlite/Database/Beam/Sqlite/Syntax.hs index 63859c3b5..99cbb1c5b 100644 --- a/beam-sqlite/Database/Beam/Sqlite/Syntax.hs +++ b/beam-sqlite/Database/Beam/Sqlite/Syntax.hs @@ -55,7 +55,7 @@ import Database.Beam.Migrate.Serialization import qualified Database.Beam.Migrate.Serialization as Db import Database.Beam.Query hiding (ExtractField(..)) -import Data.Aeson (object, (.=)) +import Data.Aeson (object, withObject, (.=), (.:)) import Data.ByteString (ByteString) import qualified Data.ByteString as B import Data.ByteString.Builder @@ -64,6 +64,7 @@ import Data.Coerce import qualified Data.DList as DL import Data.Hashable import Data.Int +import qualified Data.List.NonEmpty as NE (toList) import Data.Maybe import Data.Scientific import Data.String @@ -981,3 +982,32 @@ instance HasSqlValueSyntax SqliteValueSyntax Day where instance HasDataTypeCreatedCheck SqliteDataTypeSyntax where dataTypeHasBeenCreated _ _ = True + +instance IsSql92CreateDropIndexSyntax SqliteCommandSyntax where + newtype instance Sql92CreateIndexOptionsSyntax SqliteCommandSyntax = + SqliteIndexOptions { sqliteIndexUnique :: Bool } + deriving (Show, Eq, Hashable) + + defaultIndexOptions = SqliteIndexOptions { sqliteIndexUnique = False } + + createIndexCmd idxNm tblNm cols opts = + SqliteCommandSyntax $ + emit (if sqliteIndexUnique opts then "CREATE UNIQUE INDEX " else "CREATE INDEX ") <> + quotedIdentifier idxNm <> + emit " ON " <> fromSqliteTableName tblNm <> + parens (commas (NE.toList $ fmap quotedIdentifier cols)) + + dropIndexCmd idxNm = + SqliteCommandSyntax (emit "DROP INDEX " <> quotedIdentifier idxNm) + + serializeIndexOptions opts = + object ["unique" .= sqliteIndexUnique opts] + + deserializeIndexOptions = + withObject "SqliteIndexOptions" $ \v -> + SqliteIndexOptions <$> v .: "unique" + +instance IsSql92UniqueIndexSyntax SqliteCommandSyntax where + + setUniqueIndexOptions u opts = opts { sqliteIndexUnique = u } + indexIsUnique opts = sqliteIndexUnique opts diff --git a/beam-sqlite/test/Database/Beam/Sqlite/Test/Migrate.hs b/beam-sqlite/test/Database/Beam/Sqlite/Test/Migrate.hs index b363126d1..a6348d7a9 100644 --- a/beam-sqlite/test/Database/Beam/Sqlite/Test/Migrate.hs +++ b/beam-sqlite/test/Database/Beam/Sqlite/Test/Migrate.hs @@ -4,6 +4,8 @@ import Database.SQLite.Simple import Test.Tasty import Test.Tasty.HUnit +import qualified Data.List.NonEmpty as NE +import Data.Int (Int32) import Database.Beam import Database.Beam.Sqlite import Database.Beam.Sqlite.Migrate @@ -16,6 +18,8 @@ tests :: TestTree tests = testGroup "Migration tests" [ verifiesPrimaryKey , verifiesNoPrimaryKey + , verifiesIndex + , verifiesUniqueIndex ] newtype WithPkT f = WithPkT @@ -72,3 +76,44 @@ testVerifySchema conn db = VerificationSucceeded -> return () VerificationFailed failures -> fail $ "Verification failed: " ++ show failures + +-- Shared table type for index tests + +newtype IdxT f = IdxT + { _idx_value :: C f Int32 + } deriving (Generic, Beamable) + +instance Table IdxT where + newtype PrimaryKey IdxT f = IdxPk (C f Int32) + deriving (Generic, Beamable) + primaryKey = IdxPk . _idx_value + +data IdxDb entity = IdxDb + { _idx_tbl :: entity (TableEntity IdxT) + } deriving (Generic, Database Sqlite) + +verifiesIndex :: TestTree +verifiesIndex = testCase "verifySchema correctly detects a secondary index" $ + withTestDb $ \conn -> do + execute_ conn "create table idx_tbl (idx_value int not null primary key)" + execute_ conn "create index idx_tbl_value on idx_tbl (idx_value)" + let db :: CheckedDatabaseSettings Sqlite IdxDb + db = defaultMigratableDbSettings `withDbModification` + (dbModification @_ @Sqlite) + { _idx_tbl = + addTableIndex "idx_tbl_value" defaultIndexOptions + (\t -> selectorColumnName _idx_value t NE.:| []) } + testVerifySchema conn db + +verifiesUniqueIndex :: TestTree +verifiesUniqueIndex = testCase "verifySchema correctly detects a UNIQUE secondary index" $ + withTestDb $ \conn -> do + execute_ conn "create table idx_tbl (idx_value int not null primary key)" + execute_ conn "create unique index idx_tbl_value_uniq on idx_tbl (idx_value)" + let db :: CheckedDatabaseSettings Sqlite IdxDb + db = defaultMigratableDbSettings `withDbModification` + (dbModification @_ @Sqlite) + { _idx_tbl = + addTableIndex "idx_tbl_value_uniq" (setUniqueIndexOptions True defaultIndexOptions) + (\t -> selectorColumnName _idx_value t NE.:| []) } + testVerifySchema conn db From 7f45fc30735737c78c1f8ffff401c8ba177ec0f3 Mon Sep 17 00:00:00 2001 From: sheaf Date: Mon, 23 Mar 2026 22:05:00 +0100 Subject: [PATCH 2/2] Make Sql92CreateIndexOptionsSyntax into a type family --- beam-migrate/ChangeLog.md | 2 +- beam-migrate/Database/Beam/Migrate/Checks.hs | 6 +++--- beam-migrate/Database/Beam/Migrate/SQL/SQL92.hs | 3 ++- beam-postgres/Database/Beam/Postgres/Migrate.hs | 11 ++++++----- beam-postgres/Database/Beam/Postgres/Syntax.hs | 9 ++++++--- .../test/Database/Beam/Postgres/Test/Migrate.hs | 10 ++++++---- beam-sqlite/Database/Beam/Sqlite/Migrate.hs | 9 +++++---- beam-sqlite/Database/Beam/Sqlite/Syntax.hs | 10 +++++++--- beam-sqlite/test/Database/Beam/Sqlite/Test/Migrate.hs | 8 ++++++-- 9 files changed, 42 insertions(+), 26 deletions(-) diff --git a/beam-migrate/ChangeLog.md b/beam-migrate/ChangeLog.md index dcee2268c..1f5970160 100644 --- a/beam-migrate/ChangeLog.md +++ b/beam-migrate/ChangeLog.md @@ -5,7 +5,7 @@ * Added support for declaring secondary indices on tables. User API is the `addTableIndex` function, `selectorColumnName` and `foreignKeyColumns` helpers. Backend support goes through new `IsSql92CreateDropIndexSyntax` (which carries - a per-backend `Sql92CreateIndexOptionsSyntax` data family) and + a per-backend `Sql92CreateIndexOptionsSyntax` type family) and `IsSql92UniqueIndexSyntax` (for index uniqueness constraints). ## Updated dependencies diff --git a/beam-migrate/Database/Beam/Migrate/Checks.hs b/beam-migrate/Database/Beam/Migrate/Checks.hs index 03b907c87..defdcd3b8 100644 --- a/beam-migrate/Database/Beam/Migrate/Checks.hs +++ b/beam-migrate/Database/Beam/Migrate/Checks.hs @@ -131,7 +131,7 @@ instance ( Typeable be DatabasePredicate (TableHasIndex be) where englishDescription (TableHasIndex { hasIndex_table = tbl, hasIndex_name = nm , hasIndex_columns = cols, hasIndex_opts = opts }) = - (if indexIsUnique opts then "Unique index " else "Index ") <> + (if indexIsUnique @(BeamSqlBackendSyntax be) opts then "Unique index " else "Index ") <> show nm <> " on table " <> show tbl <> " covering columns " <> show cols predicateSpecificity _ = PredicateSpecificityAllBackends @@ -140,7 +140,7 @@ instance ( Typeable be , hasIndex_columns = cols, hasIndex_opts = opts }) = object [ "has-index" .= object [ "table" .= tbl, "name" .= nm , "columns" .= cols - , "options" .= serializeIndexOptions opts ] ] + , "options" .= serializeIndexOptions @(BeamSqlBackendSyntax be) opts ] ] predicateCascadesDropOn (TableHasIndex { hasIndex_table = tblNm }) p' | Just (TableExistsPredicate tblNm') <- cast p' = tblNm' == tblNm @@ -212,7 +212,7 @@ beamCheckDeserializers = mconcat fmap (id @(TableHasIndex be)) (TableHasIndex <$> v' .: "table" <*> v' .: "name" <*> v' .: "columns" - <*> (deserializeIndexOptions =<< v' .: "options"))) + <*> (deserializeIndexOptions @(BeamSqlBackendSyntax be) =<< v' .: "options"))) deserializeTableHasColumnPredicate :: BeamDeserializers be' -> Value -> Parser SomeDatabasePredicate diff --git a/beam-migrate/Database/Beam/Migrate/SQL/SQL92.hs b/beam-migrate/Database/Beam/Migrate/SQL/SQL92.hs index b70fa86c5..4013eb9ea 100644 --- a/beam-migrate/Database/Beam/Migrate/SQL/SQL92.hs +++ b/beam-migrate/Database/Beam/Migrate/SQL/SQL92.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} @@ -249,7 +250,7 @@ class ( IsSql92DdlCommandSyntax syntax , Eq (Sql92CreateIndexOptionsSyntax syntax) , Hashable (Sql92CreateIndexOptionsSyntax syntax) ) => IsSql92CreateDropIndexSyntax syntax where - data family Sql92CreateIndexOptionsSyntax syntax + type family Sql92CreateIndexOptionsSyntax syntax -- | Render a @CREATE INDEX@ command. createIndexCmd diff --git a/beam-postgres/Database/Beam/Postgres/Migrate.hs b/beam-postgres/Database/Beam/Postgres/Migrate.hs index 51d086716..c97906fa3 100644 --- a/beam-postgres/Database/Beam/Postgres/Migrate.hs +++ b/beam-postgres/Database/Beam/Postgres/Migrate.hs @@ -417,11 +417,12 @@ getDbConstraintsForSchemas subschemas conn = case NE.nonEmpty (V.toList cols) of Nothing -> Nothing Just colsNE -> - Just $ - Db.SomeDatabasePredicate - (Db.TableHasIndex (Db.QualifiedName schema tblNm) idxNm colsNE - (Db.setUniqueIndexOptions isUniq Db.defaultIndexOptions) - :: Db.TableHasIndex Postgres)) <$> + let opts = Db.setUniqueIndexOptions @(BeamSqlBackendSyntax Postgres) isUniq + $ Db.defaultIndexOptions @(BeamSqlBackendSyntax Postgres) + in + Just $ + Db.SomeDatabasePredicate @(Db.TableHasIndex Postgres) + (Db.TableHasIndex (Db.QualifiedName schema tblNm) idxNm colsNE opts)) <$> Pg.query_ conn (fromString (unlines [ -- NULL out 'public' since it is the implicit default schema in Postgres "SELECT NULLIF(ns.nspname, 'public'), c.relname, i.relname, ix.indisunique," diff --git a/beam-postgres/Database/Beam/Postgres/Syntax.hs b/beam-postgres/Database/Beam/Postgres/Syntax.hs index c94fa5ab9..0ad4d5996 100644 --- a/beam-postgres/Database/Beam/Postgres/Syntax.hs +++ b/beam-postgres/Database/Beam/Postgres/Syntax.hs @@ -59,6 +59,8 @@ module Database.Beam.Postgres.Syntax , PgDataTypeDescr(..) , PgHasEnum(..) + , PgIndexOptions(..) + , pgCreateExtensionSyntax, pgDropExtensionSyntax , pgCreateEnumSyntax, pgDropTypeSyntax @@ -429,11 +431,12 @@ instance IsSql92DdlCommandSyntax PgCommandSyntax where dropTableCmd = PgCommandSyntax PgCommandTypeDdl . coerce alterTableCmd = PgCommandSyntax PgCommandTypeDdl . coerce -instance IsSql92CreateDropIndexSyntax PgCommandSyntax where - newtype instance Sql92CreateIndexOptionsSyntax PgCommandSyntax = - PgIndexOptions { pgIndexUnique :: Bool } +newtype PgIndexOptions = PgIndexOptions { pgIndexUnique :: Bool } deriving (Show, Eq, Hashable) +instance IsSql92CreateDropIndexSyntax PgCommandSyntax where + type instance Sql92CreateIndexOptionsSyntax PgCommandSyntax = PgIndexOptions + defaultIndexOptions = PgIndexOptions { pgIndexUnique = False } createIndexCmd idxNm tblNm cols opts = diff --git a/beam-postgres/test/Database/Beam/Postgres/Test/Migrate.hs b/beam-postgres/test/Database/Beam/Postgres/Test/Migrate.hs index 9275f7c20..efc3d5d06 100644 --- a/beam-postgres/test/Database/Beam/Postgres/Test/Migrate.hs +++ b/beam-postgres/test/Database/Beam/Postgres/Test/Migrate.hs @@ -169,7 +169,7 @@ indexVerification pgConn = let db :: CheckedDatabaseSettings Postgres IdxDb db = defaultMigratableDbSettings `withDbModification` (dbModification @_ @Postgres) - { _idx_tbl = addTableIndex "idx_tbl_value" defaultIndexOptions + { _idx_tbl = addTableIndex "idx_tbl_value" (defaultIndexOptions @PgCommandSyntax) (\t -> selectorColumnName _idx_value t NE.:| []) } runBeamPostgres conn (verifySchema migrationBackend db) >>= \case VerificationSucceeded -> return () @@ -182,11 +182,13 @@ uniqueIndexVerification pgConn = withTestPostgres "db_unique_index" pgConn $ \conn -> do Pg.execute_ conn "CREATE TABLE idx_tbl (idx_value integer NOT NULL PRIMARY KEY)" Pg.execute_ conn "CREATE UNIQUE INDEX idx_tbl_value_uniq ON idx_tbl (idx_value)" - let db :: CheckedDatabaseSettings Postgres IdxDb + let idxOpts = setUniqueIndexOptions @PgCommandSyntax True + $ defaultIndexOptions @PgCommandSyntax + db :: CheckedDatabaseSettings Postgres IdxDb db = defaultMigratableDbSettings `withDbModification` (dbModification @_ @Postgres) - { _idx_tbl = addTableIndex "idx_tbl_value_uniq" (setUniqueIndexOptions True defaultIndexOptions) + { _idx_tbl = addTableIndex "idx_tbl_value_uniq" idxOpts (\t -> selectorColumnName _idx_value t NE.:| []) } runBeamPostgres conn (verifySchema migrationBackend db) >>= \case VerificationSucceeded -> return () - VerificationFailed failures -> fail ("Verification failed: " ++ show failures) \ No newline at end of file + VerificationFailed failures -> fail ("Verification failed: " ++ show failures) diff --git a/beam-sqlite/Database/Beam/Sqlite/Migrate.hs b/beam-sqlite/Database/Beam/Sqlite/Migrate.hs index 30149d8f6..dc560230b 100644 --- a/beam-sqlite/Database/Beam/Sqlite/Migrate.hs +++ b/beam-sqlite/Database/Beam/Sqlite/Migrate.hs @@ -342,10 +342,11 @@ getDbConstraints extraParser = case NE.nonEmpty cols of Nothing -> [] Just colsNE -> - [ Db.SomeDatabasePredicate - (Db.TableHasIndex tblName idxNm colsNE - (Db.setUniqueIndexOptions (isUniq /= (0 :: Int)) Db.defaultIndexOptions) - :: Db.TableHasIndex Sqlite) ] + let opts = Db.setUniqueIndexOptions @SqliteCommandSyntax (isUniq /= (0 :: Int)) + $ Db.defaultIndexOptions @SqliteCommandSyntax + in + [ Db.SomeDatabasePredicate + (Db.TableHasIndex @Sqlite tblName idxNm colsNE opts) ] pure ( [ Db.SomeDatabasePredicate (Db.TableExistsPredicate tblName) ] ++ pkPred ++ columnPreds ++ idxPreds ) diff --git a/beam-sqlite/Database/Beam/Sqlite/Syntax.hs b/beam-sqlite/Database/Beam/Sqlite/Syntax.hs index 99cbb1c5b..e07a33138 100644 --- a/beam-sqlite/Database/Beam/Sqlite/Syntax.hs +++ b/beam-sqlite/Database/Beam/Sqlite/Syntax.hs @@ -26,6 +26,7 @@ module Database.Beam.Sqlite.Syntax , SqliteTableNameSyntax(..) , SqliteFieldNameSyntax(..) , SqliteAggregationSetQuantifierSyntax(..) + , SqliteIndexOptions(..) , fromSqliteExpression @@ -983,11 +984,14 @@ instance HasSqlValueSyntax SqliteValueSyntax Day where instance HasDataTypeCreatedCheck SqliteDataTypeSyntax where dataTypeHasBeenCreated _ _ = True -instance IsSql92CreateDropIndexSyntax SqliteCommandSyntax where - newtype instance Sql92CreateIndexOptionsSyntax SqliteCommandSyntax = - SqliteIndexOptions { sqliteIndexUnique :: Bool } +newtype SqliteIndexOptions = + SqliteIndexOptions { sqliteIndexUnique :: Bool } deriving (Show, Eq, Hashable) +instance IsSql92CreateDropIndexSyntax SqliteCommandSyntax where + type instance Sql92CreateIndexOptionsSyntax SqliteCommandSyntax = + SqliteIndexOptions + defaultIndexOptions = SqliteIndexOptions { sqliteIndexUnique = False } createIndexCmd idxNm tblNm cols opts = diff --git a/beam-sqlite/test/Database/Beam/Sqlite/Test/Migrate.hs b/beam-sqlite/test/Database/Beam/Sqlite/Test/Migrate.hs index a6348d7a9..8035710ca 100644 --- a/beam-sqlite/test/Database/Beam/Sqlite/Test/Migrate.hs +++ b/beam-sqlite/test/Database/Beam/Sqlite/Test/Migrate.hs @@ -13,6 +13,7 @@ import Database.Beam.Migrate import Database.Beam.Migrate.Simple import Database.Beam.Sqlite.Test +import Database.Beam.Sqlite.Syntax (SqliteIndexOptions) tests :: TestTree tests = testGroup "Migration tests" @@ -101,7 +102,7 @@ verifiesIndex = testCase "verifySchema correctly detects a secondary index" $ db = defaultMigratableDbSettings `withDbModification` (dbModification @_ @Sqlite) { _idx_tbl = - addTableIndex "idx_tbl_value" defaultIndexOptions + addTableIndex "idx_tbl_value" (defaultIndexOptions @SqliteCommandSyntax) (\t -> selectorColumnName _idx_value t NE.:| []) } testVerifySchema conn db @@ -114,6 +115,9 @@ verifiesUniqueIndex = testCase "verifySchema correctly detects a UNIQUE secondar db = defaultMigratableDbSettings `withDbModification` (dbModification @_ @Sqlite) { _idx_tbl = - addTableIndex "idx_tbl_value_uniq" (setUniqueIndexOptions True defaultIndexOptions) + let idxOpts = setUniqueIndexOptions @SqliteCommandSyntax True + $ defaultIndexOptions @SqliteCommandSyntax + in + addTableIndex "idx_tbl_value_uniq" idxOpts (\t -> selectorColumnName _idx_value t NE.:| []) } testVerifySchema conn db