beam-migrate: CREATE INDEX support

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` type family) and
+  `IsSql92UniqueIndexSyntax` (for index uniqueness constraints).
+
 ## Updated dependencies
 
 * Updated the upper bound on `parallel` to include `parallel-3.3.0.0`

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:

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
 

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 @(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 @@ 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 @(BeamSqlBackendSyntax be) =<< v' .: "options")))
+
     deserializeTableHasColumnPredicate :: BeamDeserializers be'
                                        -> Value -> Parser SomeDatabasePredicate
     deserializeTableHasColumnPredicate d =

beam-migrate/Database/Beam/Migrate/SQL/SQL92.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE CPP #-}
 
@@ -11,13 +12,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 +240,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
+  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).
+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

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)

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