diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +# hpqtypes-extras-1.16.3.0 (2023-01-25) +* Add support for `WITH MATERIALIZED` with backward compatibility. +* Add `sqlWhereEqualsAny`. + # hpqtypes-extras-1.16.2.0 (2022-10-27) * Add support for setting collation method for columns. 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.16.2.0 +version: 1.16.3.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.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.4 +tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.4 || ==9.4.2 Source-repository head Type: git 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 @@ -91,6 +91,7 @@ , sqlWhereEq , sqlWhereEqSql , sqlWhereNotEq + , sqlWhereEqualsAny , sqlWhereIn , sqlWhereInSql , sqlWhereNotIn @@ -126,7 +127,9 @@ , sqlLimit , sqlDistinct , sqlWith + , sqlWithMaterialized , sqlUnion + , checkAndRememberMaterializationSupport , sqlSelect , sqlSelect2 @@ -166,12 +169,17 @@ where import Control.Monad.State +import Control.Monad.Catch +import Data.Int +import Data.IORef +import Data.Either 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 @@ -231,7 +239,7 @@ , sqlSelectHaving :: [SQL] , sqlSelectOffset :: Integer , sqlSelectLimit :: Integer - , sqlSelectWith :: [(SQL, SQL)] + , sqlSelectWith :: [(SQL, SQL, Materialized)] } data SqlUpdate = SqlUpdate @@ -240,7 +248,7 @@ , sqlUpdateWhere :: [SqlCondition] , sqlUpdateSet :: [(SQL,SQL)] , sqlUpdateResult :: [SQL] - , sqlUpdateWith :: [(SQL, SQL)] + , sqlUpdateWith :: [(SQL, SQL, Materialized)] } data SqlInsert = SqlInsert @@ -248,7 +256,7 @@ , sqlInsertOnConflict :: Maybe (SQL, Maybe SQL) , sqlInsertSet :: [(SQL, Multiplicity SQL)] , sqlInsertResult :: [SQL] - , sqlInsertWith :: [(SQL, SQL)] + , sqlInsertWith :: [(SQL, SQL, Materialized)] } data SqlInsertSelect = SqlInsertSelect @@ -264,7 +272,7 @@ , sqlInsertSelectHaving :: [SQL] , sqlInsertSelectOffset :: Integer , sqlInsertSelectLimit :: Integer - , sqlInsertSelectWith :: [(SQL, SQL)] + , sqlInsertSelectWith :: [(SQL, SQL, Materialized)] } data SqlDelete = SqlDelete @@ -272,7 +280,7 @@ , sqlDeleteUsing :: SQL , sqlDeleteWhere :: [SqlCondition] , sqlDeleteResult :: [SQL] - , sqlDeleteWith :: [(SQL, SQL)] + , sqlDeleteWith :: [(SQL, SQL, Materialized)] } -- | This is not exported and is used as an implementation detail in @@ -331,7 +339,7 @@ instance Sqlable SqlSelect where toSQLCommand cmd = smconcat [ emitClausesSepComma "WITH" $ - map (\(name,command) -> name <+> "AS" <+> parenthesize command) (sqlSelectWith cmd) + map (\(name,command,mat) -> name <+> "AS" <+> materializedClause mat <+> parenthesize command) (sqlSelectWith cmd) , if hasUnion then emitClausesSep "" "UNION" (mainSelectClause : sqlSelectUnion cmd) else mainSelectClause @@ -371,7 +379,7 @@ instance Sqlable SqlInsert where toSQLCommand cmd = - emitClausesSepComma "WITH" (map (\(name,command) -> name <+> "AS" <+> parenthesize command) (sqlInsertWith cmd)) <+> + emitClausesSepComma "WITH" (map (\(name,command,mat) -> name <+> "AS" <+> materializedClause mat <+> parenthesize command) (sqlInsertWith cmd)) <+> "INSERT INTO" <+> sqlInsertWhat cmd <+> parenthesize (sqlConcatComma (map fst (sqlInsertSet cmd))) <+> emitClausesSep "VALUES" "," (map sqlConcatComma (transpose (map (makeLongEnough . snd) (sqlInsertSet cmd)))) <+> @@ -390,7 +398,7 @@ -- WITH clause needs to be at the top level, so we emit it here and not -- include it in the SqlSelect below. [ emitClausesSepComma "WITH" $ - map (\(name,command) -> name <+> "AS" <+> parenthesize command) (sqlInsertSelectWith cmd) + map (\(name,command,mat) -> name <+> "AS" <+> materializedClause mat <+> parenthesize command) (sqlInsertSelectWith cmd) , "INSERT INTO" <+> sqlInsertSelectWhat cmd , parenthesize . sqlConcatComma . map fst $ sqlInsertSelectSet cmd , parenthesize . toSQLCommand $ SqlSelect { sqlSelectFrom = sqlInsertSelectFrom cmd @@ -409,9 +417,30 @@ , 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) SELECT n FROM t LIMIT 1" + fetchOne runIdentity + liftIO $ writeIORef withMaterializedSupported (isRight res) + +withMaterializedSupported :: IORef Bool +{-# NOINLINE withMaterializedSupported #-} +withMaterializedSupported = unsafePerformIO $ newIORef False + +isWithMaterializedSupported :: Bool +isWithMaterializedSupported = unsafePerformIO $ readIORef withMaterializedSupported + +materializedClause :: Materialized -> SQL +materializedClause Materialized = if isWithMaterializedSupported then "MATERIALIZED" else "" +materializedClause NonMaterialized = if isWithMaterializedSupported then "NOT MATERIALIZED" else "" + instance Sqlable SqlUpdate where toSQLCommand cmd = - emitClausesSepComma "WITH" (map (\(name,command) -> name <+> "AS" <+> parenthesize command) (sqlUpdateWith cmd)) <+> + emitClausesSepComma "WITH" (map (\(name,command,mat) -> name <+> "AS" <+> materializedClause mat <+> parenthesize command) (sqlUpdateWith cmd)) <+> "UPDATE" <+> sqlUpdateWhat cmd <+> "SET" <+> sqlConcatComma (map (\(name, command) -> name <> "=" <> command) (sqlUpdateSet cmd)) <+> emitClause "FROM" (sqlUpdateFrom cmd) <+> @@ -420,7 +449,7 @@ instance Sqlable SqlDelete where toSQLCommand cmd = - emitClausesSepComma "WITH" (map (\(name,command) -> name <+> "AS" <+> parenthesize command) (sqlDeleteWith cmd)) <+> + emitClausesSepComma "WITH" (map (\(name,command,mat) -> name <+> "AS" <+> materializedClause mat <+> parenthesize command) (sqlDeleteWith cmd)) <+> "DELETE FROM" <+> sqlDeleteFrom cmd <+> emitClause "USING" (sqlDeleteUsing cmd) <+> emitClausesSep "WHERE" "AND" (map toSQLCommand $ sqlDeleteWhere cmd) <+> @@ -475,25 +504,31 @@ , sqlDeleteWith = [] }) + +data Materialized = Materialized | NonMaterialized + class SqlWith a where - sqlWith1 :: a -> SQL -> SQL -> a + sqlWith1 :: a -> SQL -> SQL -> Materialized -> a instance SqlWith SqlSelect where - sqlWith1 cmd name sql = cmd { sqlSelectWith = sqlSelectWith cmd ++ [(name,sql)] } + sqlWith1 cmd name sql mat = cmd { sqlSelectWith = sqlSelectWith cmd ++ [(name,sql, mat)] } instance SqlWith SqlInsertSelect where - sqlWith1 cmd name sql = cmd { sqlInsertSelectWith = sqlInsertSelectWith cmd ++ [(name,sql)] } + sqlWith1 cmd name sql mat = cmd { sqlInsertSelectWith = sqlInsertSelectWith cmd ++ [(name,sql,mat)] } instance SqlWith SqlUpdate where - sqlWith1 cmd name sql = cmd { sqlUpdateWith = sqlUpdateWith cmd ++ [(name,sql)] } + sqlWith1 cmd name sql mat = cmd { sqlUpdateWith = sqlUpdateWith cmd ++ [(name,sql,mat)] } instance SqlWith SqlDelete where - sqlWith1 cmd name sql = cmd { sqlDeleteWith = sqlDeleteWith cmd ++ [(name,sql)] } + sqlWith1 cmd name sql mat = cmd { sqlDeleteWith = sqlDeleteWith cmd ++ [(name,sql,mat)] } sqlWith :: (MonadState v m, SqlWith v, Sqlable s) => SQL -> s -> m () -sqlWith name sql = modify (\cmd -> sqlWith1 cmd name (toSQLCommand sql)) +sqlWith name sql = modify (\cmd -> sqlWith1 cmd name (toSQLCommand sql) NonMaterialized) +sqlWithMaterialized :: (MonadState v m, SqlWith v, Sqlable s) => SQL -> s -> m () +sqlWithMaterialized name sql = modify (\cmd -> sqlWith1 cmd name (toSQLCommand sql) Materialized) + -- | Note: WHERE clause of the main SELECT is treated specially, i.e. it only -- applies to the main SELECT, not the whole union. sqlUnion :: (MonadState SqlSelect m, Sqlable sql) => [sql] -> m () @@ -542,6 +577,13 @@ sqlWhereILike :: (MonadState v m, SqlWhere v, Show a, ToSQL a) => SQL -> a -> m () sqlWhereILike name value = sqlWhere $ name <+> "ILIKE" value + +-- | Similar to 'sqlWhereIn', but uses @ANY@ instead of @SELECT UNNEST@. +sqlWhereEqualsAny :: (MonadState v m, SqlWhere v, Show a, ToSQL a) => SQL -> [a] -> m () +sqlWhereEqualsAny name = \case + [] -> sqlWhere "FALSE" + [value] -> sqlWhereEq name value + values -> sqlWhere $ name <+> "= ANY(" Array1 values <+> ")" sqlWhereIn :: (MonadState v m, SqlWhere v, Show a, ToSQL a) => SQL -> [a] -> m () sqlWhereIn _name [] = sqlWhere "FALSE" diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1199,6 +1199,64 @@ runSQL_ "DELETE FROM table_versions WHERE name = 'bank'"; migrate [tableBankSchema1] [createTableMigration tableBankSchema1] +testSqlWith :: HasCallStack => (String -> TestM ()) -> TestM () +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 + migrateDatabase defaultExtrasOptions ["pgcrypto"] [] [] tables migrations + checkDatabase defaultExtrasOptions [] [] tables + testPass = do + step "create the initial database" + migrate [tableBankSchema1] [createTableMigration tableBankSchema1] + step "inserting initial data" + runQuery_ . sqlInsert "bank" $ do + sqlSetList "name" (["HSBC" :: T.Text, "other"]) + sqlSetList "location" (["13 Foo St., Tucson" :: T.Text, "no address"]) + sqlResult "id" + step "testing WITH .. INSERT SELECT" + runQuery_ . sqlInsertSelect "bank" "bank_name" $ do + sqlWith "bank_name" $ do + sqlSelect "bank" $ do + sqlResult "'another'" + sqlLimit (1 :: Int) + sqlFrom "bank_name" + sqlSetCmd "name" "bank_name" + sqlSet "location" ("Other side" :: T.Text) + step "testing WITH .. UPDATE" + runQuery_ . sqlUpdate "bank" $ do + sqlWith "other_bank" $ do + sqlSelect "bank" $ do + sqlWhereEq "name" ("other" :: T.Text) + sqlResult "id" + sqlFrom "other_bank" + sqlSet "location" ("abcd" :: T.Text) + sqlWhereInSql "bank.id" $ mkSQL "other_bank.id" + sqlResult "bank.id" + step "testing WITH .. DELETE" + runQuery_ . sqlDelete "bank" $ do + sqlWith "other_bank" $ do + sqlSelect "bank" $ do + sqlWhereEq "name" ("other" :: T.Text) + sqlResult "id" + sqlFrom "other_bank" + sqlWhereInSql "bank.id" $ mkSQL "other_bank.id" + step "testing WITH .. SELECT" + runQuery_ . sqlSelect "bank" $ do + sqlWith "other_bank" $ do + sqlSelect "bank" $ do + sqlResult "name" + sqlFrom "other_bank" + sqlResult "other_bank.name" + (results :: [T.Text]) <- fetchMany runIdentity + liftIO $ assertEqual "Wrong number of banks left" 2 (length results) + migrationTest1 :: ConnectionSourceM (LogT IO) -> TestTree migrationTest1 connSource = testCaseSteps' "Migration test 1" connSource $ \step -> do @@ -1334,6 +1392,12 @@ freshTestDB step testTriggers step +sqlWithTests :: ConnectionSourceM (LogT IO) -> TestTree +sqlWithTests connSource = + testCaseSteps' "sql WITH tests" connSource $ \step -> do + freshTestDB step + testSqlWith step + eitherExc :: MonadCatch m => (SomeException -> m ()) -> (a -> m ()) -> m a -> m () eitherExc left right c = try c >>= either left right @@ -1432,7 +1496,7 @@ copyColumnSql primaryKeys = runQuery_ . sqlUpdate "bank" $ do sqlSetCmd "name_new" "bank.name" - sqlWhereIn "bank.id" $ runIdentity <$> primaryKeys + sqlWhereEqualsAny "bank.id" $ runIdentity <$> primaryKeys addBoolColumnMigration = Migration { mgrTableName = "bank" @@ -1497,7 +1561,7 @@ testCaseSteps' testName connSource f = testCaseSteps testName $ \step' -> do let step s = liftIO $ step' s - withSimpleStdOutLogger $ \logger -> + withStdOutLogger $ \logger -> runLogT "hpqtypes-extras-test" logger defaultLogLevel $ runDBT connSource defaultTransactionSettings $ f step @@ -1516,6 +1580,7 @@ , migrationTest4 connSource , migrationTest5 connSource , triggerTests connSource + , sqlWithTests connSource ] where ings =