diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,18 @@ +# 0.5.4.0 + +## 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` type family) and + `IsSql92UniqueIndexSyntax` (for index uniqueness constraints). + +## Updated dependencies + +* Updated the upper bound on `parallel` to include `parallel-3.3.0.0` +* Updated the upper bound on `time` to include `time-1.14` + # 0.5.3.2 ## Dependencies diff --git a/Database/Beam/Migrate/Actions.hs b/Database/Beam/Migrate/Actions.hs --- a/Database/Beam/Migrate/Actions.hs +++ b/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 @@ , addColumnProvider , addColumnNullProvider , dropColumnNullProvider + , createIndexActionProvider + , dropIndexActionProvider , defaultActionProvider , defaultSchemaActionProvider @@ -112,7 +115,6 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Typeable -import Data.Semigroup import GHC.Generics @@ -273,6 +275,10 @@ 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 () @@ -516,6 +522,60 @@ pure (PotentialAction (HS.fromList [SomeDatabasePredicate colP]) mempty (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. -- diff --git a/Database/Beam/Migrate/Backend.hs b/Database/Beam/Migrate/Backend.hs --- a/Database/Beam/Migrate/Backend.hs +++ b/Database/Beam/Migrate/Backend.hs @@ -54,9 +54,6 @@ 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/Database/Beam/Migrate/Checks.hs b/Database/Beam/Migrate/Checks.hs --- a/Database/Beam/Migrate/Checks.hs +++ b/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 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 @@ | 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 @(BeamSqlBackendSyntax be) 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 @(BeamSqlBackendSyntax be) 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 @@ 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 ] @@ -165,6 +202,17 @@ v .: "has-primary-key" >>= (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 @(BeamSqlBackendSyntax be) =<< v' .: "options"))) deserializeTableHasColumnPredicate :: BeamDeserializers be' -> Value -> Parser SomeDatabasePredicate diff --git a/Database/Beam/Migrate/SQL/SQL92.hs b/Database/Beam/Migrate/SQL/SQL92.hs --- a/Database/Beam/Migrate/SQL/SQL92.hs +++ b/Database/Beam/Migrate/SQL/SQL92.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} @@ -11,13 +12,12 @@ 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 @@ -99,17 +99,17 @@ dropTableCmd :: Sql92DdlCommandDropTableSyntax syntax -> syntax alterTableCmd :: Sql92DdlCommandAlterTableSyntax syntax -> syntax -class IsSql92SchemaNameSyntax (Sql92CreateSchemaSchemaNameSyntax syntax) => +class IsSql92SchemaNameSyntax (Sql92CreateSchemaSchemaNameSyntax syntax) => IsSql92CreateSchemaSyntax syntax where - + type Sql92CreateSchemaSchemaNameSyntax syntax :: Type createSchemaSyntax :: Sql92CreateSchemaSchemaNameSyntax syntax -> syntax -class IsSql92SchemaNameSyntax (Sql92DropSchemaSchemaNameSyntax syntax) => +class IsSql92SchemaNameSyntax (Sql92DropSchemaSchemaNameSyntax syntax) => IsSql92DropSchemaSyntax syntax where - + type Sql92DropSchemaSchemaNameSyntax syntax :: Type dropSchemaSyntax :: Sql92DropSchemaSchemaNameSyntax syntax @@ -240,3 +240,58 @@ -- | '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. +-- +-- @since 0.5.4.0 +class ( IsSql92DdlCommandSyntax syntax + , Show (Sql92CreateIndexOptionsSyntax syntax) + , Eq (Sql92CreateIndexOptionsSyntax syntax) + , Hashable (Sql92CreateIndexOptionsSyntax syntax) + ) => IsSql92CreateDropIndexSyntax syntax where + type 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). +-- +-- @since 0.5.4.0 +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/Database/Beam/Migrate/SQL/Types.hs b/Database/Beam/Migrate/SQL/Types.hs --- a/Database/Beam/Migrate/SQL/Types.hs +++ b/Database/Beam/Migrate/SQL/Types.hs @@ -18,6 +18,7 @@ , BeamSqlBackendMatchTypeSyntax , BeamSqlBackendReferentialActionSyntax , BeamSqlBackendConstraintAttributesSyntax + , BeamSqlBackendIndexSyntax ) where import Database.Beam.Migrate.Types.Predicates @@ -91,3 +92,5 @@ = Sql92DdlCommandReferentialActionSyntax (BeamSqlBackendSyntax be) type BeamSqlBackendConstraintAttributesSyntax be = Sql92DdlCommandConstraintAttributesSyntax (BeamSqlBackendSyntax be) +type BeamSqlBackendIndexSyntax be + = Sql92CreateIndexOptionsSyntax (BeamSqlBackendSyntax be) diff --git a/Database/Beam/Migrate/Serialization.hs b/Database/Beam/Migrate/Serialization.hs --- a/Database/Beam/Migrate/Serialization.hs +++ b/Database/Beam/Migrate/Serialization.hs @@ -218,6 +218,8 @@ , "be-data" .= v ] -- | Corresponding deserializer for 'beamSerializeJSON' +-- +-- @since 0.5.3.2 beamDeserializeJSON :: Text -> (Value -> Parser a) -> Value -> Parser a beamDeserializeJSON backend go = withObject "backend-specific item" $ \v -> do diff --git a/Database/Beam/Migrate/Types.hs b/Database/Beam/Migrate/Types.hs --- a/Database/Beam/Migrate/Types.hs +++ b/Database/Beam/Migrate/Types.hs @@ -24,7 +24,12 @@ , modifyCheckedTable , checkedTableModification + , addTableIndex + , selectorColumnName + , foreignKeyColumns + , IsSql92CreateDropIndexSyntax(..) + -- * Predicates , DatabasePredicate(..) , SomeDatabasePredicate(..) @@ -50,6 +55,7 @@ , 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/Database/Beam/Migrate/Types/CheckedEntities.hs b/Database/Beam/Migrate/Types/CheckedEntities.hs --- a/Database/Beam/Migrate/Types/CheckedEntities.hs +++ b/Database/Beam/Migrate/Types/CheckedEntities.hs @@ -8,6 +8,8 @@ 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.Identity import Data.Kind (Constraint, Type) +import qualified Data.List.NonEmpty as NE (NonEmpty, nonEmpty) import Data.Maybe import Data.Monoid import Data.Proxy @@ -218,6 +221,82 @@ (dt { dbTableCurrentName = renamer (dbTableCurrentName dt) , 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 -- diff --git a/beam-migrate.cabal b/beam-migrate.cabal --- a/beam-migrate.cabal +++ b/beam-migrate.cabal @@ -1,5 +1,5 @@ name: beam-migrate -version: 0.5.3.2 +version: 0.5.4.0 synopsis: SQL DDL support and migrations support library for Beam description: This package provides type classes to allow backends to implement SQL DDL support for beam. This allows you to use beam syntax to @@ -59,21 +59,21 @@ aeson >=0.11 && <2.3, bytestring >=0.10 && <0.13, free >=4.12 && <5.3, - time >=1.6 && <1.13, + time >=1.6 && <1.15, mtl >=2.2 && <2.4, scientific >=0.3 && <0.4, vector >=0.11 && <0.14, containers >=0.5 && <0.9, unordered-containers >=0.2 && <0.3, hashable >=1.2 && <1.6, - microlens >=0.4 && <0.5, - parallel >=3.2 && <3.3, + microlens >=0.4 && <0.6, + parallel >=3.2 && <3.4, deepseq >=1.4 && <1.7, haskell-src-exts >=1.18 && <1.24, pretty >=1.1 && <1.2, dependent-map >=0.2 && <0.5, dependent-sum >=0.4 && <0.8, - pqueue >=1.3 && <1.6, + pqueue >=1.3 && <1.7, uuid-types >=1.0 && <1.1 default-language: Haskell2010 default-extensions: KindSignatures, OverloadedStrings, TypeFamilies, FlexibleContexts,