hpqtypes-extras 1.17.0.1 → 1.18.0.0
raw patch · 6 files changed
+41/−23 lines, 6 files
Files
- CHANGELOG.md +5/−0
- hpqtypes-extras.cabal +3/−2
- src/Database/PostgreSQL/PQTypes/Checks.hs +26/−13
- src/Database/PostgreSQL/PQTypes/ExtrasOptions.hs +6/−2
- src/Database/PostgreSQL/PQTypes/Model/Index.hs +0/−5
- test/Main.hs +1/−1
CHANGELOG.md view
@@ -1,3 +1,8 @@+# hpqtypes-extras-1.18.0.0 (2025-06-02)+* Don't consider invalid indexes when checking consistency of the database.+* Improve handling of lock failures during migrations.+* Rename `eoLockTimeoutMs` to `eoLockTimeoutSecs` to normalize units.+ # hpqtypes-extras-1.17.0.1 (2025-03-27) * Fix validation of NOT NULL domains with PostgreSQL >= 17.
hpqtypes-extras.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: hpqtypes-extras-version: 1.17.0.1+version: 1.18.0.0 synopsis: Extra utilities for hpqtypes library description: The following extras for hpqtypes library: .@@ -20,7 +20,7 @@ copyright: Scrive AB category: Database build-type: Simple-tested-with: GHC == { 8.10.7, 9.0.2, 9.2.8, 9.4.8, 9.6.6, 9.8.4, 9.10.1, 9.12.1 }+tested-with: GHC == { 8.10.7, 9.0.2, 9.2.8, 9.4.8, 9.6.6, 9.8.4, 9.10.2, 9.12.2 } Source-repository head Type: git@@ -36,6 +36,7 @@ , ImportQualifiedPost , LambdaCase , MultiWayIf+ , NumericUnderscores , OverloadedStrings , RankNTypes , RecordWildCards
src/Database/PostgreSQL/PQTypes/Checks.hs view
@@ -1224,20 +1224,31 @@ validateMigrationsToRun migrationsToRun dbTablesWithVersions unless (null migrationsToRun) $ do logInfo_ "Running migrations..."- forM_ migrationsToRun $ \mgr -> fix $ \loop -> do- let restartMigration query = do- logAttention "Failed to acquire a lock" $ object ["query" .= query]- logInfo_ "Restarting the migration shortly..."- liftIO $ threadDelay 1000000- loop+ forM_ migrationsToRun $ \mgr -> (`fix` 1) $ \loop attempts -> do+ let restartMigration query =+ if attempts < maxAttempts+ then do+ logInfo "Failed to acquire a lock, backing off..." $+ object+ [ "query" .= query+ , "attempts" .= attempts+ , "backoff_seconds" .= backoffSecs+ ]+ liftIO . threadDelay $ backoffSecs * 1_000_000+ loop $ attempts + 1+ else do+ logAttention_ "Failed to lock the table, aborting."+ error "Lock acquisition failure" handleJust lockNotAvailable restartMigration $ do- forM_ (eoLockTimeoutMs options) $ \lockTimeout -> do- runSQL_ $ "SET LOCAL lock_timeout TO" <+> intToSQL lockTimeout+ runSQL_ $ "SET LOCAL lock_timeout TO" <+> intToSQL (eoLockTimeoutSecs options * 1_000) runMigration mgr `onException` rollback logInfo_ "Committing migration changes..." commit- logInfo_ "Running migrations... done."+ logInfo_ "Running migrations done." where+ backoffSecs = eoLockFailureBackoffSecs options+ maxAttempts = eoLockAttempts options+ intToSQL :: Int -> SQL intToSQL = unsafeSQL . show @@ -1491,7 +1502,6 @@ sqlResult $ "ARRAY(" <> selectCoordinates "i.indnkeyatts" "i.indnatts" <> ")" -- array of included columns in the index sqlResult "am.amname::text" -- the method used (btree, gin etc) sqlResult "i.indisunique" -- is it unique?- sqlResult "i.indisvalid" -- is it valid? -- does it have NULLS NOT DISTINCT ? if nullsNotDistinctSupported then sqlResult "i.indnullsnotdistinct"@@ -1503,6 +1513,10 @@ sqlLeftJoinOn "pg_catalog.pg_constraint r" "r.conrelid = i.indrelid AND r.conindid = i.indexrelid"+ -- Indexes currently being built by CREATE INDEX CONCURRENTLY (or ones that+ -- weren't successfully built by it) are marked as invalid, so we don't want+ -- to consider them at a time.+ sqlWhere "i.indisvalid" sqlWhereEqSql "i.indrelid" $ sqlGetTableID table sqlWhereIsNULL "r.contype" -- fetch only "pure" indexes where@@ -1520,15 +1534,14 @@ ] fetchTableIndex- :: (String, Array1 String, Array1 String, String, Bool, Bool, Bool, Maybe String)+ :: (String, Array1 String, Array1 String, String, Bool, Bool, Maybe String) -> (TableIndex, RawSQL ())-fetchTableIndex (name, Array1 keyColumns, Array1 includeColumns, method, unique, valid, nullsNotDistinct, mconstraint) =+fetchTableIndex (name, Array1 keyColumns, Array1 includeColumns, method, unique, nullsNotDistinct, mconstraint) = ( TableIndex { idxColumns = map (indexColumn . unsafeSQL) keyColumns , idxInclude = map unsafeSQL includeColumns , idxMethod = read method , idxUnique = unique- , idxValid = valid , idxWhere = unsafeSQL <$> mconstraint , idxNotDistinctNulls = nullsNotDistinct }
src/Database/PostgreSQL/PQTypes/ExtrasOptions.hs view
@@ -6,7 +6,9 @@ data ExtrasOptions = ExtrasOptions- { eoLockTimeoutMs :: !(Maybe Int)+ { eoLockTimeoutSecs :: !Int+ , eoLockFailureBackoffSecs :: !Int+ , eoLockAttempts :: !Int , eoEnforcePKs :: !Bool -- ^ Validate that every handled table has a primary key , eoObjectsValidationMode :: !ObjectsValidationMode@@ -24,7 +26,9 @@ defaultExtrasOptions :: ExtrasOptions defaultExtrasOptions = ExtrasOptions- { eoLockTimeoutMs = Nothing+ { eoLockTimeoutSecs = 3+ , eoLockFailureBackoffSecs = 30+ , eoLockAttempts = 5 , eoEnforcePKs = False , eoObjectsValidationMode = DontAllowUnknownObjects , eoAllowHigherTableVersions = False
src/Database/PostgreSQL/PQTypes/Model/Index.hs view
@@ -37,7 +37,6 @@ , idxInclude :: [RawSQL ()] , idxMethod :: IndexMethod , idxUnique :: Bool- , idxValid :: Bool , -- \^ If creation of index with CONCURRENTLY fails, index -- will be marked as invalid. Set it to 'False' if such -- situation is expected.@@ -97,7 +96,6 @@ , idxInclude = [] , idxMethod = BTree , idxUnique = False- , idxValid = True , idxWhere = Nothing , idxNotDistinctNulls = False }@@ -134,7 +132,6 @@ , idxInclude = [] , idxMethod = BTree , idxUnique = True- , idxValid = True , idxWhere = Nothing , idxNotDistinctNulls = False }@@ -146,7 +143,6 @@ , idxInclude = [] , idxMethod = BTree , idxUnique = True- , idxValid = True , idxWhere = Nothing , idxNotDistinctNulls = False }@@ -158,7 +154,6 @@ , idxInclude = [] , idxMethod = BTree , idxUnique = True- , idxValid = True , idxWhere = Just whereC , idxNotDistinctNulls = False }
test/Main.hs view
@@ -890,7 +890,7 @@ let definitions = tableDefsWithPgCrypto schema2Tables step "Migrating the database (schema version 1 -> schema version 2)..." migrateDatabase- defaultExtrasOptions {eoLockTimeoutMs = Just 1000}+ defaultExtrasOptions definitions schema2Migrations checkDatabase defaultExtrasOptions definitions