diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,10 +1,4 @@ -# hpqtypes-extras-1.12.0.1aou -aoeu -ao -eua -oe -uao -eu (2021-10-11) +# hpqtypes-extras-1.12.0.1 (2021-10-11) * Add support for log-base-0.11.0.0 # hpqtypes-extras-1.12.0.0 (2021-10-??) diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,7 +1,2 @@ -aoeu -aoe -uao -eua -oeu -aoeuimport Distribution.Simple +import Distribution.Simple main = defaultMain diff --git a/hpqtypes-extras.cabal b/hpqtypes-extras.cabal --- a/hpqtypes-extras.cabal +++ b/hpqtypes-extras.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: hpqtypes-extras -version: 1.12.0.1 +version: 1.13.0.0 synopsis: Extra utilities for hpqtypes library description: The following extras for hpqtypes library: . @@ -74,7 +74,7 @@ build-depends: base >= 4.9 && < 5 , hpqtypes >= 1.8.0.0 && < 2.0.0.0 - , base16-bytestring >= 0.1 && < 1.0.2.0 + , base16-bytestring >= 0.1 && < 1.1 , bytestring >= 0.10 && < 0.12 , containers >= 0.5 && < 0.7 , cryptohash >= 0.11 && < 0.12 @@ -87,7 +87,8 @@ , monad-control >= 1.0.3.1 && < 1.1 , semigroups >= 0.16 && < 0.20 , text-show >= 3.7 && < 4 - , log-base >= 0.7 && < 0.12 + , transformers-base + , log-base >= 0.11 && < 0.12 , safe >= 0.3 && < 0.4 default-language: Haskell2010 diff --git a/src/Database/PostgreSQL/PQTypes/Checks.hs b/src/Database/PostgreSQL/PQTypes/Checks.hs --- a/src/Database/PostgreSQL/PQTypes/Checks.hs +++ b/src/Database/PostgreSQL/PQTypes/Checks.hs @@ -14,6 +14,8 @@ ) where import Control.Arrow ((&&&)) +import Control.Concurrent.Lifted (threadDelay) +import Control.Monad.Base import Control.Monad.Catch import Control.Monad.Reader import Data.Int @@ -22,6 +24,7 @@ import Data.Monoid import Data.Monoid.Utils import Data.Ord (comparing) +import Data.Typeable (cast) import qualified Data.String import Data.Text (Text) import Database.PostgreSQL.PQTypes @@ -49,7 +52,7 @@ -- | Run migrations and check the database structure. migrateDatabase - :: (MonadDB m, MonadLog m, MonadMask m) + :: (MonadBase IO m, MonadDB m, MonadLog m, MonadMask m) => ExtrasOptions -> [Extension] -> [CompositeType] @@ -539,7 +542,7 @@ -- * all 'mgrFrom' are less than table version number of the table in -- the 'tables' list checkDBConsistency - :: forall m. (MonadDB m, MonadLog m, MonadMask m) + :: forall m. (MonadBase IO m, MonadDB m, MonadLog m, MonadMask m) => ExtrasOptions -> [Domain] -> TablesWithVersions -> [Migration m] -> m () checkDBConsistency options domains tablesWithVersions migrations = do @@ -819,12 +822,28 @@ validateMigrationsToRun migrationsToRun dbTablesWithVersions when (not . null $ migrationsToRun) $ do logInfo_ "Running migrations..." - forM_ migrationsToRun $ \mgr -> do - runMigration mgr - when (eoCommitAfterEachMigration options) $ do + forM_ migrationsToRun $ \mgr -> fix $ \loop -> do + let restartMigration query = do + logAttention "Failed to acquire a lock" $ object ["query" .= query] + logInfo_ "Restarting the migration shortly..." + threadDelay 1000000 + loop + handleJust lockNotAvailable restartMigration $ do + forM_ (eoLockTimeoutMs options) $ \lockTimeout -> do + runSQL_ $ "SET LOCAL lock_timeout TO" <+> intToSQL lockTimeout + runMigration mgr `onException` rollback logInfo_ $ "Committing migration changes..." commit logInfo_ "Running migrations... done." + where + intToSQL :: Int -> SQL + intToSQL = unsafeSQL . show + + lockNotAvailable :: DBException -> Maybe String + lockNotAvailable DBException{..} + | Just DetailedQueryError{..} <- cast dbeError + , qeErrorCode == LockNotAvailable = Just $ show dbeQueryContext + | otherwise = Nothing validateMigrationsToRun :: [Migration m] -> [(Text, Int32)] -> m () validateMigrationsToRun migrationsToRun dbTablesWithVersions = do diff --git a/src/Database/PostgreSQL/PQTypes/ExtrasOptions.hs b/src/Database/PostgreSQL/PQTypes/ExtrasOptions.hs --- a/src/Database/PostgreSQL/PQTypes/ExtrasOptions.hs +++ b/src/Database/PostgreSQL/PQTypes/ExtrasOptions.hs @@ -6,9 +6,8 @@ data ExtrasOptions = ExtrasOptions - { eoCommitAfterEachMigration :: Bool - -- ^ Run commit after every migration. - , eoEnforcePKs :: Bool + { eoLockTimeoutMs :: !(Maybe Int) + , eoEnforcePKs :: !Bool -- ^ Validate that every handled table has a primary key , eoObjectsValidationMode :: !ObjectsValidationMode -- ^ Validation mode for unknown tables and composite types. @@ -19,7 +18,7 @@ defaultExtrasOptions :: ExtrasOptions defaultExtrasOptions = ExtrasOptions - { eoCommitAfterEachMigration = False + { eoLockTimeoutMs = Nothing , eoEnforcePKs = False , eoObjectsValidationMode = DontAllowUnknownObjects , eoAllowHigherTableVersions = False diff --git a/src/Database/PostgreSQL/PQTypes/Migrate.hs b/src/Database/PostgreSQL/PQTypes/Migrate.hs --- a/src/Database/PostgreSQL/PQTypes/Migrate.hs +++ b/src/Database/PostgreSQL/PQTypes/Migrate.hs @@ -17,7 +17,7 @@ -- create the domain runQuery_ $ sqlCreateDomain dom -- add constraint checks to the domain - F.forM_ domChecks $ runQuery_ . sqlAlterDomain domName . sqlAddValidCheck + F.forM_ domChecks $ runQuery_ . sqlAlterDomain domName . sqlAddValidCheckMaybeDowntime createTable :: MonadDB m => Bool -> Table -> m () createTable withConstraints table@Table{..} = do @@ -25,7 +25,7 @@ runQuery_ $ sqlCreateTable tblName runQuery_ $ sqlAlterTable tblName $ map sqlAddColumn tblColumns -- Add indexes. - forM_ tblIndexes $ runQuery_ . sqlCreateIndexSequentially tblName + forM_ tblIndexes $ runQuery_ . sqlCreateIndexMaybeDowntime tblName -- Add all the other constraints if applicable. when withConstraints $ createTableConstraints table -- Register the table along with its version. @@ -39,6 +39,6 @@ where addConstraints = concat [ [sqlAddPK tblName pk | Just pk <- return tblPrimaryKey] - , map sqlAddValidCheck tblChecks - , map (sqlAddValidFK tblName) tblForeignKeys + , map sqlAddValidCheckMaybeDowntime tblChecks + , map (sqlAddValidFKMaybeDowntime tblName) tblForeignKeys ] diff --git a/src/Database/PostgreSQL/PQTypes/Model/Check.hs b/src/Database/PostgreSQL/PQTypes/Model/Check.hs --- a/src/Database/PostgreSQL/PQTypes/Model/Check.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/Check.hs @@ -1,8 +1,7 @@ module Database.PostgreSQL.PQTypes.Model.Check ( Check(..) , tblCheck - , sqlAddCheck - , sqlAddValidCheck + , sqlAddValidCheckMaybeDowntime , sqlAddNotValidCheck , sqlValidateCheck , sqlDropCheck @@ -26,17 +25,12 @@ , chkValidated = True } -{-# DEPRECATED sqlAddCheck "Use sqlAddValidCheck instead" #-} --- | Deprecated version of 'sqlAddValidCheck'. -sqlAddCheck :: Check -> RawSQL () -sqlAddCheck = sqlAddCheck_ True - -- | Add valid check constraint. Warning: PostgreSQL acquires SHARE ROW -- EXCLUSIVE lock (that prevents updates) on modified table for the duration of -- the creation. If this is not acceptable, use 'sqlAddNotValidCheck' and -- 'sqlValidateCheck'. -sqlAddValidCheck :: Check -> RawSQL () -sqlAddValidCheck = sqlAddCheck_ True +sqlAddValidCheckMaybeDowntime :: Check -> RawSQL () +sqlAddValidCheckMaybeDowntime = sqlAddCheck_ True -- | Add check marked as NOT VALID. This avoids potentially long validation -- blocking updates to modified table for its duration. However, checks created @@ -45,8 +39,8 @@ sqlAddNotValidCheck = sqlAddCheck_ False -- | Validate check previously created as NOT VALID. -sqlValidateCheck :: Check -> RawSQL () -sqlValidateCheck Check{..} = "VALIDATE CONSTRAINT" <+> chkName +sqlValidateCheck :: RawSQL () -> RawSQL () +sqlValidateCheck checkName = "VALIDATE CONSTRAINT" <+> checkName sqlAddCheck_ :: Bool -> Check -> RawSQL () sqlAddCheck_ valid Check{..} = smconcat [ diff --git a/src/Database/PostgreSQL/PQTypes/Model/ForeignKey.hs b/src/Database/PostgreSQL/PQTypes/Model/ForeignKey.hs --- a/src/Database/PostgreSQL/PQTypes/Model/ForeignKey.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/ForeignKey.hs @@ -4,8 +4,7 @@ , fkOnColumn , fkOnColumns , fkName - , sqlAddFK - , sqlAddValidFK + , sqlAddValidFKMaybeDowntime , sqlAddNotValidFK , sqlValidateFK , sqlDropFK @@ -66,17 +65,12 @@ -- PostgreSQL's limit for identifier is 63 characters shorten = flip rawSQL () . T.take 63 . unRawSQL -{-# DEPRECATED sqlAddFK "Use sqlAddValidFK instead" #-} --- | Deprecated version of sqlAddValidFK. -sqlAddFK :: RawSQL () -> ForeignKey -> RawSQL () -sqlAddFK = sqlAddFK_ True - -- | Add valid foreign key. Warning: PostgreSQL acquires SHARE ROW EXCLUSIVE -- lock (that prevents data updates) on both modified and referenced table for -- the duration of the creation. If this is not acceptable, use -- 'sqlAddNotValidFK' and 'sqlValidateFK'. -sqlAddValidFK :: RawSQL () -> ForeignKey -> RawSQL () -sqlAddValidFK = sqlAddFK_ True +sqlAddValidFKMaybeDowntime :: RawSQL () -> ForeignKey -> RawSQL () +sqlAddValidFKMaybeDowntime = sqlAddFK_ True -- | Add foreign key marked as NOT VALID. This avoids potentially long -- validation blocking updates to both modified and referenced table for its diff --git a/src/Database/PostgreSQL/PQTypes/Model/Index.hs b/src/Database/PostgreSQL/PQTypes/Model/Index.hs --- a/src/Database/PostgreSQL/PQTypes/Model/Index.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/Index.hs @@ -10,10 +10,9 @@ , uniqueIndexOnColumnWithCondition , uniqueIndexOnColumns , indexName - , sqlCreateIndex - , sqlCreateIndexSequentially + , sqlCreateIndexMaybeDowntime , sqlCreateIndexConcurrently - , sqlDropIndex + , sqlDropIndexMaybeDowntime , sqlDropIndexConcurrently ) where @@ -132,18 +131,13 @@ -- with the same columns, but different constraints can coexist hashWhere = asText $ T.decodeUtf8 . encode . BS.take 10 . hash . T.encodeUtf8 -{-# DEPRECATED sqlCreateIndex "Use sqlCreateIndexSequentially instead" #-} --- | Deprecated version of 'sqlCreateIndexSequentially'. -sqlCreateIndex :: RawSQL () -> TableIndex -> RawSQL () -sqlCreateIndex = sqlCreateIndex_ False - --- | Create index sequentially. Warning: if the affected table is large, this --- will prevent the table from being modified during the creation. If this is --- not acceptable, use sqlCreateIndexConcurrently. See +-- | Create an index. Warning: if the affected table is large, this will prevent +-- the table from being modified during the creation. If this is not acceptable, +-- use 'CreateIndexConcurrentlyMigration'. See -- https://www.postgresql.org/docs/current/sql-createindex.html for more -- information. -sqlCreateIndexSequentially :: RawSQL () -> TableIndex -> RawSQL () -sqlCreateIndexSequentially = sqlCreateIndex_ False +sqlCreateIndexMaybeDowntime :: RawSQL () -> TableIndex -> RawSQL () +sqlCreateIndexMaybeDowntime = sqlCreateIndex_ False -- | Create index concurrently. sqlCreateIndexConcurrently :: RawSQL () -> TableIndex -> RawSQL () @@ -163,8 +157,12 @@ , maybe "" (" WHERE" <+>) idxWhere ] -sqlDropIndex :: RawSQL () -> TableIndex -> RawSQL () -sqlDropIndex tname idx = "DROP INDEX" <+> indexName tname idx +-- | Drop an index. Warning: if you don't want to lock out concurrent operations +-- on the index's table, use 'DropIndexConcurrentlyMigration'. See +-- https://www.postgresql.org/docs/current/sql-dropindex.html for more +-- information. +sqlDropIndexMaybeDowntime :: RawSQL () -> TableIndex -> RawSQL () +sqlDropIndexMaybeDowntime tname idx = "DROP INDEX" <+> indexName tname idx sqlDropIndexConcurrently :: RawSQL () -> TableIndex -> RawSQL () sqlDropIndexConcurrently tname idx = "DROP INDEX CONCURRENTLY" <+> indexName tname idx diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -589,7 +589,7 @@ composites = [] domains = [] step "Migrating the database (schema version 1 -> schema version 2)..." - migrateDatabase defaultExtrasOptions extensions composites domains + migrateDatabase defaultExtrasOptions { eoLockTimeoutMs = Just 1000 } extensions composites domains schema2Tables schema2Migrations checkDatabase defaultExtrasOptions composites domains schema2Tables