beam-migrate 0.5.3.2 → 0.5.4.0

raw patch · 10 files changed

+282/−17 lines, 10 filesdep ~pqueuePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: pqueue

API changes (from Hackage documentation)

Files

• ChangeLog.md +15/−0
• Database/Beam/Migrate/Actions.hs +61/−1
• Database/Beam/Migrate/Backend.hs +0/−3
• Database/Beam/Migrate/Checks.hs +49/−1
• Database/Beam/Migrate/SQL/SQL92.hs +62/−7
• Database/Beam/Migrate/SQL/Types.hs +3/−0
• Database/Beam/Migrate/Serialization.hs +2/−0
• Database/Beam/Migrate/Types.hs +6/−0
• Database/Beam/Migrate/Types/CheckedEntities.hs +79/−0
• beam-migrate.cabal +5/−5

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

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

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

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

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

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

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

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

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

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