hpqtypes-extras 1.16.2.0 → 1.16.3.0

raw patch · 4 files changed

+131/−20 lines, 4 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• hpqtypes-extras.cabal +2/−2
• src/Database/PostgreSQL/PQTypes/SQL/Builder.hs +58/−16
• test/Main.hs +67/−2

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

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

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

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