diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,12 @@ +# hpqtypes-extras-1.21.0.0 (2026-09-18) +* `migrateDatabase` and `checkDatabase` now require PostgreSQL 15 or later. On an + older server they stop with an error. +* Remove `checkAndRememberMaterializationSupport`. All supported servers + understand the `MATERIALIZED` keyword, so delete the call from your code. +* `sqlWith` now emits a plain `WITH` clause and lets PostgreSQL decide whether + to materialize it. It used to emit `WITH ... AS NOT MATERIALIZED`. To keep the + old behavior, use the new `sqlWithNotMaterialized`. + # hpqtypes-extras-1.20.0.0 (2026-06-10) * Drop `crypton` dependency in favor of `ppad-ripemd160`. * Add support for customizing trigger functions. diff --git a/hpqtypes-extras.cabal b/hpqtypes-extras.cabal --- a/hpqtypes-extras.cabal +++ b/hpqtypes-extras.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: hpqtypes-extras -version: 1.20.0.0 +version: 1.21.0.0 synopsis: Extra utilities for hpqtypes library description: The following extras for hpqtypes library: . @@ -89,8 +89,8 @@ , containers >= 0.5 , exceptions >= 0.10 , extra >= 1.6.17 - , hpqtypes >= 1.13.0.0 - , log-base >= 0.11 + , hpqtypes >= 1.13.0.0 && < 2 + , log-base >= 0.12.0.1 , mtl >= 2.2 , ppad-ripemd160 >= 0.1.4 , text >= 1.2 @@ -127,7 +127,7 @@ , hpqtypes-extras , log-base , tasty - , tasty-hunit + , tasty-hunit >= 0.10 , text , uuid-types 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 @@ -88,6 +88,7 @@ , dbTables = tables } migrations = do + checkPostgresVersion setDBTimeZoneToUTC mapM_ checkExtension extensions tablesWithVersions <- getTableVersions (tableVersions : tables) @@ -131,6 +132,7 @@ , dbDomains = domains , dbTables = tables } = execWriterT $ do + lift checkPostgresVersion (_, report) <- W.listen $ do tablesWithVersions <- getTableVersions (tableVersions : tables) tell $ checkVersions options tablesWithVersions @@ -600,12 +602,11 @@ sqlOrderBy "a.attnum" desc <- fetchMany fetchTableColumn - isAbove15 <- checkVersionIsAtLeast15 -- get info about constraints from pg_catalog pk <- sqlGetPrimaryKey tblName runQuery_ $ sqlGetChecks tblName checks <- fetchMany fetchTableCheck - runQuery_ $ sqlGetIndexes isAbove15 tblName Nothing + runQuery_ $ sqlGetIndexes tblName Nothing indexes <- fetchMany fetchTableIndex runQuery_ $ sqlGetForeignKeys tblName fkeys <- fetchMany fetchForeignKey @@ -1131,8 +1132,7 @@ indexSet <- case mLocalIndexName of Nothing -> pure False Just localIndexName -> do - isAbove15 <- checkVersionIsAtLeast15 - runQuery_ $ sqlGetIndexes isAbove15 mgrTableName (Just localIndexName) + runQuery_ $ sqlGetIndexes mgrTableName (Just localIndexName) fetchMaybe fetchTableIndex >>= \case Nothing -> do logInfo_ "Local index not found" @@ -1378,11 +1378,21 @@ -- | Type synonym for a list of tables along with their database versions. type TablesWithVersions = [(Table, Int32)] --- The server_version_num has been there since 8.2 -checkVersionIsAtLeast15 :: (MonadDB m, MonadThrow m) => m Bool -checkVersionIsAtLeast15 = do - runSQL01_ "select current_setting('server_version_num',true)::int >= 150000;" - fetchOne runIdentity +-- | Fail if the PostgreSQL server is older than the oldest supported version. +checkPostgresVersion :: (MonadDB m, MonadLog m, MonadThrow m) => m () +checkPostgresVersion = do + runSQL_ "SELECT current_setting('server_version_num')::int4, current_setting('server_version')" + (versionNum, version) <- fetchOne $ id @(Int32, Text) + when (versionNum < minimumVersion) . resultCheck . validationError $ + T.concat + [ "PostgreSQL " + , version + , " is not supported, the minimum supported version is " + , showt $ minimumVersion `div` 10_000 + ] + where + minimumVersion :: Int32 + minimumVersion = 150_000 -- | Associate each table in the list with its version as it exists in -- the DB, or 0 if it's missing from the DB. @@ -1516,17 +1526,14 @@ } -- *** INDEXES *** -sqlGetIndexes :: Bool -> RawSQL () -> Maybe (RawSQL ()) -> SQL -sqlGetIndexes nullsNotDistinctSupported tableName mname = toSQLCommand . sqlSelect "pg_catalog.pg_class c" $ do +sqlGetIndexes :: RawSQL () -> Maybe (RawSQL ()) -> SQL +sqlGetIndexes tableName mname = toSQLCommand . sqlSelect "pg_catalog.pg_class c" $ do sqlResult "c.relname::text" -- index name sqlResult $ "ARRAY(" <> selectCoordinates "0" "i.indnkeyatts" <> ")" -- array of key columns in the index 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? - -- does it have NULLS NOT DISTINCT ? - if nullsNotDistinctSupported - then sqlResult "i.indnullsnotdistinct" - else sqlResult "false" + sqlResult "i.indnullsnotdistinct" -- does it have NULLS NOT DISTINCT? -- if partial, get constraint def sqlResult "pg_catalog.pg_get_expr(i.indpred, i.indrelid, true)" sqlJoinOn "pg_catalog.pg_index i" "c.oid = i.indexrelid" diff --git a/src/Database/PostgreSQL/PQTypes/SQL/Builder.hs b/src/Database/PostgreSQL/PQTypes/SQL/Builder.hs --- a/src/Database/PostgreSQL/PQTypes/SQL/Builder.hs +++ b/src/Database/PostgreSQL/PQTypes/SQL/Builder.hs @@ -125,9 +125,9 @@ , sqlWith , sqlWithRecursive , sqlWithMaterialized + , sqlWithNotMaterialized , sqlUnion , sqlUnionAll - , checkAndRememberMaterializationSupport , sqlSelect , sqlSelect2 , SqlSelect (..) @@ -165,18 +165,12 @@ ) where -import Control.Monad.Catch import Control.Monad.State -import Data.Either -import Data.IORef -import Data.Int import Data.List import Data.Maybe import Data.Monoid.Utils import Data.String -import Data.Typeable import Database.PostgreSQL.PQTypes -import System.IO.Unsafe class Sqlable a where toSQLCommand :: a -> SQL @@ -209,7 +203,7 @@ deriving (Eq, Show) data Multiplicity a = Single a | Many [a] - deriving (Eq, Ord, Show, Typeable) + deriving (Eq, Ord, Show) -- | 'SqlCondition' are clauses that are part of the WHERE block in -- SQL statements. Each statement has a list of conditions, all of @@ -220,7 +214,7 @@ data SqlCondition = SqlPlainCondition SQL | SqlExistsCondition SqlSelect - deriving (Typeable, Show) + deriving (Show) instance Sqlable SqlCondition where toSQLCommand (SqlPlainCondition a) = a @@ -238,7 +232,7 @@ , sqlSelectHaving :: [SQL] , sqlSelectOffset :: Integer , sqlSelectLimit :: Integer - , sqlSelectWith :: [(SQL, SQL, Materialized)] + , sqlSelectWith :: [(SQL, SQL, Materialization)] , sqlSelectRecursiveWith :: Recursive } @@ -248,7 +242,7 @@ , sqlUpdateWhere :: [SqlCondition] , sqlUpdateSet :: [(SQL, SQL)] , sqlUpdateResult :: [SQL] - , sqlUpdateWith :: [(SQL, SQL, Materialized)] + , sqlUpdateWith :: [(SQL, SQL, Materialization)] , sqlUpdateRecursiveWith :: Recursive } @@ -257,7 +251,7 @@ , sqlInsertOnConflict :: Maybe (SQL, Maybe SQL) , sqlInsertSet :: [(SQL, Multiplicity SQL)] , sqlInsertResult :: [SQL] - , sqlInsertWith :: [(SQL, SQL, Materialized)] + , sqlInsertWith :: [(SQL, SQL, Materialization)] , sqlInsertRecursiveWith :: Recursive } @@ -274,7 +268,7 @@ , sqlInsertSelectHaving :: [SQL] , sqlInsertSelectOffset :: Integer , sqlInsertSelectLimit :: Integer - , sqlInsertSelectWith :: [(SQL, SQL, Materialized)] + , sqlInsertSelectWith :: [(SQL, SQL, Materialization)] , sqlInsertSelectRecursiveWith :: Recursive } @@ -283,7 +277,7 @@ , sqlDeleteUsing :: SQL , sqlDeleteWhere :: [SqlCondition] , sqlDeleteResult :: [SQL] - , sqlDeleteWith :: [(SQL, SQL, Materialized)] + , sqlDeleteWith :: [(SQL, SQL, Materialization)] , sqlDeleteRecursiveWith :: Recursive } @@ -355,7 +349,7 @@ toSQLCommand cmd = smconcat [ emitClausesSepComma (recursiveClause $ sqlSelectRecursiveWith cmd) $ - map (\(name, command, mat) -> name <+> "AS" <+> materializedClause mat <+> parenthesize command) (sqlSelectWith cmd) + map withClause (sqlSelectWith cmd) , if hasUnion || hasUnionAll then emitClausesSep "" unionKeyword (mainSelectClause : unionCmd) else mainSelectClause @@ -412,7 +406,7 @@ toSQLCommand cmd = emitClausesSepComma (recursiveClause $ sqlInsertRecursiveWith cmd) - (map (\(name, command, mat) -> name <+> "AS" <+> materializedClause mat <+> parenthesize command) (sqlInsertWith cmd)) + (map withClause (sqlInsertWith cmd)) <+> "INSERT INTO" <+> sqlInsertWhat cmd <+> parenthesize (sqlConcatComma (map fst (sqlInsertSet cmd))) @@ -433,7 +427,7 @@ -- WITH clause needs to be at the top level, so we emit it here and not -- include it in the SqlSelect below. [ emitClausesSepComma (recursiveClause $ sqlInsertSelectRecursiveWith cmd) $ - map (\(name, command, mat) -> name <+> "AS" <+> materializedClause mat <+> parenthesize command) (sqlInsertSelectWith cmd) + map withClause (sqlInsertSelectWith cmd) , "INSERT INTO" <+> sqlInsertSelectWhat cmd , parenthesize . sqlConcatComma . map fst $ sqlInsertSelectSet cmd , parenthesize . toSQLCommand $ @@ -456,27 +450,15 @@ , emitClausesSepComma "RETURNING" $ sqlInsertSelectResult cmd ] --- This function has to be called as one of first things in your program --- for the library to make sure that it is aware if the "WITH MATERIALIZED" --- clause is supported by your PostgreSQL version. -checkAndRememberMaterializationSupport :: (MonadDB m, MonadIO m, MonadMask m) => m () -checkAndRememberMaterializationSupport = do - res :: Either DBException Int64 <- try . withNewConnection $ do - runSQL01_ "WITH t(n) AS MATERIALIZED (SELECT (1 :: bigint)) SELECT n FROM t LIMIT 1" - fetchOne runIdentity - liftIO $ writeIORef withMaterializedSupported (isRight res) - -withMaterializedSupported :: IORef Bool -{-# NOINLINE withMaterializedSupported #-} -withMaterializedSupported = unsafePerformIO $ newIORef False - -isWithMaterializedSupported :: Bool -{-# NOINLINE isWithMaterializedSupported #-} -isWithMaterializedSupported = unsafePerformIO $ readIORef withMaterializedSupported - -materializedClause :: Materialized -> SQL -materializedClause Materialized = if isWithMaterializedSupported then "MATERIALIZED" else "" -materializedClause NonMaterialized = if isWithMaterializedSupported then "NOT MATERIALIZED" else "" +withClause :: (SQL, SQL, Materialization) -> SQL +withClause (name, command, materialization) = + name <+> "AS" <+> materializationClause <+> parenthesize command + where + materializationClause :: SQL + materializationClause = case materialization of + DefaultMaterialization -> "" + Materialized -> "MATERIALIZED" + NotMaterialized -> "NOT MATERIALIZED" recursiveClause :: Recursive -> SQL recursiveClause Recursive = "WITH RECURSIVE" @@ -486,7 +468,7 @@ toSQLCommand cmd = emitClausesSepComma (recursiveClause $ sqlUpdateRecursiveWith cmd) - (map (\(name, command, mat) -> name <+> "AS" <+> materializedClause mat <+> parenthesize command) (sqlUpdateWith cmd)) + (map withClause (sqlUpdateWith cmd)) <+> "UPDATE" <+> sqlUpdateWhat cmd <+> "SET" @@ -499,7 +481,7 @@ toSQLCommand cmd = emitClausesSepComma (recursiveClause $ sqlDeleteRecursiveWith cmd) - (map (\(name, command, mat) -> name <+> "AS" <+> materializedClause mat <+> parenthesize command) (sqlDeleteWith cmd)) + (map withClause (sqlDeleteWith cmd)) <+> "DELETE FROM" <+> sqlDeleteFrom cmd <+> emitClause "USING" (sqlDeleteUsing cmd) @@ -570,7 +552,7 @@ } ) -data Materialized = Materialized | NonMaterialized +data Materialization = DefaultMaterialization | Materialized | NotMaterialized data Recursive = Recursive | NonRecursive -- This instance guarantees that once a single CTE has @@ -582,7 +564,7 @@ _ <> _ = NonRecursive class SqlWith a where - sqlWith1 :: a -> SQL -> SQL -> Materialized -> Recursive -> a + sqlWith1 :: a -> SQL -> SQL -> Materialization -> Recursive -> a instance SqlWith SqlSelect where sqlWith1 cmd name sql mat recurse = cmd {sqlSelectWith = sqlSelectWith cmd ++ [(name, sql, mat)], sqlSelectRecursiveWith = recurse <> sqlSelectRecursiveWith cmd} @@ -596,15 +578,23 @@ instance SqlWith SqlDelete where sqlWith1 cmd name sql mat recurse = cmd {sqlDeleteWith = sqlDeleteWith cmd ++ [(name, sql, mat)], sqlDeleteRecursiveWith = recurse <> sqlDeleteRecursiveWith cmd} +-- | Add a @WITH@ clause and let PostgreSQL decide whether to materialize it. sqlWith :: (MonadState v m, SqlWith v, Sqlable s) => SQL -> s -> m () -sqlWith name sql = modify (\cmd -> sqlWith1 cmd name (toSQLCommand sql) NonMaterialized NonRecursive) +sqlWith name sql = modify (\cmd -> sqlWith1 cmd name (toSQLCommand sql) DefaultMaterialization NonRecursive) +-- | Add a @WITH ... AS MATERIALIZED@ clause. sqlWithMaterialized :: (MonadState v m, SqlWith v, Sqlable s) => SQL -> s -> m () sqlWithMaterialized name sql = modify (\cmd -> sqlWith1 cmd name (toSQLCommand sql) Materialized NonRecursive) +-- | Add a @WITH ... AS NOT MATERIALIZED@ clause. +-- +-- @since 1.21.0.0 +sqlWithNotMaterialized :: (MonadState v m, SqlWith v, Sqlable s) => SQL -> s -> m () +sqlWithNotMaterialized name sql = modify (\cmd -> sqlWith1 cmd name (toSQLCommand sql) NotMaterialized NonRecursive) + -- | Note: RECURSIVE only powers SELECTs (but the SELECT can feed an UPDATE outside of the recursive query). sqlWithRecursive :: (MonadState v m, SqlWith v, Sqlable s) => SQL -> s -> m () -sqlWithRecursive name sql = modify (\cmd -> sqlWith1 cmd name (toSQLCommand sql) NonMaterialized Recursive) +sqlWithRecursive name sql = modify (\cmd -> sqlWith1 cmd name (toSQLCommand sql) DefaultMaterialization Recursive) -- | Note: WHERE clause of the main SELECT is treated specially, i.e. it only -- applies to the main SELECT, not the whole union. diff --git a/src/Database/PostgreSQL/PQTypes/Utils/NubList.hs b/src/Database/PostgreSQL/PQTypes/Utils/NubList.hs --- a/src/Database/PostgreSQL/PQTypes/Utils/NubList.hs +++ b/src/Database/PostgreSQL/PQTypes/Utils/NubList.hs @@ -5,8 +5,6 @@ , overNubList ) where -import Data.Typeable - import Data.Semigroup qualified as SG import Data.Set qualified as Set import Text.Read qualified as R @@ -21,7 +19,7 @@ -- | NubList : A de-duplicated list that maintains the original order. newtype NubList a = NubList {fromNubList :: [a]} - deriving (Eq, Typeable) + deriving (Eq) -- NubList assumes that nub retains the list order while removing duplicate -- elements (keeping the first occurence). Documentation for "Data.List.nub" diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -28,7 +28,6 @@ import Test.Tasty.Options newtype ConnectionString = ConnectionString String - deriving (Typeable) instance IsOption ConnectionString where defaultValue = @@ -1617,11 +1616,6 @@ testSqlWith step = do step "Running sql WITH tests" testPass - runSQL_ "DELETE FROM bank" - step "Checking for WITH MATERIALIZED support" - checkAndRememberMaterializationSupport - step "Running sql WITH tests again with WITH MATERIALIZED support flag set" - testPass where migrate tables migrations = do let definitions = tableDefsWithPgCrypto tables @@ -1644,9 +1638,9 @@ sqlFrom "bank_name" sqlSetCmd "name" "bank_name" sqlSet "location" ("Other side" :: T.Text) - step "testing WITH .. UPDATE" + step "testing WITH MATERIALIZED .. UPDATE" runQuery_ . sqlUpdate "bank" $ do - sqlWith "other_bank" $ do + sqlWithMaterialized "other_bank" $ do sqlSelect "bank" $ do sqlWhereEq "name" ("other" :: T.Text) sqlResult "id" @@ -1654,9 +1648,9 @@ sqlSet "location" ("abcd" :: T.Text) sqlWhereInSql "bank.id" $ mkSQL "other_bank.id" sqlResult "bank.id" - step "testing WITH .. DELETE" + step "testing WITH NOT MATERIALIZED .. DELETE" runQuery_ . sqlDelete "bank" $ do - sqlWith "other_bank" $ do + sqlWithNotMaterialized "other_bank" $ do sqlSelect "bank" $ do sqlWhereEq "name" ("other" :: T.Text) sqlResult "id"