From 4e4903dbdc54b6e2244c812346e97f940d1851cb Mon Sep 17 00:00:00 2001 From: Dylan Martin Date: Wed, 31 Mar 2021 11:15:54 -0700 Subject: [PATCH 01/41] initial implementation of the upsertWhere --- persistent-mysql/Database/Persist/MySQL.hs | 2 +- .../Database/Persist/Postgresql.hs | 316 +++++++++++++++++- .../Database/Persist/query.sql | 8 + .../Persist/Sql/Orphan/PersistQuery.hs | 1 + 4 files changed, 322 insertions(+), 5 deletions(-) create mode 100644 persistent-postgresql/Database/Persist/query.sql diff --git a/persistent-mysql/Database/Persist/MySQL.hs b/persistent-mysql/Database/Persist/MySQL.hs index 4f3476abb..addaaf3bc 100644 --- a/persistent-mysql/Database/Persist/MySQL.hs +++ b/persistent-mysql/Database/Persist/MySQL.hs @@ -1428,7 +1428,7 @@ copyField = CopyField -- [] -- @ -- --- Once we run that code on the datahase, the new data set looks like this: +-- Once we run that code on the database, the new data set looks like this: -- -- > items: -- > +------+-------------+-------+----------+ diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index 459d69ffc..f4046950f 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -1,5 +1,9 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -23,6 +27,7 @@ module Database.Persist.Postgresql , ConnectionString , PostgresConf (..) , PgInterval (..) + , upsertWhere , openSimpleConn , openSimpleConnWithVersion , tableName @@ -50,7 +55,7 @@ import Control.Monad import Control.Monad.Except import Control.Monad.IO.Unlift (MonadIO (..), MonadUnliftIO) import Control.Monad.Logger (MonadLoggerIO, runNoLoggingT) -import Control.Monad.Trans.Reader (runReaderT) +import Control.Monad.Trans.Reader (ReaderT(..), runReaderT) import Control.Monad.Trans.Writer (WriterT(..), runWriterT) import qualified Blaze.ByteString.Builder.Char8 as BBB @@ -73,7 +78,7 @@ import Data.Function (on) import Data.Int (Int64) import qualified Data.IntMap as I import Data.IORef -import Data.List (find, sort, groupBy, foldl') +import Data.List (find, sort, groupBy, foldl', transpose, inits) import Data.List.NonEmpty (NonEmpty) import qualified Data.List as List import qualified Data.List.NonEmpty as NEL @@ -82,7 +87,7 @@ import Data.Maybe import Data.Monoid ((<>)) import Data.Pool (Pool) import Data.String.Conversions.Monomorphic (toStrictByteString) -import Data.Text (Text) +import Data.Text (Text, pack) import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T @@ -91,6 +96,7 @@ import Data.Time (utc, NominalDiffTime, localTimeToUTC) import System.Environment (getEnvironment) import Database.Persist.Sql +import Database.Persist.Sql.Util (isIdField) import qualified Database.Persist.Sql.Util as Util -- | A @libpq@ connection string. A simple example of connection @@ -397,7 +403,6 @@ insertSql' ent vals = ] ] - upsertSql' :: EntityDef -> NonEmpty (FieldNameHS, FieldNameDB) -> Text -> Text upsertSql' ent uniqs updateVal = T.concat @@ -1487,15 +1492,24 @@ tableName = escapeE . tableDBName fieldName :: (PersistEntity record) => EntityField record typ -> Text fieldName = escapeF . fieldDBName +fieldName' :: forall record typ. (PersistEntity record, PersistEntityBackend record ~ SqlBackend) => EntityField record typ -> FieldNameDB +fieldName' f = fieldDB $ persistFieldDef f + escapeC :: ConstraintNameDB -> Text escapeC = escapeWith escape escapeE :: EntityNameDB -> Text escapeE = escapeWith escape +escapeES :: EntityNameDB -> String +escapeES = escapeWith (escapeDBName . T.unpack) + escapeF :: FieldNameDB -> Text escapeF = escapeWith escape +escapeFS :: FieldNameDB -> String +escapeFS = escapeWith (escapeDBName . T.unpack) + escape :: Text -> Text escape s = T.pack $ '"' : go (T.unpack s) ++ "\"" @@ -1504,6 +1518,14 @@ escape s = go ('"':xs) = "\"\"" ++ go xs go (x:xs) = x : go xs +-- | Escape a database name to be included on a query. +escapeDBName :: String -> String +escapeDBName str = '`' : go str + where + go ('`':xs) = '`' : '`' : go xs + go ( x :xs) = x : go xs + go "" = "`" + -- | Information required to connect to a PostgreSQL database -- using @persistent@'s generic facilities. These values are the -- same that are given to 'withPostgresqlPool'. @@ -1738,6 +1760,292 @@ repsertManySql ent n = putManySql' conflictColumns fields ent n fields = keyAndEntityFields ent conflictColumns = escapeF . fieldDB <$> entityKeyFields ent +-- | This type is used to determine how to update rows using MySQL's +-- @INSERT ... ON DUPLICATE KEY UPDATE@ functionality, exposed via +-- 'insertManyOnDuplicateKeyUpdate' in this library. +-- +-- @since 2.8.0 +data HandleUpdateCollision record where + -- | Copy the field directly from the record. + CopyField :: EntityField record typ -> HandleUpdateCollision record + -- | Only copy the field if it is not equal to the provided value. + CopyUnlessEq :: PersistField typ => EntityField record typ -> typ -> HandleUpdateCollision record + +-- | Postgres specific 'upsertWhere'. This will prevent multiple queries, when one will +-- do. The record will be inserted into the database. In the event that the +-- record already exists in the database, the record will have the +-- relevant updates performed. +upsertWhere + :: ( backend ~ PersistEntityBackend record + , PersistEntity record + , PersistEntityBackend record ~ SqlBackend + , MonadIO m + , PersistStore backend + , BackendCompatible SqlBackend backend + ) + => record + -> SqlBackend + -> [Update record] + -> [Filter record] + -> ReaderT backend m () +upsertWhere record conn updates filts = + upsertManyWhere [record] conn [] updates filts + +upsertManyWhere :: + forall record backend m. + ( backend ~ PersistEntityBackend record, + BackendCompatible SqlBackend backend, + PersistEntityBackend record ~ SqlBackend, + PersistEntity record, + MonadIO m + ) => + -- | A list of the records you want to insert, or update + [record] -> + SqlBackend -> + -- | A list of the fields you want to copy over. + [HandleUpdateCollision record] -> + -- | A list of the updates to apply that aren't dependent on the record being inserted. + [Update record] -> + [Filter record] -> + ReaderT backend m () +upsertManyWhere [] _ _ _ _ = return () +upsertManyWhere records conn fieldValues updates conditions = + uncurry rawExecute $ + mkBulkUpsertQuery records conn fieldValues updates conditions + +-- | This creates the query for 'bulkInsertOnDuplicateKeyUpdate'. If you +-- provide an empty list of updates to perform, then it will generate +-- a dummy/no-op update using the first field of the record. This avoids +-- duplicate key exceptions. +mkBulkUpsertQuery + :: (PersistEntity record, PersistEntityBackend record ~ SqlBackend) + => [record] -- ^ A list of the records you want to insert, or update + -> SqlBackend + -> [HandleUpdateCollision record] -- ^ A list of the fields you want to copy over. + -> [Update record] -- ^ A list of the updates to apply that aren't dependent on the record being inserted. + -> [Filter record] + -> (Text, [PersistValue]) +mkBulkUpsertQuery records conn fieldValues updates filts = + (q, recordValues <> updsValues <> copyUnlessValues) + where + mfieldDef x = case x of + CopyField rec -> Right (fieldDbToText (persistFieldDef rec)) + CopyUnlessEq rec val -> Left (fieldDbToText (persistFieldDef rec), toPersistValue val) + (fieldsToMaybeCopy, updateFieldNames) = partitionEithers $ map mfieldDef fieldValues + fieldDbToText = T.pack . escapeFS . fieldDB + entityDef' = entityDef records + firstField = case entityFieldNames of + [] -> error "The entity you're trying to insert does not have any fields." + (field:_) -> field + entityFieldNames = map fieldDbToText (entityFields entityDef') + nameOfTable = T.pack . escapeES . entityDB $ entityDef' + copyUnlessValues = map snd fieldsToMaybeCopy + recordValues = concatMap (map toPersistValue . toPersistFields) records + recordPlaceholders = Util.commaSeparated $ map (Util.parenWrapped . Util.commaSeparated . map (const "?") . toPersistFields) records + mkCondFieldSet n _ = T.concat + [ n + , "=COALESCE(" + , "NULLIF(" + , "VALUES(", n, ")," + , "?" + , ")," + , n + , ")" + ] + condFieldSets = map (uncurry mkCondFieldSet) fieldsToMaybeCopy + fieldSets = map (\n -> T.concat [n, "=VALUES(", n, ")"]) updateFieldNames + upds = map (Util.mkUpdateText' (pack . escapeFS) id) updates + updsValues = map (\(Update _ val _) -> toPersistValue val) updates + wher = if null filts then "" else filterClause False conn filts + updateText = case fieldSets <> upds <> condFieldSets of + [] -> T.concat [firstField, "=", firstField] + xs -> Util.commaSeparated xs + q = T.concat + [ "INSERT INTO " + , nameOfTable + , " (" + , Util.commaSeparated entityFieldNames + , ") " + , " VALUES " + , recordPlaceholders + , " ON CONFLICT DO UPDATE SET " + , updateText + , " WHERE " + , wher + ] + +filterClause :: (PersistEntity val, PersistEntityBackend val ~ SqlBackend) + => Bool -- ^ include table name? + -> SqlBackend + -> [Filter val] + -> Text +filterClause b c = fst . filterClauseHelper b True c OrNullNo + +filterClauseHelper :: (PersistEntity val, PersistEntityBackend val ~ SqlBackend) + => Bool -- ^ include table name? + -> Bool -- ^ include WHERE? + -> SqlBackend + -> OrNull + -> [Filter val] + -> (Text, [PersistValue]) +filterClauseHelper includeTable includeWhere conn orNull filters = + (if not (T.null sql) && includeWhere + then " WHERE " <> sql + else sql, vals) + where + (sql, vals) = combineAND filters + combineAND = combine " AND " + + combine s fs = + (T.intercalate s $ map wrapP a, mconcat b) + where + (a, b) = unzip $ map go fs + wrapP x = T.concat ["(", x, ")"] + + go (BackendFilter _) = error "BackendFilter not expected" + go (FilterAnd []) = ("1=1", []) + go (FilterAnd fs) = combineAND fs + go (FilterOr []) = ("1=0", []) + go (FilterOr fs) = combine " OR " fs + go (Filter field value pfilter) = + let t = entityDef $ dummyFromFilts [Filter field value pfilter] + in case (isIdField field, entityPrimary t, allVals) of + (True, Just pdef, PersistList ys:_) -> + if length (compositeFields pdef) /= length ys + then error $ "wrong number of entries in compositeFields vs PersistList allVals=" ++ show allVals + else + case (allVals, pfilter, isCompFilter pfilter) of + ([PersistList xs], Eq, _) -> + let sqlcl=T.intercalate " and " (map (\a -> connEscapeFieldName conn (fieldDB a) <> showSqlFilter pfilter <> "? ") (compositeFields pdef)) + in (wrapSql sqlcl,xs) + ([PersistList xs], Ne, _) -> + let sqlcl=T.intercalate " or " (map (\a -> connEscapeFieldName conn (fieldDB a) <> showSqlFilter pfilter <> "? ") (compositeFields pdef)) + in (wrapSql sqlcl,xs) + (_, In, _) -> + let xxs = transpose (map fromPersistList allVals) + sqls=map (\(a,xs) -> connEscapeFieldName conn (fieldDB a) <> showSqlFilter pfilter <> "(" <> T.intercalate "," (replicate (length xs) " ?") <> ") ") (zip (compositeFields pdef) xxs) + in (wrapSql (T.intercalate " and " (map wrapSql sqls)), concat xxs) + (_, NotIn, _) -> + let xxs = transpose (map fromPersistList allVals) + sqls=map (\(a,xs) -> connEscapeFieldName conn (fieldDB a) <> showSqlFilter pfilter <> "(" <> T.intercalate "," (replicate (length xs) " ?") <> ") ") (zip (compositeFields pdef) xxs) + in (wrapSql (T.intercalate " or " (map wrapSql sqls)), concat xxs) + ([PersistList xs], _, True) -> + let zs = tail (inits (compositeFields pdef)) + sql1 = map (\b -> wrapSql (T.intercalate " and " (map (\(i,a) -> sql2 (i==length b) a) (zip [1..] b)))) zs + sql2 islast a = connEscapeFieldName conn (fieldDB a) <> (if islast then showSqlFilter pfilter else showSqlFilter Eq) <> "? " + sqlcl = T.intercalate " or " sql1 + in (wrapSql sqlcl, concat (tail (inits xs))) + (_, BackendSpecificFilter _, _) -> error "unhandled type BackendSpecificFilter for composite/non id primary keys" + _ -> error $ "unhandled type/filter for composite/non id primary keys pfilter=" ++ show pfilter ++ " persistList="++show allVals + (True, Just pdef, []) -> + error $ "empty list given as filter value filter=" ++ show pfilter ++ " persistList=" ++ show allVals ++ " pdef=" ++ show pdef + (True, Just pdef, _) -> + error $ "unhandled error for composite/non id primary keys filter=" ++ show pfilter ++ " persistList=" ++ show allVals ++ " pdef=" ++ show pdef + + _ -> case (isNull, pfilter, length notNullVals) of + (True, Eq, _) -> (name <> " IS NULL", []) + (True, Ne, _) -> (name <> " IS NOT NULL", []) + (False, Ne, _) -> (T.concat + [ "(" + , name + , " IS NULL OR " + , name + , " <> " + , qmarks + , ")" + ], notNullVals) + -- We use 1=2 (and below 1=1) to avoid using TRUE and FALSE, since + -- not all databases support those words directly. + (_, In, 0) -> ("1=2" <> orNullSuffix, []) + (False, In, _) -> (name <> " IN " <> qmarks <> orNullSuffix, allVals) + (True, In, _) -> (T.concat + [ "(" + , name + , " IS NULL OR " + , name + , " IN " + , qmarks + , ")" + ], notNullVals) + (False, NotIn, 0) -> ("1=1", []) + (True, NotIn, 0) -> (name <> " IS NOT NULL", []) + (False, NotIn, _) -> (T.concat + [ "(" + , name + , " IS NULL OR " + , name + , " NOT IN " + , qmarks + , ")" + ], notNullVals) + (True, NotIn, _) -> (T.concat + [ "(" + , name + , " IS NOT NULL AND " + , name + , " NOT IN " + , qmarks + , ")" + ], notNullVals) + _ -> (name <> showSqlFilter pfilter <> "?" <> orNullSuffix, allVals) + + where + isCompFilter Lt = True + isCompFilter Le = True + isCompFilter Gt = True + isCompFilter Ge = True + isCompFilter _ = False + + wrapSql sqlcl = "(" <> sqlcl <> ")" + fromPersistList (PersistList xs) = xs + fromPersistList other = error $ "expected PersistList but found " ++ show other + + filterValueToPersistValues :: forall a. PersistField a => FilterValue a -> [PersistValue] + filterValueToPersistValues = \case + FilterValue a -> [toPersistValue a] + FilterValues as -> toPersistValue <$> as + UnsafeValue x -> [toPersistValue x] + + orNullSuffix = + case orNull of + OrNullYes -> mconcat [" OR ", name, " IS NULL"] + OrNullNo -> "" + + isNull = PersistNull `elem` allVals + notNullVals = filter (/= PersistNull) allVals + allVals = filterValueToPersistValues value + tn = connEscapeTableName conn $ entityDef $ dummyFromFilts [Filter field value pfilter] + name = + (if includeTable + then ((tn <> ".") <>) + else id) + $ connEscapeFieldName conn (fieldName' field) + qmarks = case value of + FilterValue{} -> "(?)" + UnsafeValue{} -> "(?)" + FilterValues xs -> + let parens a = "(" <> a <> ")" + commas = T.intercalate "," + toQs = fmap $ const "?" + nonNulls = filter (/= PersistNull) $ map toPersistValue xs + in parens . commas . toQs $ nonNulls + showSqlFilter Eq = "=" + showSqlFilter Ne = "<>" + showSqlFilter Gt = ">" + showSqlFilter Lt = "<" + showSqlFilter Ge = ">=" + showSqlFilter Le = "<=" + showSqlFilter In = " IN " + showSqlFilter NotIn = " NOT IN " + showSqlFilter (BackendSpecificFilter s) = s + +data OrNull = OrNullYes | OrNullNo + +dummyFromFilts :: [Filter v] -> Maybe v +dummyFromFilts _ = Nothing + + + putManySql' :: [Text] -> [FieldDef] -> EntityDef -> Int -> Text putManySql' conflictColumns (filter isFieldNotGenerated -> fields) ent n = q where diff --git a/persistent-postgresql/Database/Persist/query.sql b/persistent-postgresql/Database/Persist/query.sql new file mode 100644 index 000000000..5156424dc --- /dev/null +++ b/persistent-postgresql/Database/Persist/query.sql @@ -0,0 +1,8 @@ +INSERT INTO ( + currencycloud_balances +) VALUES ( + externalAccountID, + externalAmount +) ON CONFLICT DO UPDATE SET ( + amount = externalAmount +) WHERE amount != externalAmount diff --git a/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs b/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs index 3dc784292..a5b547cea 100644 --- a/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs +++ b/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs @@ -7,6 +7,7 @@ module Database.Persist.Sql.Orphan.PersistQuery ( deleteWhereCount , updateWhereCount , decorateSQLWithLimitOffset + , filterClauseHelper ) where import Control.Exception (throwIO) From f61f33f80a471d5e5c95f936f9ce12877f45f43e Mon Sep 17 00:00:00 2001 From: Dylan Martin Date: Wed, 31 Mar 2021 11:30:17 -0700 Subject: [PATCH 02/41] whoops don't commit that --- persistent-postgresql/Database/Persist/query.sql | 8 -------- 1 file changed, 8 deletions(-) delete mode 100644 persistent-postgresql/Database/Persist/query.sql diff --git a/persistent-postgresql/Database/Persist/query.sql b/persistent-postgresql/Database/Persist/query.sql deleted file mode 100644 index 5156424dc..000000000 --- a/persistent-postgresql/Database/Persist/query.sql +++ /dev/null @@ -1,8 +0,0 @@ -INSERT INTO ( - currencycloud_balances -) VALUES ( - externalAccountID, - externalAmount -) ON CONFLICT DO UPDATE SET ( - amount = externalAmount -) WHERE amount != externalAmount From 767ed39ba87fc2e0405e2f1d74c9d2cfe3af2c6a Mon Sep 17 00:00:00 2001 From: Dylan Martin Date: Wed, 31 Mar 2021 11:30:43 -0700 Subject: [PATCH 03/41] don't export this --- persistent/Database/Persist/Sql/Orphan/PersistQuery.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs b/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs index a5b547cea..3dc784292 100644 --- a/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs +++ b/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs @@ -7,7 +7,6 @@ module Database.Persist.Sql.Orphan.PersistQuery ( deleteWhereCount , updateWhereCount , decorateSQLWithLimitOffset - , filterClauseHelper ) where import Control.Exception (throwIO) From e49750edd07d814a00e7a8d8da2286b2a018e611 Mon Sep 17 00:00:00 2001 From: Dylan Martin Date: Wed, 31 Mar 2021 11:42:19 -0700 Subject: [PATCH 04/41] updating docs and changelog --- persistent-postgresql/ChangeLog.md | 4 ++ .../Database/Persist/Postgresql.hs | 43 +++++++++++++------ 2 files changed, 35 insertions(+), 12 deletions(-) diff --git a/persistent-postgresql/ChangeLog.md b/persistent-postgresql/ChangeLog.md index 6350581ef..2266adf14 100644 --- a/persistent-postgresql/ChangeLog.md +++ b/persistent-postgresql/ChangeLog.md @@ -1,5 +1,9 @@ # Changelog for persistent-postgresql +## 2.12.0.1 + +* Added `upsertWhere` and `upsertManyWhere` to `persistent-postgresql`. [#1222](https://github.com/yesodweb/persistent/pull/1222). + ## 2.12.0.0 * Decomposed `HaskellName` into `ConstraintNameHS`, `EntityNameHS`, `FieldNameHS`. Decomposed `DBName` into `ConstraintNameDB`, `EntityNameDB`, `FieldNameDB` respectively. [#1174](https://github.com/yesodweb/persistent/pull/1174) diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index f4046950f..dac475179 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -28,6 +28,7 @@ module Database.Persist.Postgresql , PostgresConf (..) , PgInterval (..) , upsertWhere + , upsertManyWhere , openSimpleConn , openSimpleConnWithVersion , tableName @@ -71,7 +72,7 @@ import qualified Data.ByteString.Char8 as B8 import Data.Char (ord) import Data.Conduit import qualified Data.Conduit.List as CL -import Data.Data +import Data.Data ( Data, Typeable ) import Data.Either (partitionEithers) import Data.Fixed (Fixed(..), Pico) import Data.Function (on) @@ -1760,21 +1761,29 @@ repsertManySql ent n = putManySql' conflictColumns fields ent n fields = keyAndEntityFields ent conflictColumns = escapeF . fieldDB <$> entityKeyFields ent --- | This type is used to determine how to update rows using MySQL's --- @INSERT ... ON DUPLICATE KEY UPDATE@ functionality, exposed via --- 'insertManyOnDuplicateKeyUpdate' in this library. +-- | This type is used to determine how to update rows using Postgres' +-- @INSERT ... ON CONFLICT KEY UPDATE@ functionality, exposed via +-- 'upsertWhere' and 'upsertManyWhere' in this library. -- --- @since 2.8.0 +-- @since 2.12.0.1 data HandleUpdateCollision record where -- | Copy the field directly from the record. CopyField :: EntityField record typ -> HandleUpdateCollision record -- | Only copy the field if it is not equal to the provided value. CopyUnlessEq :: PersistField typ => EntityField record typ -> typ -> HandleUpdateCollision record --- | Postgres specific 'upsertWhere'. This will prevent multiple queries, when one will --- do. The record will be inserted into the database. In the event that the --- record already exists in the database, the record will have the --- relevant updates performed. +-- | Postgres specific 'upsertWhere'. This method does the following: +-- It will insert a record if no matching unique key exists. +-- If a unique key exists, it will update the relevant field with a user-supplied value, however, +-- it will only do this update on a user-supplied condition. +-- For example, here's how this method could be called like such: +-- +-- upsertWhere record [recordField =. newValue] [recordField /= newValue] +-- +-- Called thusly, this method will insert a new record (if none exists) OR update a recordField with a new value +-- assuming the condition in the last block is met. +-- +-- @since 2.12.0.1 upsertWhere :: ( backend ~ PersistEntityBackend record , PersistEntity record @@ -1791,6 +1800,18 @@ upsertWhere upsertWhere record conn updates filts = upsertManyWhere [record] conn [] updates filts +-- | Postgres specific 'upsertManyWhere'. This method does the following: +-- It will insert a record if no matching unique key exists. +-- If a unique key exists, it will update the relevant field with a user-supplied value, however, +-- it will only do this update on a user-supplied condition. +-- For example, here's how this method could be called like such: +-- +-- upsertManyWhere record [recordField =. newValue] [recordField /= newValue] +-- +-- Called thusly, this method will insert a new record (if none exists) OR update a recordField with a new value +-- assuming the condition in the last block is met. +-- +-- -- @since 2.12.0.1 upsertManyWhere :: forall record backend m. ( backend ~ PersistEntityBackend record, @@ -1813,7 +1834,7 @@ upsertManyWhere records conn fieldValues updates conditions = uncurry rawExecute $ mkBulkUpsertQuery records conn fieldValues updates conditions --- | This creates the query for 'bulkInsertOnDuplicateKeyUpdate'. If you +-- | This creates the query for 'upsertManyWhere'. If you -- provide an empty list of updates to perform, then it will generate -- a dummy/no-op update using the first field of the record. This avoids -- duplicate key exceptions. @@ -2044,8 +2065,6 @@ data OrNull = OrNullYes | OrNullNo dummyFromFilts :: [Filter v] -> Maybe v dummyFromFilts _ = Nothing - - putManySql' :: [Text] -> [FieldDef] -> EntityDef -> Int -> Text putManySql' conflictColumns (filter isFieldNotGenerated -> fields) ent n = q where From 95d4b0c79a240b616883ed24d862fa8ef3ecbac5 Mon Sep 17 00:00:00 2001 From: Dylan Martin Date: Wed, 31 Mar 2021 14:43:31 -0700 Subject: [PATCH 05/41] remove redundant code --- .../Database/Persist/Postgresql.hs | 26 ++++--------------- 1 file changed, 5 insertions(+), 21 deletions(-) diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index dac475179..743993370 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -88,7 +88,7 @@ import Data.Maybe import Data.Monoid ((<>)) import Data.Pool (Pool) import Data.String.Conversions.Monomorphic (toStrictByteString) -import Data.Text (Text, pack) +import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T @@ -1493,23 +1493,15 @@ tableName = escapeE . tableDBName fieldName :: (PersistEntity record) => EntityField record typ -> Text fieldName = escapeF . fieldDBName -fieldName' :: forall record typ. (PersistEntity record, PersistEntityBackend record ~ SqlBackend) => EntityField record typ -> FieldNameDB -fieldName' f = fieldDB $ persistFieldDef f - escapeC :: ConstraintNameDB -> Text escapeC = escapeWith escape escapeE :: EntityNameDB -> Text escapeE = escapeWith escape -escapeES :: EntityNameDB -> String -escapeES = escapeWith (escapeDBName . T.unpack) - escapeF :: FieldNameDB -> Text escapeF = escapeWith escape -escapeFS :: FieldNameDB -> String -escapeFS = escapeWith (escapeDBName . T.unpack) escape :: Text -> Text escape s = @@ -1519,14 +1511,6 @@ escape s = go ('"':xs) = "\"\"" ++ go xs go (x:xs) = x : go xs --- | Escape a database name to be included on a query. -escapeDBName :: String -> String -escapeDBName str = '`' : go str - where - go ('`':xs) = '`' : '`' : go xs - go ( x :xs) = x : go xs - go "" = "`" - -- | Information required to connect to a PostgreSQL database -- using @persistent@'s generic facilities. These values are the -- same that are given to 'withPostgresqlPool'. @@ -1853,13 +1837,13 @@ mkBulkUpsertQuery records conn fieldValues updates filts = CopyField rec -> Right (fieldDbToText (persistFieldDef rec)) CopyUnlessEq rec val -> Left (fieldDbToText (persistFieldDef rec), toPersistValue val) (fieldsToMaybeCopy, updateFieldNames) = partitionEithers $ map mfieldDef fieldValues - fieldDbToText = T.pack . escapeFS . fieldDB + fieldDbToText = escapeF . fieldDB entityDef' = entityDef records firstField = case entityFieldNames of [] -> error "The entity you're trying to insert does not have any fields." (field:_) -> field entityFieldNames = map fieldDbToText (entityFields entityDef') - nameOfTable = T.pack . escapeES . entityDB $ entityDef' + nameOfTable = escapeE . entityDB $ entityDef' copyUnlessValues = map snd fieldsToMaybeCopy recordValues = concatMap (map toPersistValue . toPersistFields) records recordPlaceholders = Util.commaSeparated $ map (Util.parenWrapped . Util.commaSeparated . map (const "?") . toPersistFields) records @@ -1875,7 +1859,7 @@ mkBulkUpsertQuery records conn fieldValues updates filts = ] condFieldSets = map (uncurry mkCondFieldSet) fieldsToMaybeCopy fieldSets = map (\n -> T.concat [n, "=VALUES(", n, ")"]) updateFieldNames - upds = map (Util.mkUpdateText' (pack . escapeFS) id) updates + upds = map (Util.mkUpdateText' (escapeF) id) updates updsValues = map (\(Update _ val _) -> toPersistValue val) updates wher = if null filts then "" else filterClause False conn filts updateText = case fieldSets <> upds <> condFieldSets of @@ -2040,7 +2024,7 @@ filterClauseHelper includeTable includeWhere conn orNull filters = (if includeTable then ((tn <> ".") <>) else id) - $ connEscapeFieldName conn (fieldName' field) + $ (fieldName field) qmarks = case value of FilterValue{} -> "(?)" UnsafeValue{} -> "(?)" From 8db67bb6ebca96c7ceeab9586f351ff8b30392e1 Mon Sep 17 00:00:00 2001 From: Dylan Martin Date: Wed, 31 Mar 2021 14:59:05 -0700 Subject: [PATCH 06/41] omg hls led me astray --- .../Database/Persist/Postgresql.hs | 175 +----------------- persistent/Database/Persist/Sql.hs | 2 + .../Persist/Sql/Orphan/PersistQuery.hs | 2 + 3 files changed, 6 insertions(+), 173 deletions(-) diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index 743993370..d7a7c619c 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -79,7 +79,7 @@ import Data.Function (on) import Data.Int (Int64) import qualified Data.IntMap as I import Data.IORef -import Data.List (find, sort, groupBy, foldl', transpose, inits) +import Data.List (find, sort, groupBy, foldl') import Data.List.NonEmpty (NonEmpty) import qualified Data.List as List import qualified Data.List.NonEmpty as NEL @@ -97,7 +97,6 @@ import Data.Time (utc, NominalDiffTime, localTimeToUTC) import System.Environment (getEnvironment) import Database.Persist.Sql -import Database.Persist.Sql.Util (isIdField) import qualified Database.Persist.Sql.Util as Util -- | A @libpq@ connection string. A simple example of connection @@ -1790,7 +1789,7 @@ upsertWhere record conn updates filts = -- it will only do this update on a user-supplied condition. -- For example, here's how this method could be called like such: -- --- upsertManyWhere record [recordField =. newValue] [recordField /= newValue] +-- upsertManyWhere [record] [recordField =. newValue] [recordField /= newValue] -- -- Called thusly, this method will insert a new record (if none exists) OR update a recordField with a new value -- assuming the condition in the last block is met. @@ -1879,176 +1878,6 @@ mkBulkUpsertQuery records conn fieldValues updates filts = , wher ] -filterClause :: (PersistEntity val, PersistEntityBackend val ~ SqlBackend) - => Bool -- ^ include table name? - -> SqlBackend - -> [Filter val] - -> Text -filterClause b c = fst . filterClauseHelper b True c OrNullNo - -filterClauseHelper :: (PersistEntity val, PersistEntityBackend val ~ SqlBackend) - => Bool -- ^ include table name? - -> Bool -- ^ include WHERE? - -> SqlBackend - -> OrNull - -> [Filter val] - -> (Text, [PersistValue]) -filterClauseHelper includeTable includeWhere conn orNull filters = - (if not (T.null sql) && includeWhere - then " WHERE " <> sql - else sql, vals) - where - (sql, vals) = combineAND filters - combineAND = combine " AND " - - combine s fs = - (T.intercalate s $ map wrapP a, mconcat b) - where - (a, b) = unzip $ map go fs - wrapP x = T.concat ["(", x, ")"] - - go (BackendFilter _) = error "BackendFilter not expected" - go (FilterAnd []) = ("1=1", []) - go (FilterAnd fs) = combineAND fs - go (FilterOr []) = ("1=0", []) - go (FilterOr fs) = combine " OR " fs - go (Filter field value pfilter) = - let t = entityDef $ dummyFromFilts [Filter field value pfilter] - in case (isIdField field, entityPrimary t, allVals) of - (True, Just pdef, PersistList ys:_) -> - if length (compositeFields pdef) /= length ys - then error $ "wrong number of entries in compositeFields vs PersistList allVals=" ++ show allVals - else - case (allVals, pfilter, isCompFilter pfilter) of - ([PersistList xs], Eq, _) -> - let sqlcl=T.intercalate " and " (map (\a -> connEscapeFieldName conn (fieldDB a) <> showSqlFilter pfilter <> "? ") (compositeFields pdef)) - in (wrapSql sqlcl,xs) - ([PersistList xs], Ne, _) -> - let sqlcl=T.intercalate " or " (map (\a -> connEscapeFieldName conn (fieldDB a) <> showSqlFilter pfilter <> "? ") (compositeFields pdef)) - in (wrapSql sqlcl,xs) - (_, In, _) -> - let xxs = transpose (map fromPersistList allVals) - sqls=map (\(a,xs) -> connEscapeFieldName conn (fieldDB a) <> showSqlFilter pfilter <> "(" <> T.intercalate "," (replicate (length xs) " ?") <> ") ") (zip (compositeFields pdef) xxs) - in (wrapSql (T.intercalate " and " (map wrapSql sqls)), concat xxs) - (_, NotIn, _) -> - let xxs = transpose (map fromPersistList allVals) - sqls=map (\(a,xs) -> connEscapeFieldName conn (fieldDB a) <> showSqlFilter pfilter <> "(" <> T.intercalate "," (replicate (length xs) " ?") <> ") ") (zip (compositeFields pdef) xxs) - in (wrapSql (T.intercalate " or " (map wrapSql sqls)), concat xxs) - ([PersistList xs], _, True) -> - let zs = tail (inits (compositeFields pdef)) - sql1 = map (\b -> wrapSql (T.intercalate " and " (map (\(i,a) -> sql2 (i==length b) a) (zip [1..] b)))) zs - sql2 islast a = connEscapeFieldName conn (fieldDB a) <> (if islast then showSqlFilter pfilter else showSqlFilter Eq) <> "? " - sqlcl = T.intercalate " or " sql1 - in (wrapSql sqlcl, concat (tail (inits xs))) - (_, BackendSpecificFilter _, _) -> error "unhandled type BackendSpecificFilter for composite/non id primary keys" - _ -> error $ "unhandled type/filter for composite/non id primary keys pfilter=" ++ show pfilter ++ " persistList="++show allVals - (True, Just pdef, []) -> - error $ "empty list given as filter value filter=" ++ show pfilter ++ " persistList=" ++ show allVals ++ " pdef=" ++ show pdef - (True, Just pdef, _) -> - error $ "unhandled error for composite/non id primary keys filter=" ++ show pfilter ++ " persistList=" ++ show allVals ++ " pdef=" ++ show pdef - - _ -> case (isNull, pfilter, length notNullVals) of - (True, Eq, _) -> (name <> " IS NULL", []) - (True, Ne, _) -> (name <> " IS NOT NULL", []) - (False, Ne, _) -> (T.concat - [ "(" - , name - , " IS NULL OR " - , name - , " <> " - , qmarks - , ")" - ], notNullVals) - -- We use 1=2 (and below 1=1) to avoid using TRUE and FALSE, since - -- not all databases support those words directly. - (_, In, 0) -> ("1=2" <> orNullSuffix, []) - (False, In, _) -> (name <> " IN " <> qmarks <> orNullSuffix, allVals) - (True, In, _) -> (T.concat - [ "(" - , name - , " IS NULL OR " - , name - , " IN " - , qmarks - , ")" - ], notNullVals) - (False, NotIn, 0) -> ("1=1", []) - (True, NotIn, 0) -> (name <> " IS NOT NULL", []) - (False, NotIn, _) -> (T.concat - [ "(" - , name - , " IS NULL OR " - , name - , " NOT IN " - , qmarks - , ")" - ], notNullVals) - (True, NotIn, _) -> (T.concat - [ "(" - , name - , " IS NOT NULL AND " - , name - , " NOT IN " - , qmarks - , ")" - ], notNullVals) - _ -> (name <> showSqlFilter pfilter <> "?" <> orNullSuffix, allVals) - - where - isCompFilter Lt = True - isCompFilter Le = True - isCompFilter Gt = True - isCompFilter Ge = True - isCompFilter _ = False - - wrapSql sqlcl = "(" <> sqlcl <> ")" - fromPersistList (PersistList xs) = xs - fromPersistList other = error $ "expected PersistList but found " ++ show other - - filterValueToPersistValues :: forall a. PersistField a => FilterValue a -> [PersistValue] - filterValueToPersistValues = \case - FilterValue a -> [toPersistValue a] - FilterValues as -> toPersistValue <$> as - UnsafeValue x -> [toPersistValue x] - - orNullSuffix = - case orNull of - OrNullYes -> mconcat [" OR ", name, " IS NULL"] - OrNullNo -> "" - - isNull = PersistNull `elem` allVals - notNullVals = filter (/= PersistNull) allVals - allVals = filterValueToPersistValues value - tn = connEscapeTableName conn $ entityDef $ dummyFromFilts [Filter field value pfilter] - name = - (if includeTable - then ((tn <> ".") <>) - else id) - $ (fieldName field) - qmarks = case value of - FilterValue{} -> "(?)" - UnsafeValue{} -> "(?)" - FilterValues xs -> - let parens a = "(" <> a <> ")" - commas = T.intercalate "," - toQs = fmap $ const "?" - nonNulls = filter (/= PersistNull) $ map toPersistValue xs - in parens . commas . toQs $ nonNulls - showSqlFilter Eq = "=" - showSqlFilter Ne = "<>" - showSqlFilter Gt = ">" - showSqlFilter Lt = "<" - showSqlFilter Ge = ">=" - showSqlFilter Le = "<=" - showSqlFilter In = " IN " - showSqlFilter NotIn = " NOT IN " - showSqlFilter (BackendSpecificFilter s) = s - -data OrNull = OrNullYes | OrNullNo - -dummyFromFilts :: [Filter v] -> Maybe v -dummyFromFilts _ = Nothing - putManySql' :: [Text] -> [FieldDef] -> EntityDef -> Int -> Text putManySql' conflictColumns (filter isFieldNotGenerated -> fields) ent n = q where diff --git a/persistent/Database/Persist/Sql.hs b/persistent/Database/Persist/Sql.hs index a0e802507..2422e2397 100644 --- a/persistent/Database/Persist/Sql.hs +++ b/persistent/Database/Persist/Sql.hs @@ -12,6 +12,8 @@ module Database.Persist.Sql , rawSql , deleteWhereCount , updateWhereCount + , filterClause + , filterClauseHelper , transactionSave , transactionSaveWithIsolation , transactionUndo diff --git a/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs b/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs index 3dc784292..89a4ee952 100644 --- a/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs +++ b/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs @@ -6,6 +6,8 @@ module Database.Persist.Sql.Orphan.PersistQuery ( deleteWhereCount , updateWhereCount + , filterClause + , filterClauseHelper , decorateSQLWithLimitOffset ) where From 85a442d6426e18b20b19e78fb78808c6a8d0ebde Mon Sep 17 00:00:00 2001 From: Dylan Martin Date: Wed, 31 Mar 2021 20:41:33 -0700 Subject: [PATCH 07/41] refactoring the connection, updating the changelog, and running stylish :) --- persistent-postgresql/ChangeLog.md | 2 +- .../Database/Persist/Postgresql.hs | 15 +++++++-------- 2 files changed, 8 insertions(+), 9 deletions(-) diff --git a/persistent-postgresql/ChangeLog.md b/persistent-postgresql/ChangeLog.md index 2266adf14..7fce26302 100644 --- a/persistent-postgresql/ChangeLog.md +++ b/persistent-postgresql/ChangeLog.md @@ -1,6 +1,6 @@ # Changelog for persistent-postgresql -## 2.12.0.1 +## 2.12.1.0 * Added `upsertWhere` and `upsertManyWhere` to `persistent-postgresql`. [#1222](https://github.com/yesodweb/persistent/pull/1222). diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index d7a7c619c..6d9683cdb 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -56,7 +56,7 @@ import Control.Monad import Control.Monad.Except import Control.Monad.IO.Unlift (MonadIO (..), MonadUnliftIO) import Control.Monad.Logger (MonadLoggerIO, runNoLoggingT) -import Control.Monad.Trans.Reader (ReaderT(..), runReaderT) +import Control.Monad.Trans.Reader (ReaderT(..), runReaderT, asks) import Control.Monad.Trans.Writer (WriterT(..), runWriterT) import qualified Blaze.ByteString.Builder.Char8 as BBB @@ -1776,12 +1776,11 @@ upsertWhere , BackendCompatible SqlBackend backend ) => record - -> SqlBackend -> [Update record] -> [Filter record] -> ReaderT backend m () -upsertWhere record conn updates filts = - upsertManyWhere [record] conn [] updates filts +upsertWhere record updates filts = + upsertManyWhere [record] [] updates filts -- | Postgres specific 'upsertManyWhere'. This method does the following: -- It will insert a record if no matching unique key exists. @@ -1805,15 +1804,15 @@ upsertManyWhere :: ) => -- | A list of the records you want to insert, or update [record] -> - SqlBackend -> -- | A list of the fields you want to copy over. [HandleUpdateCollision record] -> -- | A list of the updates to apply that aren't dependent on the record being inserted. [Update record] -> [Filter record] -> ReaderT backend m () -upsertManyWhere [] _ _ _ _ = return () -upsertManyWhere records conn fieldValues updates conditions = +upsertManyWhere [] _ _ _ = return () +upsertManyWhere records fieldValues updates conditions = do + conn <- asks projectBackend uncurry rawExecute $ mkBulkUpsertQuery records conn fieldValues updates conditions @@ -1829,7 +1828,7 @@ mkBulkUpsertQuery -> [Update record] -- ^ A list of the updates to apply that aren't dependent on the record being inserted. -> [Filter record] -> (Text, [PersistValue]) -mkBulkUpsertQuery records conn fieldValues updates filts = +mkBulkUpsertQuery records conn fieldValues updates filts = (q, recordValues <> updsValues <> copyUnlessValues) where mfieldDef x = case x of From 36c2446ee0d7041b32eb8def08e17186d5cf151e Mon Sep 17 00:00:00 2001 From: Dylan Martin Date: Thu, 1 Apr 2021 10:01:20 -0700 Subject: [PATCH 08/41] continue on errors --- .github/workflows/haskell.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index df9e14926..1c4279496 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -23,6 +23,7 @@ jobs: --health-interval 10s --health-timeout 5s --health-retries 5 + --continue-on-error # mysql-service Label used to access the service container mysql-service: # Docker Hub image (also with version) From c7630a54208593556cac8a1ae6d707683b24ee85 Mon Sep 17 00:00:00 2001 From: Dylan Martin Date: Thu, 1 Apr 2021 10:07:31 -0700 Subject: [PATCH 09/41] put it in the wrong place i don't actually know yaml --- .github/workflows/haskell.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 1c4279496..f5c8d672e 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -23,7 +23,6 @@ jobs: --health-interval 10s --health-timeout 5s --health-retries 5 - --continue-on-error # mysql-service Label used to access the service container mysql-service: # Docker Hub image (also with version) @@ -57,6 +56,7 @@ jobs: env: CONFIG: "--enable-tests" steps: + - continue-on-error: true - uses: actions/checkout@v2 - uses: actions/setup-haskell@v1.1.4 id: setup-haskell-cabal From 7d6af72ade15dd500763531953ce6d4040818406 Mon Sep 17 00:00:00 2001 From: Dylan Martin Date: Thu, 1 Apr 2021 10:42:38 -0700 Subject: [PATCH 10/41] jeez maybe this works --- .github/workflows/haskell.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index f5c8d672e..c68a14f19 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -56,10 +56,10 @@ jobs: env: CONFIG: "--enable-tests" steps: - - continue-on-error: true - uses: actions/checkout@v2 - uses: actions/setup-haskell@v1.1.4 id: setup-haskell-cabal + continue-on-error: true with: ghc-version: ${{ matrix.ghc }} cabal-version: ${{ matrix.cabal }} From 27d9edb777140e383f953259568d802225b76474 Mon Sep 17 00:00:00 2001 From: Dylan Martin Date: Thu, 1 Apr 2021 10:46:19 -0700 Subject: [PATCH 11/41] maybe it should go here instead --- .github/workflows/haskell.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index c68a14f19..af8b007f5 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -59,7 +59,6 @@ jobs: - uses: actions/checkout@v2 - uses: actions/setup-haskell@v1.1.4 id: setup-haskell-cabal - continue-on-error: true with: ghc-version: ${{ matrix.ghc }} cabal-version: ${{ matrix.cabal }} @@ -83,4 +82,5 @@ jobs: - run: cabal v2-build all --disable-optimization $CONFIG - run: cabal v2-test all --disable-optimization $CONFIG - run: cabal v2-haddock all $CONFIG + continue-on-error: true - run: cabal v2-sdist all From a7ed10f11ce61a1a9fa3a2e4c359d5f412f66cc2 Mon Sep 17 00:00:00 2001 From: Dylan Martin Date: Thu, 1 Apr 2021 13:31:33 -0700 Subject: [PATCH 12/41] test this on CI --- .../Database/Persist/Postgresql.hs | 1 + persistent-postgresql/test/UpsertWhere.hs | 97 +++++++++++++++++++ 2 files changed, 98 insertions(+) create mode 100644 persistent-postgresql/test/UpsertWhere.hs diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index 6d9683cdb..d44b52d0f 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -25,6 +25,7 @@ module Database.Persist.Postgresql , createPostgresqlPoolWithConf , module Database.Persist.Sql , ConnectionString + , HandleUpdateCollision , PostgresConf (..) , PgInterval (..) , upsertWhere diff --git a/persistent-postgresql/test/UpsertWhere.hs b/persistent-postgresql/test/UpsertWhere.hs new file mode 100644 index 000000000..bb4d86ca0 --- /dev/null +++ b/persistent-postgresql/test/UpsertWhere.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE DataKinds, FlexibleInstances, MultiParamTypeClasses, ExistentialQuantification #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE StandaloneDeriving #-} + +module UpsertWhere where + +import Data.List (sort) + +import Database.Persist.Postgresql +import PgInit + +share [mkPersist sqlSettings, mkMigrate "upsertMigrate"] [persistLowerCase| + Item + name Text sqltype=varchar(80) + description Text + price Double Maybe + quantity Int Maybe + + Primary name + deriving Eq Show Ord + +|] + +specs :: Spec +specs = describe "UpsertWhere" $ do + let item1 = Item "item1" "" (Just 3) Nothing + item2 = Item "item2" "hello world" Nothing (Just 2) + items = [item1, item2] + describe "upsertWhere" $ do + it "inserts appropriately" $ runConnAssert $ do + deleteWhere ([] :: [Filter Item]) + upsertWhere item1 [ItemDescription =. "i am item 1"] [] + Just item <- get (ItemKey "item1") + item @== item1 + + it "performs only updates given if record already exists" $ runConnAssert $ do + deleteWhere ([] :: [Filter Item]) + let newDescription = "I am a new description" + insert_ item1 + upsertWhere + (Item "item1" "i am inserted description" (Just 1) (Just 2)) + [ItemDescription =. newDescription] + [] + Just item <- get (ItemKey "item1") + item @== item1 { itemDescription = newDescription } + + describe "upsertManyWhere" $ do + it "inserts fresh records" $ runConnAssert $ do + deleteWhere ([] :: [Filter Item]) + insertMany_ items + let newItem = Item "item3" "fresh" Nothing Nothing + upsertManyWhere + (newItem : items) + [copyField ItemDescription] + [] + [] + dbItems <- map entityVal <$> selectList [] [] + sort dbItems @== sort (newItem : items) + it "updates existing records" $ runConnAssert $ do + deleteWhere ([] :: [Filter Item]) + insertMany_ items + upsertManyWhere + items + [] + [ItemQuantity +=. Just 1] + [] + it "only copies passing values" $ runConnAssert $ do + deleteWhere ([] :: [Filter Item]) + insertMany_ items + let newItems = map (\i -> i { itemQuantity = Just 0, itemPrice = fmap (*2) (itemPrice i) }) items + postUpdate = map (\i -> i { itemPrice = fmap (*2) (itemPrice i) }) items + upsertManyWhere + newItems + [ copyUnlessEq ItemQuantity (Just 0) + , copyField ItemPrice + ] + [] + [] + dbItems <- sort . fmap entityVal <$> selectList [] [] + dbItems @== sort postUpdate + it "inserts without modifying existing records if no updates specified" $ runConnAssert $ do + let newItem = Item "item3" "hi friends!" Nothing Nothing + deleteWhere ([] :: [Filter Item]) + insertMany_ items + upsertManyWhere + (newItem : items) + [] + [] + [] + dbItems <- sort . fmap entityVal <$> selectList [] [] + dbItems @== sort (newItem : items) From 12cecffd3e0498d498cd1cf977594a141744c2ad Mon Sep 17 00:00:00 2001 From: Dylan Martin Date: Thu, 1 Apr 2021 14:20:01 -0700 Subject: [PATCH 13/41] testing a different DB --- .../Database/Persist/Postgresql.hs | 54 +++++++++++++++++++ persistent-postgresql/README.md | 2 +- persistent-postgresql/test/PgInit.hs | 4 +- 3 files changed, 57 insertions(+), 3 deletions(-) diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index d44b52d0f..868bba017 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -5,6 +5,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} @@ -26,6 +27,12 @@ module Database.Persist.Postgresql , module Database.Persist.Sql , ConnectionString , HandleUpdateCollision + , pattern SomeField + , SomeField + , copyField + , copyUnlessNull + , copyUnlessEmpty + , copyUnlessEq , PostgresConf (..) , PgInterval (..) , upsertWhere @@ -87,6 +94,7 @@ import qualified Data.List.NonEmpty as NEL import qualified Data.Map as Map import Data.Maybe import Data.Monoid ((<>)) +import qualified Data.Monoid as Monoid import Data.Pool (Pool) import Data.String.Conversions.Monomorphic (toStrictByteString) import Data.Text (Text) @@ -1756,6 +1764,52 @@ data HandleUpdateCollision record where -- | Only copy the field if it is not equal to the provided value. CopyUnlessEq :: PersistField typ => EntityField record typ -> typ -> HandleUpdateCollision record +-- | An alias for 'HandleUpdateCollision'. The type previously was only +-- used to copy a single value, but was expanded to be handle more complex +-- queries. +-- +-- @since 2.6.2 +type SomeField = HandleUpdateCollision + +pattern SomeField :: EntityField record typ -> SomeField record +pattern SomeField x = CopyField x +{-# DEPRECATED SomeField "The type SomeField is deprecated. Use the type HandleUpdateCollision instead, and use the function copyField instead of the data constructor." #-} + +-- | Copy the field into the database only if the value in the +-- corresponding record is non-@NULL@. +-- +-- @since 2.6.2 +copyUnlessNull :: PersistField typ => EntityField record (Maybe typ) -> HandleUpdateCollision record +copyUnlessNull field = CopyUnlessEq field Nothing + +-- | Copy the field into the database only if the value in the +-- corresponding record is non-empty, where "empty" means the Monoid +-- definition for 'mempty'. Useful for 'Text', 'String', 'ByteString', etc. +-- +-- The resulting 'HandleUpdateCollision' type is useful for the +-- 'insertManyOnDuplicateKeyUpdate' function. +-- +-- @since 2.6.2 +copyUnlessEmpty :: (Monoid.Monoid typ, PersistField typ) => EntityField record typ -> HandleUpdateCollision record +copyUnlessEmpty field = CopyUnlessEq field Monoid.mempty + +-- | Copy the field into the database only if the field is not equal to the +-- provided value. This is useful to avoid copying weird nullary data into +-- the database. +-- +-- The resulting 'HandleUpdateCollision' type is useful for the +-- 'insertManyOnDuplicateKeyUpdate' function. +-- +-- @since 2.6.2 +copyUnlessEq :: PersistField typ => EntityField record typ -> typ -> HandleUpdateCollision record +copyUnlessEq = CopyUnlessEq + +-- | Copy the field directly from the record. +-- +-- @since 3.0 +copyField :: PersistField typ => EntityField record typ -> HandleUpdateCollision record +copyField = CopyField + -- | Postgres specific 'upsertWhere'. This method does the following: -- It will insert a record if no matching unique key exists. -- If a unique key exists, it will update the relevant field with a user-supplied value, however, diff --git a/persistent-postgresql/README.md b/persistent-postgresql/README.md index 7318e21ea..219bb184a 100644 --- a/persistent-postgresql/README.md +++ b/persistent-postgresql/README.md @@ -21,5 +21,5 @@ $ createdb test The tests do not pass a test and expect to connect with the `postgres` user. Ensure that peer authentication is allowed for this. -An easy/insecure way to do this is to set the `METHOD` to `trust` for all the login methods in `/etc/postgresql/XX/main/pg_hba.coinf`. +An easy/insecure way to do this is to set the `METHOD` to `trust` for all the login methods in `/etc/postgresql/XX/main/pg_hba.conf`. (TODO: make this better?) diff --git a/persistent-postgresql/test/PgInit.hs b/persistent-postgresql/test/PgInit.hs index d2fcb85dd..cfe71f6a0 100644 --- a/persistent-postgresql/test/PgInit.hs +++ b/persistent-postgresql/test/PgInit.hs @@ -56,7 +56,7 @@ import Test.HUnit ((@?=),(@=?), Assertion, assertFailure, assertBool) import Test.QuickCheck import Control.Monad (unless, (>=>)) -import Control.Monad.IO.Class + import Control.Monad.IO.Unlift (MonadUnliftIO) import Control.Monad.Logger import Control.Monad.Trans.Resource (ResourceT, runResourceT) @@ -110,7 +110,7 @@ runConnInternal connType f = do pure "host=localhost port=5432 user=perstest password=perstest dbname=persistent" else do host <- fromMaybe "localhost" <$> liftIO dockerPg - pure ("host=" <> host <> " port=5432 user=postgres dbname=test") + pure ("host=" <> host <> " port=5432 user=postgres dbname=test-dylan") flip runLoggingT (\_ _ _ s -> printDebug s) $ do logInfoN (if travis then "Running in CI" else "CI not detected") From 1d5af1598dd896378180ad67fab88e9bdfb86d92 Mon Sep 17 00:00:00 2001 From: Dylan Martin Date: Sun, 4 Apr 2021 17:37:18 -0700 Subject: [PATCH 14/41] preparing for the PR --- .../Database/Persist/Postgresql.hs | 58 ++++++++----------- persistent-postgresql/test/PgInit.hs | 2 +- persistent-postgresql/test/UpsertWhere.hs | 16 ++++- persistent-postgresql/test/main.hs | 3 + persistent/Database/Persist/Sql/Raw.hs | 7 ++- persistent/Database/Persist/Sql/Util.hs | 14 +++++ 6 files changed, 64 insertions(+), 36 deletions(-) diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index 868bba017..d61275b2a 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -96,13 +96,14 @@ import Data.Maybe import Data.Monoid ((<>)) import qualified Data.Monoid as Monoid import Data.Pool (Pool) -import Data.String.Conversions.Monomorphic (toStrictByteString) +import Data.String.Conversions.Monomorphic (toStrictByteString, toString) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T import Data.Text.Read (rational) import Data.Time (utc, NominalDiffTime, localTimeToUTC) +import Debug.Trace import System.Environment (getEnvironment) import Database.Persist.Sql @@ -146,7 +147,7 @@ withPostgresqlPool ci = withPostgresqlPoolWithVersion getServerVersion ci -- | Same as 'withPostgresPool', but takes a callback for obtaining -- the server version (to work around an Amazon Redshift bug). -- --- @since 2.6.2 +-- @since 2.12.1 withPostgresqlPoolWithVersion :: (MonadUnliftIO m, MonadLoggerIO m) => (PG.Connection -> IO (Maybe Double)) -- ^ Action to perform to get the server version. @@ -212,7 +213,7 @@ createPostgresqlPoolModified = createPostgresqlPoolModifiedWithVersion getServer -- the server version (to work around an Amazon Redshift bug) and connection-specific tweaking -- (to change the schema). -- --- @since 2.6.2 +-- @since 2.12.1 createPostgresqlPoolModifiedWithVersion :: (MonadUnliftIO m, MonadLoggerIO m) => (PG.Connection -> IO (Maybe Double)) -- ^ Action to perform to get the server version. @@ -256,7 +257,7 @@ withPostgresqlConn = withPostgresqlConnWithVersion getServerVersion -- | Same as 'withPostgresqlConn', but takes a callback for obtaining -- the server version (to work around an Amazon Redshift bug). -- --- @since 2.6.2 +-- @since 2.12.1 withPostgresqlConnWithVersion :: (MonadUnliftIO m, MonadLoggerIO m) => (PG.Connection -> IO (Maybe Double)) -> ConnectionString @@ -1757,7 +1758,7 @@ repsertManySql ent n = putManySql' conflictColumns fields ent n -- @INSERT ... ON CONFLICT KEY UPDATE@ functionality, exposed via -- 'upsertWhere' and 'upsertManyWhere' in this library. -- --- @since 2.12.0.1 +-- @since 2.12.1 data HandleUpdateCollision record where -- | Copy the field directly from the record. CopyField :: EntityField record typ -> HandleUpdateCollision record @@ -1768,7 +1769,7 @@ data HandleUpdateCollision record where -- used to copy a single value, but was expanded to be handle more complex -- queries. -- --- @since 2.6.2 +-- @since 2.12.1 type SomeField = HandleUpdateCollision pattern SomeField :: EntityField record typ -> SomeField record @@ -1778,7 +1779,7 @@ pattern SomeField x = CopyField x -- | Copy the field into the database only if the value in the -- corresponding record is non-@NULL@. -- --- @since 2.6.2 +-- @since 2.12.1 copyUnlessNull :: PersistField typ => EntityField record (Maybe typ) -> HandleUpdateCollision record copyUnlessNull field = CopyUnlessEq field Nothing @@ -1789,7 +1790,7 @@ copyUnlessNull field = CopyUnlessEq field Nothing -- The resulting 'HandleUpdateCollision' type is useful for the -- 'insertManyOnDuplicateKeyUpdate' function. -- --- @since 2.6.2 +-- @since 2.12.1 copyUnlessEmpty :: (Monoid.Monoid typ, PersistField typ) => EntityField record typ -> HandleUpdateCollision record copyUnlessEmpty field = CopyUnlessEq field Monoid.mempty @@ -1806,7 +1807,7 @@ copyUnlessEq = CopyUnlessEq -- | Copy the field directly from the record. -- --- @since 3.0 +-- @since 2.6.2 copyField :: PersistField typ => EntityField record typ -> HandleUpdateCollision record copyField = CopyField @@ -1821,7 +1822,7 @@ copyField = CopyField -- Called thusly, this method will insert a new record (if none exists) OR update a recordField with a new value -- assuming the condition in the last block is met. -- --- @since 2.12.0.1 +-- @since 2.12.1 upsertWhere :: ( backend ~ PersistEntityBackend record , PersistEntity record @@ -1863,13 +1864,14 @@ upsertManyWhere :: [HandleUpdateCollision record] -> -- | A list of the updates to apply that aren't dependent on the record being inserted. [Update record] -> + -- a filter condition [Filter record] -> ReaderT backend m () upsertManyWhere [] _ _ _ = return () -upsertManyWhere records fieldValues updates conditions = do +upsertManyWhere records fieldValues updates filters = do conn <- asks projectBackend uncurry rawExecute $ - mkBulkUpsertQuery records conn fieldValues updates conditions + mkBulkUpsertQuery records conn fieldValues updates filters -- | This creates the query for 'upsertManyWhere'. If you -- provide an empty list of updates to perform, then it will generate @@ -1883,8 +1885,8 @@ mkBulkUpsertQuery -> [Update record] -- ^ A list of the updates to apply that aren't dependent on the record being inserted. -> [Filter record] -> (Text, [PersistValue]) -mkBulkUpsertQuery records conn fieldValues updates filts = - (q, recordValues <> updsValues <> copyUnlessValues) +mkBulkUpsertQuery records conn fieldValues updates filters = + (q, recordValues <> updsValues <> copyUnlessValues) where mfieldDef x = case x of CopyField rec -> Right (fieldDbToText (persistFieldDef rec)) @@ -1900,35 +1902,25 @@ mkBulkUpsertQuery records conn fieldValues updates filts = copyUnlessValues = map snd fieldsToMaybeCopy recordValues = concatMap (map toPersistValue . toPersistFields) records recordPlaceholders = Util.commaSeparated $ map (Util.parenWrapped . Util.commaSeparated . map (const "?") . toPersistFields) records - mkCondFieldSet n _ = T.concat - [ n - , "=COALESCE(" - , "NULLIF(" - , "VALUES(", n, ")," - , "?" - , ")," - , n - , ")" - ] + mkCondFieldSet n _ = T.concat [n, "=EXCLUDED.", n] condFieldSets = map (uncurry mkCondFieldSet) fieldsToMaybeCopy - fieldSets = map (\n -> T.concat [n, "=VALUES(", n, ")"]) updateFieldNames - upds = map (Util.mkUpdateText' (escapeF) id) updates + fieldSets = map (\n -> T.concat [n, "=EXCLUDED.", n, ""]) updateFieldNames + upds = map (Util.mkPostgresUpdateText (escapeF) id) updates updsValues = map (\(Update _ val _) -> toPersistValue val) updates - wher = if null filts then "" else filterClause False conn filts + wher = if null filters then "" else filterClause False conn filters updateText = case fieldSets <> upds <> condFieldSets of - [] -> T.concat [firstField, "=", firstField] + [] -> T.concat [firstField, "=EXCLUDED.", firstField] xs -> Util.commaSeparated xs q = T.concat [ "INSERT INTO " , nameOfTable - , " (" - , Util.commaSeparated entityFieldNames - , ") " + , Util.parenWrapped . Util.commaSeparated $ entityFieldNames , " VALUES " , recordPlaceholders - , " ON CONFLICT DO UPDATE SET " + , " ON CONFLICT " + , Util.parenWrapped $ firstField + , " DO UPDATE SET " , updateText - , " WHERE " , wher ] diff --git a/persistent-postgresql/test/PgInit.hs b/persistent-postgresql/test/PgInit.hs index cfe71f6a0..8c9906ce3 100644 --- a/persistent-postgresql/test/PgInit.hs +++ b/persistent-postgresql/test/PgInit.hs @@ -110,7 +110,7 @@ runConnInternal connType f = do pure "host=localhost port=5432 user=perstest password=perstest dbname=persistent" else do host <- fromMaybe "localhost" <$> liftIO dockerPg - pure ("host=" <> host <> " port=5432 user=postgres dbname=test-dylan") + pure ("host=" <> host <> " port=5432 user=postgres dbname=test") flip runLoggingT (\_ _ _ s -> printDebug s) $ do logInfoN (if travis then "Running in CI" else "CI not detected") diff --git a/persistent-postgresql/test/UpsertWhere.hs b/persistent-postgresql/test/UpsertWhere.hs index bb4d86ca0..a33e27cd3 100644 --- a/persistent-postgresql/test/UpsertWhere.hs +++ b/persistent-postgresql/test/UpsertWhere.hs @@ -15,7 +15,7 @@ import Data.List (sort) import Database.Persist.Postgresql import PgInit -share [mkPersist sqlSettings, mkMigrate "upsertMigrate"] [persistLowerCase| +share [mkPersist sqlSettings, mkMigrate "upsertWhereMigrate"] [persistLowerCase| Item name Text sqltype=varchar(80) description Text @@ -70,6 +70,7 @@ specs = describe "UpsertWhere" $ do [] [ItemQuantity +=. Just 1] [] + -- TODO: this test doesn't pass it "only copies passing values" $ runConnAssert $ do deleteWhere ([] :: [Filter Item]) insertMany_ items @@ -95,3 +96,16 @@ specs = describe "UpsertWhere" $ do [] dbItems <- sort . fmap entityVal <$> selectList [] [] dbItems @== sort (newItem : items) + -- TODO: this test doesn't pass + it "inserts without modifying existing records if no updates specified and there's a filter" $ + runConnAssert $ do + let newItem = Item "item3" "hi friends!" Nothing Nothing + deleteWhere ([] :: [Filter Item]) + insertMany_ items + upsertManyWhere + (newItem : items) + [] + [] + [ItemDescription ==. "hi friends!"] + dbItems <- sort . fmap entityVal <$> selectList [] [] + dbItems @== sort (newItem : items) diff --git a/persistent-postgresql/test/main.hs b/persistent-postgresql/test/main.hs index 6c0c47ee6..60543a349 100644 --- a/persistent-postgresql/test/main.hs +++ b/persistent-postgresql/test/main.hs @@ -51,6 +51,7 @@ import qualified TransactionLevelTest import qualified TreeTest import qualified UniqueTest import qualified UpsertTest +import qualified UpsertWhere import qualified CustomConstraintTest import qualified LongIdentifierTest import qualified PgIntervalTest @@ -128,6 +129,7 @@ main = do , ForeignKey.compositeMigrate , MigrationTest.migrationMigrate , PgIntervalTest.pgIntervalMigrate + , UpsertWhere.upsertWhereMigrate ] PersistentTest.cleanDB ForeignKey.cleanDB @@ -195,6 +197,7 @@ main = do LongIdentifierTest.specsWith runConnAssertUseConf -- Have at least one test use the conf variant of connecting to Postgres, to improve test coverage. JSONTest.specs CustomConstraintTest.specs + UpsertWhere.specs PgIntervalTest.specs ArrayAggTest.specs GeneratedColumnTestSQL.specsWith runConnAssert diff --git a/persistent/Database/Persist/Sql/Raw.hs b/persistent/Database/Persist/Sql/Raw.hs index b3bd2b72e..6cd8c6109 100644 --- a/persistent/Database/Persist/Sql/Raw.hs +++ b/persistent/Database/Persist/Sql/Raw.hs @@ -48,7 +48,10 @@ rawExecute :: (MonadIO m, BackendCompatible SqlBackend backend) => Text -- ^ SQL statement, possibly with placeholders. -> [PersistValue] -- ^ Values to fill the placeholders. -> ReaderT backend m () -rawExecute x y = liftM (const ()) $ rawExecuteCount x y +rawExecute x y = do + -- TODO: remove this altogether when done debugging + -- liftIO $ putStrLn $ T.unpack x + liftM (const ()) $ rawExecuteCount x y -- | Execute a raw SQL statement and return the number of -- rows it has modified. @@ -60,6 +63,8 @@ rawExecuteCount sql vals = do conn <- projectBackend `liftM` ask runLoggingT (logDebugNS (pack "SQL") $ T.append sql $ pack $ "; " ++ show vals) (connLogFunc conn) + -- TODO: remove this altogether when done debugging + -- liftIO $ putStrLn $ T.unpack sql stmt <- getStmt sql res <- liftIO $ stmtExecute stmt vals liftIO $ stmtReset stmt diff --git a/persistent/Database/Persist/Sql/Util.hs b/persistent/Database/Persist/Sql/Util.hs index 980cc6e08..94678deea 100644 --- a/persistent/Database/Persist/Sql/Util.hs +++ b/persistent/Database/Persist/Sql/Util.hs @@ -14,6 +14,7 @@ module Database.Persist.Sql.Util , updatePersistValue , mkUpdateText , mkUpdateText' + , mkPostgresUpdateText , commaSeparated , parenWrapped , mkInsertValues @@ -220,6 +221,19 @@ mkUpdateText' escapeName refColumn x = where n = escapeName . fieldDB . updateFieldDef $ x +mkPostgresUpdateText :: PersistEntity record => (FieldNameDB -> Text) -> (Text -> Text) -> Update record -> Text +mkPostgresUpdateText escapeName refColumn x = + case updateUpdate x of + Assign -> n <> "=?" + Add -> T.concat [n, "=EXCLUDED.", refColumn n, "+?"] + Subtract -> T.concat [n, "=EXCLUDED.", refColumn n, "-?"] + Multiply -> T.concat [n, "=EXCLUDED.", refColumn n, "*?"] + Divide -> T.concat [n, "=EXCLUDED.", refColumn n, "/?"] + BackendSpecificUpdate up -> + error . T.unpack $ "mkUpdateText: BackendSpecificUpdate " <> up <> " not supported" + where + n = escapeName . fieldDB . updateFieldDef $ x + parenWrapped :: Text -> Text parenWrapped t = T.concat ["(", t, ")"] From eed0a8a3a5fc293da54ae4787092d8d55d7eab3c Mon Sep 17 00:00:00 2001 From: Dylan Martin Date: Sun, 4 Apr 2021 17:45:40 -0700 Subject: [PATCH 15/41] yikes idk what i updated these haddocks incorrectly --- persistent-postgresql/Database/Persist/Postgresql.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index d61275b2a..4b2525ffc 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -147,7 +147,7 @@ withPostgresqlPool ci = withPostgresqlPoolWithVersion getServerVersion ci -- | Same as 'withPostgresPool', but takes a callback for obtaining -- the server version (to work around an Amazon Redshift bug). -- --- @since 2.12.1 +-- @since 2.6.2 withPostgresqlPoolWithVersion :: (MonadUnliftIO m, MonadLoggerIO m) => (PG.Connection -> IO (Maybe Double)) -- ^ Action to perform to get the server version. @@ -213,7 +213,7 @@ createPostgresqlPoolModified = createPostgresqlPoolModifiedWithVersion getServer -- the server version (to work around an Amazon Redshift bug) and connection-specific tweaking -- (to change the schema). -- --- @since 2.12.1 +-- @since 2.6.2 createPostgresqlPoolModifiedWithVersion :: (MonadUnliftIO m, MonadLoggerIO m) => (PG.Connection -> IO (Maybe Double)) -- ^ Action to perform to get the server version. @@ -257,7 +257,7 @@ withPostgresqlConn = withPostgresqlConnWithVersion getServerVersion -- | Same as 'withPostgresqlConn', but takes a callback for obtaining -- the server version (to work around an Amazon Redshift bug). -- --- @since 2.12.1 +-- @since 2.6.2 withPostgresqlConnWithVersion :: (MonadUnliftIO m, MonadLoggerIO m) => (PG.Connection -> IO (Maybe Double)) -> ConnectionString From f9c9015c29063d4a4e50652924b05da8cf4c2a9f Mon Sep 17 00:00:00 2001 From: Dylan Martin Date: Mon, 5 Apr 2021 09:33:49 -0700 Subject: [PATCH 16/41] Update persistent-postgresql/Database/Persist/Postgresql.hs Co-authored-by: Matt Parsons --- persistent-postgresql/Database/Persist/Postgresql.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index 4b2525ffc..79441990a 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -1799,7 +1799,7 @@ copyUnlessEmpty field = CopyUnlessEq field Monoid.mempty -- the database. -- -- The resulting 'HandleUpdateCollision' type is useful for the --- 'insertManyOnDuplicateKeyUpdate' function. +-- 'upsertMany' function. -- -- @since 2.6.2 copyUnlessEq :: PersistField typ => EntityField record typ -> typ -> HandleUpdateCollision record From 495b6098af0da73a07675981a45de4e187210728 Mon Sep 17 00:00:00 2001 From: Dylan Martin Date: Mon, 5 Apr 2021 11:15:48 -0700 Subject: [PATCH 17/41] moving a postgres-specific util to its own module, other code review ffedback --- .../Database/Persist/Postgresql.hs | 17 ++--------- .../Database/Persist/Postgresql/Util.hs | 30 +++++++++++++++++++ persistent/Database/Persist/Sql/Raw.hs | 6 ++-- persistent/Database/Persist/Sql/Util.hs | 14 --------- 4 files changed, 36 insertions(+), 31 deletions(-) create mode 100644 persistent-postgresql/Database/Persist/Postgresql/Util.hs diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index 79441990a..ae23af1b7 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -5,7 +5,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} @@ -27,8 +26,6 @@ module Database.Persist.Postgresql , module Database.Persist.Sql , ConnectionString , HandleUpdateCollision - , pattern SomeField - , SomeField , copyField , copyUnlessNull , copyUnlessEmpty @@ -96,7 +93,7 @@ import Data.Maybe import Data.Monoid ((<>)) import qualified Data.Monoid as Monoid import Data.Pool (Pool) -import Data.String.Conversions.Monomorphic (toStrictByteString, toString) +import Data.String.Conversions.Monomorphic (toStrictByteString) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -108,6 +105,7 @@ import System.Environment (getEnvironment) import Database.Persist.Sql import qualified Database.Persist.Sql.Util as Util +import Database.Persist.Postgresql.Util as Util -- | A @libpq@ connection string. A simple example of connection -- string would be @\"host=localhost port=5432 user=test @@ -1765,17 +1763,6 @@ data HandleUpdateCollision record where -- | Only copy the field if it is not equal to the provided value. CopyUnlessEq :: PersistField typ => EntityField record typ -> typ -> HandleUpdateCollision record --- | An alias for 'HandleUpdateCollision'. The type previously was only --- used to copy a single value, but was expanded to be handle more complex --- queries. --- --- @since 2.12.1 -type SomeField = HandleUpdateCollision - -pattern SomeField :: EntityField record typ -> SomeField record -pattern SomeField x = CopyField x -{-# DEPRECATED SomeField "The type SomeField is deprecated. Use the type HandleUpdateCollision instead, and use the function copyField instead of the data constructor." #-} - -- | Copy the field into the database only if the value in the -- corresponding record is non-@NULL@. -- diff --git a/persistent-postgresql/Database/Persist/Postgresql/Util.hs b/persistent-postgresql/Database/Persist/Postgresql/Util.hs new file mode 100644 index 000000000..5eb0d4549 --- /dev/null +++ b/persistent-postgresql/Database/Persist/Postgresql/Util.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Database.Persist.Postgresql.Util ( + mkPostgresUpdateText +) where + +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T + +import Database.Persist (FieldNameDB, PersistEntity (..), PersistUpdate(..), Update(..), updateUpdate, fieldDB, FieldDef) + + +mkPostgresUpdateText :: PersistEntity record => (FieldNameDB -> Text) -> (Text -> Text) -> Update record -> Text +mkPostgresUpdateText escapeName refColumn x = + case updateUpdate x of + Assign -> n <> "=?" + Add -> T.concat [n, "=EXCLUDED.", refColumn n, "+?"] + Subtract -> T.concat [n, "=EXCLUDED.", refColumn n, "-?"] + Multiply -> T.concat [n, "=EXCLUDED.", refColumn n, "*?"] + Divide -> T.concat [n, "=EXCLUDED.", refColumn n, "/?"] + BackendSpecificUpdate up -> + error . T.unpack $ "mkUpdateText: BackendSpecificUpdate " <> up <> " not supported" + where + n = escapeName . fieldDB . updateFieldDef $ x + +-- | Gets the 'FieldDef' for an 'Update'. +updateFieldDef :: PersistEntity v => Update v -> FieldDef +updateFieldDef (Update f _ _) = persistFieldDef f +updateFieldDef BackendUpdate {} = error "updateFieldDef: did not expect BackendUpdate" \ No newline at end of file diff --git a/persistent/Database/Persist/Sql/Raw.hs b/persistent/Database/Persist/Sql/Raw.hs index 6cd8c6109..516a8ea35 100644 --- a/persistent/Database/Persist/Sql/Raw.hs +++ b/persistent/Database/Persist/Sql/Raw.hs @@ -17,6 +17,7 @@ import qualified Data.Text as T import Database.Persist import Database.Persist.Sql.Types import Database.Persist.Sql.Class +import Debug.Trace rawQuery :: (MonadResource m, MonadReader env m, BackendCompatible SqlBackend env) => Text @@ -50,7 +51,8 @@ rawExecute :: (MonadIO m, BackendCompatible SqlBackend backend) -> ReaderT backend m () rawExecute x y = do -- TODO: remove this altogether when done debugging - -- liftIO $ putStrLn $ T.unpack x + liftIO $ putStrLn $ T.unpack x + liftIO $ putStrLn $ show y liftM (const ()) $ rawExecuteCount x y -- | Execute a raw SQL statement and return the number of @@ -64,7 +66,7 @@ rawExecuteCount sql vals = do runLoggingT (logDebugNS (pack "SQL") $ T.append sql $ pack $ "; " ++ show vals) (connLogFunc conn) -- TODO: remove this altogether when done debugging - -- liftIO $ putStrLn $ T.unpack sql + liftIO $ putStrLn $ T.unpack sql stmt <- getStmt sql res <- liftIO $ stmtExecute stmt vals liftIO $ stmtReset stmt diff --git a/persistent/Database/Persist/Sql/Util.hs b/persistent/Database/Persist/Sql/Util.hs index 94678deea..980cc6e08 100644 --- a/persistent/Database/Persist/Sql/Util.hs +++ b/persistent/Database/Persist/Sql/Util.hs @@ -14,7 +14,6 @@ module Database.Persist.Sql.Util , updatePersistValue , mkUpdateText , mkUpdateText' - , mkPostgresUpdateText , commaSeparated , parenWrapped , mkInsertValues @@ -221,19 +220,6 @@ mkUpdateText' escapeName refColumn x = where n = escapeName . fieldDB . updateFieldDef $ x -mkPostgresUpdateText :: PersistEntity record => (FieldNameDB -> Text) -> (Text -> Text) -> Update record -> Text -mkPostgresUpdateText escapeName refColumn x = - case updateUpdate x of - Assign -> n <> "=?" - Add -> T.concat [n, "=EXCLUDED.", refColumn n, "+?"] - Subtract -> T.concat [n, "=EXCLUDED.", refColumn n, "-?"] - Multiply -> T.concat [n, "=EXCLUDED.", refColumn n, "*?"] - Divide -> T.concat [n, "=EXCLUDED.", refColumn n, "/?"] - BackendSpecificUpdate up -> - error . T.unpack $ "mkUpdateText: BackendSpecificUpdate " <> up <> " not supported" - where - n = escapeName . fieldDB . updateFieldDef $ x - parenWrapped :: Text -> Text parenWrapped t = T.concat ["(", t, ")"] From 81cf7b0f3d28e6f96cf822e3210351a85500e0e5 Mon Sep 17 00:00:00 2001 From: Dylan Martin Date: Mon, 5 Apr 2021 13:56:25 -0700 Subject: [PATCH 18/41] one last test is failing but I'd love external input on why --- .../Database/Persist/Postgresql.hs | 20 +++++++++++++---- .../persistent-postgresql.cabal | 2 ++ persistent-postgresql/test/UpsertWhere.hs | 1 - persistent/Database/Persist/Sql.hs | 1 + .../Persist/Sql/Orphan/PersistQuery.hs | 22 +++++++++++++++---- persistent/Database/Persist/Sql/Raw.hs | 2 +- 6 files changed, 38 insertions(+), 10 deletions(-) diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index ae23af1b7..b8c66882f 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -100,7 +100,6 @@ import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T import Data.Text.Read (rational) import Data.Time (utc, NominalDiffTime, localTimeToUTC) -import Debug.Trace import System.Environment (getEnvironment) import Database.Persist.Sql @@ -1873,7 +1872,7 @@ mkBulkUpsertQuery -> [Filter record] -> (Text, [PersistValue]) mkBulkUpsertQuery records conn fieldValues updates filters = - (q, recordValues <> updsValues <> copyUnlessValues) + (q, recordValues <> updsValues <> copyUnlessValues <> whereVals) where mfieldDef x = case x of CopyField rec -> Right (fieldDbToText (persistFieldDef rec)) @@ -1889,12 +1888,25 @@ mkBulkUpsertQuery records conn fieldValues updates filters = copyUnlessValues = map snd fieldsToMaybeCopy recordValues = concatMap (map toPersistValue . toPersistFields) records recordPlaceholders = Util.commaSeparated $ map (Util.parenWrapped . Util.commaSeparated . map (const "?") . toPersistFields) records - mkCondFieldSet n _ = T.concat [n, "=EXCLUDED.", n] + mkCondFieldSet n _ = + T.concat + [ n + ,"=COALESCE(" + ,"NULLIF(" + ,"EXCLUDED." + ,n + ,"," + ,"?" + ,")" + ,")" + ] condFieldSets = map (uncurry mkCondFieldSet) fieldsToMaybeCopy fieldSets = map (\n -> T.concat [n, "=EXCLUDED.", n, ""]) updateFieldNames upds = map (Util.mkPostgresUpdateText (escapeF) id) updates updsValues = map (\(Update _ val _) -> toPersistValue val) updates - wher = if null filters then "" else filterClause False conn filters + (wher, whereVals) = if null filters + then ("", []) + else (filterClauseWithVals False conn filters) updateText = case fieldSets <> upds <> condFieldSets of [] -> T.concat [firstField, "=EXCLUDED.", firstField] xs -> Util.commaSeparated xs diff --git a/persistent-postgresql/persistent-postgresql.cabal b/persistent-postgresql/persistent-postgresql.cabal index c7ea5e3f4..46df1702d 100644 --- a/persistent-postgresql/persistent-postgresql.cabal +++ b/persistent-postgresql/persistent-postgresql.cabal @@ -36,6 +36,7 @@ library , unliftio-core exposed-modules: Database.Persist.Postgresql , Database.Persist.Postgresql.JSON + other-modules: Database.Persist.Postgresql.Util ghc-options: -Wall default-language: Haskell2010 @@ -53,6 +54,7 @@ test-suite test JSONTest CustomConstraintTest PgIntervalTest + UpsertWhere ghc-options: -Wall build-depends: base >= 4.9 && < 5 diff --git a/persistent-postgresql/test/UpsertWhere.hs b/persistent-postgresql/test/UpsertWhere.hs index a33e27cd3..1be907c70 100644 --- a/persistent-postgresql/test/UpsertWhere.hs +++ b/persistent-postgresql/test/UpsertWhere.hs @@ -96,7 +96,6 @@ specs = describe "UpsertWhere" $ do [] dbItems <- sort . fmap entityVal <$> selectList [] [] dbItems @== sort (newItem : items) - -- TODO: this test doesn't pass it "inserts without modifying existing records if no updates specified and there's a filter" $ runConnAssert $ do let newItem = Item "item3" "hi friends!" Nothing Nothing diff --git a/persistent/Database/Persist/Sql.hs b/persistent/Database/Persist/Sql.hs index 2422e2397..e423c3245 100644 --- a/persistent/Database/Persist/Sql.hs +++ b/persistent/Database/Persist/Sql.hs @@ -14,6 +14,7 @@ module Database.Persist.Sql , updateWhereCount , filterClause , filterClauseHelper + , filterClauseWithVals , transactionSave , transactionSaveWithIsolation , transactionUndo diff --git a/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs b/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs index 89a4ee952..deb142bed 100644 --- a/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs +++ b/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs @@ -8,6 +8,7 @@ module Database.Persist.Sql.Orphan.PersistQuery , updateWhereCount , filterClause , filterClauseHelper + , filterClauseWithVals , decorateSQLWithLimitOffset ) where @@ -227,18 +228,19 @@ dummyFromFilts _ = Nothing getFiltsValues :: forall val. (PersistEntity val, PersistEntityBackend val ~ SqlBackend) => SqlBackend -> [Filter val] -> [PersistValue] -getFiltsValues conn = snd . filterClauseHelper False False conn OrNullNo +getFiltsValues conn = snd . filterClauseHelper False False False conn OrNullNo data OrNull = OrNullYes | OrNullNo filterClauseHelper :: (PersistEntity val, PersistEntityBackend val ~ SqlBackend) => Bool -- ^ include table name? -> Bool -- ^ include WHERE? + -> Bool -- ^ use postgresl EXCLUDE -> SqlBackend -> OrNull -> [Filter val] -> (Text, [PersistValue]) -filterClauseHelper includeTable includeWhere conn orNull filters = +filterClauseHelper includeTable includeWhere includeExcluded conn orNull filters = (if not (T.null sql) && includeWhere then " WHERE " <> sql else sql, vals) @@ -337,7 +339,12 @@ filterClauseHelper includeTable includeWhere conn orNull filters = , qmarks , ")" ], notNullVals) - _ -> (name <> showSqlFilter pfilter <> "?" <> orNullSuffix, allVals) + _ -> (T.concat + [ + if includeExcluded then "EXCLUDED." else "" + , name + <> showSqlFilter pfilter <> "?" <> orNullSuffix + ], allVals) where isCompFilter Lt = True @@ -394,7 +401,14 @@ filterClause :: (PersistEntity val, PersistEntityBackend val ~ SqlBackend) -> SqlBackend -> [Filter val] -> Text -filterClause b c = fst . filterClauseHelper b True c OrNullNo +filterClause b c = fst . filterClauseHelper b True False c OrNullNo + +filterClauseWithVals :: (PersistEntity val, PersistEntityBackend val ~ SqlBackend) + => Bool -- ^ include table name? + -> SqlBackend + -> [Filter val] + -> (Text, [PersistValue]) +filterClauseWithVals b c = filterClauseHelper b True True c OrNullNo orderClause :: (PersistEntity val, PersistEntityBackend val ~ SqlBackend) => Bool -- ^ include the table name diff --git a/persistent/Database/Persist/Sql/Raw.hs b/persistent/Database/Persist/Sql/Raw.hs index 516a8ea35..9867b7f53 100644 --- a/persistent/Database/Persist/Sql/Raw.hs +++ b/persistent/Database/Persist/Sql/Raw.hs @@ -66,7 +66,7 @@ rawExecuteCount sql vals = do runLoggingT (logDebugNS (pack "SQL") $ T.append sql $ pack $ "; " ++ show vals) (connLogFunc conn) -- TODO: remove this altogether when done debugging - liftIO $ putStrLn $ T.unpack sql + -- liftIO $ putStrLn $ T.unpack sql stmt <- getStmt sql res <- liftIO $ stmtExecute stmt vals liftIO $ stmtReset stmt From 78f0861f1e90e6741bfd3efa6f093a6140ccfc61 Mon Sep 17 00:00:00 2001 From: Dylan Martin Date: Mon, 5 Apr 2021 14:07:43 -0700 Subject: [PATCH 19/41] last changes --- persistent-postgresql/Database/Persist/Postgresql.hs | 3 ++- persistent/Database/Persist/Sql/Raw.hs | 2 -- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index b8c66882f..ebab7c368 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -1880,6 +1880,7 @@ mkBulkUpsertQuery records conn fieldValues updates filters = (fieldsToMaybeCopy, updateFieldNames) = partitionEithers $ map mfieldDef fieldValues fieldDbToText = escapeF . fieldDB entityDef' = entityDef records + conflictColumns = escapeF . fieldDB <$> entityKeyFields entityDef' firstField = case entityFieldNames of [] -> error "The entity you're trying to insert does not have any fields." (field:_) -> field @@ -1917,7 +1918,7 @@ mkBulkUpsertQuery records conn fieldValues updates filters = , " VALUES " , recordPlaceholders , " ON CONFLICT " - , Util.parenWrapped $ firstField + , Util.parenWrapped $ Util.commaSeparated $ conflictColumns , " DO UPDATE SET " , updateText , wher diff --git a/persistent/Database/Persist/Sql/Raw.hs b/persistent/Database/Persist/Sql/Raw.hs index 9867b7f53..91e593123 100644 --- a/persistent/Database/Persist/Sql/Raw.hs +++ b/persistent/Database/Persist/Sql/Raw.hs @@ -65,8 +65,6 @@ rawExecuteCount sql vals = do conn <- projectBackend `liftM` ask runLoggingT (logDebugNS (pack "SQL") $ T.append sql $ pack $ "; " ++ show vals) (connLogFunc conn) - -- TODO: remove this altogether when done debugging - -- liftIO $ putStrLn $ T.unpack sql stmt <- getStmt sql res <- liftIO $ stmtExecute stmt vals liftIO $ stmtReset stmt From fc45c3d2efb6f642c1d09afb8a6ad8a2c84d32a7 Mon Sep 17 00:00:00 2001 From: Dylan Martin Date: Mon, 5 Apr 2021 16:09:20 -0700 Subject: [PATCH 20/41] Update persistent-postgresql/Database/Persist/Postgresql.hs Co-authored-by: Matt Parsons --- persistent-postgresql/Database/Persist/Postgresql.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index ebab7c368..ada18fe9a 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -1899,6 +1899,8 @@ mkBulkUpsertQuery records conn fieldValues updates filters = ,"," ,"?" ,")" + , ", " + , n ,")" ] condFieldSets = map (uncurry mkCondFieldSet) fieldsToMaybeCopy From 4ad926dc9eea896841f06553dc6cfeba689f2e35 Mon Sep 17 00:00:00 2001 From: Dylan Martin Date: Mon, 5 Apr 2021 16:28:52 -0700 Subject: [PATCH 21/41] hmmmm I'm close i thinkg --- persistent-postgresql/Database/Persist/Postgresql.hs | 2 +- persistent-postgresql/test/UpsertWhere.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index ada18fe9a..9ed665111 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -1899,7 +1899,7 @@ mkBulkUpsertQuery records conn fieldValues updates filters = ,"," ,"?" ,")" - , ", " + , ", EXCLUDED." , n ,")" ] diff --git a/persistent-postgresql/test/UpsertWhere.hs b/persistent-postgresql/test/UpsertWhere.hs index 1be907c70..48bc9b2ae 100644 --- a/persistent-postgresql/test/UpsertWhere.hs +++ b/persistent-postgresql/test/UpsertWhere.hs @@ -74,7 +74,7 @@ specs = describe "UpsertWhere" $ do it "only copies passing values" $ runConnAssert $ do deleteWhere ([] :: [Filter Item]) insertMany_ items - let newItems = map (\i -> i { itemQuantity = Just 0, itemPrice = fmap (*2) (itemPrice i) }) items + let newItems = map (\i -> i { itemQuantity = Nothing, itemPrice = fmap (*2) (itemPrice i) }) items postUpdate = map (\i -> i { itemPrice = fmap (*2) (itemPrice i) }) items upsertManyWhere newItems From 82b56c542ead006ef5e657055a151d399b8d12da Mon Sep 17 00:00:00 2001 From: Dylan Martin Date: Mon, 5 Apr 2021 17:37:56 -0700 Subject: [PATCH 22/41] generalized the postgresql changes to PersistQuery --- persistent-postgresql/test/UpsertWhere.hs | 4 +-- .../Persist/Sql/Orphan/PersistQuery.hs | 32 +++++++++++-------- 2 files changed, 20 insertions(+), 16 deletions(-) diff --git a/persistent-postgresql/test/UpsertWhere.hs b/persistent-postgresql/test/UpsertWhere.hs index 48bc9b2ae..2c1128c92 100644 --- a/persistent-postgresql/test/UpsertWhere.hs +++ b/persistent-postgresql/test/UpsertWhere.hs @@ -78,11 +78,11 @@ specs = describe "UpsertWhere" $ do postUpdate = map (\i -> i { itemPrice = fmap (*2) (itemPrice i) }) items upsertManyWhere newItems - [ copyUnlessEq ItemQuantity (Just 0) + [ copyUnlessEq ItemQuantity (Just 2) , copyField ItemPrice ] [] - [] + [ItemQuantity ==. Nothing] dbItems <- sort . fmap entityVal <$> selectList [] [] dbItems @== sort postUpdate it "inserts without modifying existing records if no updates specified" $ runConnAssert $ do diff --git a/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs b/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs index deb142bed..d1e9d7b84 100644 --- a/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs +++ b/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs @@ -295,11 +295,16 @@ filterClauseHelper includeTable includeWhere includeExcluded conn orNull filters error $ "unhandled error for composite/non id primary keys filter=" ++ show pfilter ++ " persistList=" ++ show allVals ++ " pdef=" ++ show pdef _ -> case (isNull, pfilter, length notNullVals) of - (True, Eq, _) -> (name <> " IS NULL", []) - (True, Ne, _) -> (name <> " IS NOT NULL", []) + (True, Eq, _) -> (T.concat + [ name + , " IS NULL" + ],[]) + (True, Ne, _) -> (T.concat + [ name + , " IS NOT NULL" + ],[]) (False, Ne, _) -> (T.concat - [ "(" - , name + [ name , " IS NULL OR " , name , " <> " @@ -311,8 +316,7 @@ filterClauseHelper includeTable includeWhere includeExcluded conn orNull filters (_, In, 0) -> ("1=2" <> orNullSuffix, []) (False, In, _) -> (name <> " IN " <> qmarks <> orNullSuffix, allVals) (True, In, _) -> (T.concat - [ "(" - , name + [ name , " IS NULL OR " , name , " IN " @@ -322,8 +326,7 @@ filterClauseHelper includeTable includeWhere includeExcluded conn orNull filters (False, NotIn, 0) -> ("1=1", []) (True, NotIn, 0) -> (name <> " IS NOT NULL", []) (False, NotIn, _) -> (T.concat - [ "(" - , name + [ name , " IS NULL OR " , name , " NOT IN " @@ -331,8 +334,7 @@ filterClauseHelper includeTable includeWhere includeExcluded conn orNull filters , ")" ], notNullVals) (True, NotIn, _) -> (T.concat - [ "(" - , name + [ name , " IS NOT NULL AND " , name , " NOT IN " @@ -340,9 +342,7 @@ filterClauseHelper includeTable includeWhere includeExcluded conn orNull filters , ")" ], notNullVals) _ -> (T.concat - [ - if includeExcluded then "EXCLUDED." else "" - , name + [name <> showSqlFilter pfilter <> "?" <> orNullSuffix ], allVals) @@ -365,7 +365,9 @@ filterClauseHelper includeTable includeWhere includeExcluded conn orNull filters orNullSuffix = case orNull of - OrNullYes -> mconcat [" OR ", name, " IS NULL"] + OrNullYes -> mconcat [" OR " + , name + , " IS NULL"] OrNullNo -> "" isNull = PersistNull `elem` allVals @@ -375,6 +377,8 @@ filterClauseHelper includeTable includeWhere includeExcluded conn orNull filters name = (if includeTable then ((tn <> ".") <>) + else if includeExcluded -- need this for PostgreSQL queries + then (("EXCLUDED.") <>) else id) $ connEscapeFieldName conn (fieldName field) qmarks = case value of From b9fdc8cb57f4c6025f19d0b64f2c35e639e31ecc Mon Sep 17 00:00:00 2001 From: Dylan Martin Date: Tue, 6 Apr 2021 12:47:15 -0700 Subject: [PATCH 23/41] finished implementation, added more tests, removed all todos --- .../Database/Persist/Postgresql.hs | 20 ++++++------ persistent-postgresql/test/UpsertWhere.hs | 32 ++++++++++++++++--- .../Persist/Sql/Orphan/PersistQuery.hs | 4 --- persistent/Database/Persist/Sql/Raw.hs | 3 -- 4 files changed, 38 insertions(+), 21 deletions(-) diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index 9ed665111..b9024f99f 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -1892,16 +1892,16 @@ mkBulkUpsertQuery records conn fieldValues updates filters = mkCondFieldSet n _ = T.concat [ n - ,"=COALESCE(" - ,"NULLIF(" - ,"EXCLUDED." - ,n - ,"," - ,"?" - ,")" - , ", EXCLUDED." - , n - ,")" + , "=COALESCE(" + , "NULLIF(" + , "EXCLUDED." + , n + , "," + , "?" + , ")" + , ",ITEM." + , n + ,")" ] condFieldSets = map (uncurry mkCondFieldSet) fieldsToMaybeCopy fieldSets = map (\n -> T.concat [n, "=EXCLUDED.", n, ""]) updateFieldNames diff --git a/persistent-postgresql/test/UpsertWhere.hs b/persistent-postgresql/test/UpsertWhere.hs index 2c1128c92..513975633 100644 --- a/persistent-postgresql/test/UpsertWhere.hs +++ b/persistent-postgresql/test/UpsertWhere.hs @@ -70,19 +70,19 @@ specs = describe "UpsertWhere" $ do [] [ItemQuantity +=. Just 1] [] - -- TODO: this test doesn't pass it "only copies passing values" $ runConnAssert $ do deleteWhere ([] :: [Filter Item]) insertMany_ items - let newItems = map (\i -> i { itemQuantity = Nothing, itemPrice = fmap (*2) (itemPrice i) }) items + let newItems = map (\i -> i { itemQuantity = Just 0, itemPrice = fmap (*2) (itemPrice i) }) items postUpdate = map (\i -> i { itemPrice = fmap (*2) (itemPrice i) }) items upsertManyWhere newItems - [ copyUnlessEq ItemQuantity (Just 2) + [ + copyUnlessEq ItemQuantity (Just 0) , copyField ItemPrice ] [] - [ItemQuantity ==. Nothing] + [] dbItems <- sort . fmap entityVal <$> selectList [] [] dbItems @== sort postUpdate it "inserts without modifying existing records if no updates specified" $ runConnAssert $ do @@ -108,3 +108,27 @@ specs = describe "UpsertWhere" $ do [ItemDescription ==. "hi friends!"] dbItems <- sort . fmap entityVal <$> selectList [] [] dbItems @== sort (newItem : items) + it "inserts without modifying existing records if there are updates specified but there's a filter" $ + runConnAssert $ do + let newItem = Item "item3" "hi friends!" Nothing Nothing + deleteWhere ([] :: [Filter Item]) + insertMany_ items + upsertManyWhere + (newItem : items) + [] + [ItemQuantity +=. Just 1] + [ItemDescription ==. "hi friends!"] + dbItems <- sort . fmap entityVal <$> selectList [] [] + dbItems @== sort (newItem : items) + it "inserts and modifies existing records if there are updates specified and the filter doesn't apply" $ + runConnAssert $ do + let newItem = Item "item3" "hi friends!" Nothing Nothing + deleteWhere ([] :: [Filter Item]) + insertMany_ items + upsertManyWhere + (newItem : items) + [] + [ItemQuantity +=. Just 1] + [ItemDescription ==. "bye friends!"] + dbItems <- sort . fmap entityVal <$> selectList [] [] + dbItems @== sort (newItem : items) diff --git a/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs b/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs index d1e9d7b84..008740394 100644 --- a/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs +++ b/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs @@ -309,7 +309,6 @@ filterClauseHelper includeTable includeWhere includeExcluded conn orNull filters , name , " <> " , qmarks - , ")" ], notNullVals) -- We use 1=2 (and below 1=1) to avoid using TRUE and FALSE, since -- not all databases support those words directly. @@ -321,7 +320,6 @@ filterClauseHelper includeTable includeWhere includeExcluded conn orNull filters , name , " IN " , qmarks - , ")" ], notNullVals) (False, NotIn, 0) -> ("1=1", []) (True, NotIn, 0) -> (name <> " IS NOT NULL", []) @@ -331,7 +329,6 @@ filterClauseHelper includeTable includeWhere includeExcluded conn orNull filters , name , " NOT IN " , qmarks - , ")" ], notNullVals) (True, NotIn, _) -> (T.concat [ name @@ -339,7 +336,6 @@ filterClauseHelper includeTable includeWhere includeExcluded conn orNull filters , name , " NOT IN " , qmarks - , ")" ], notNullVals) _ -> (T.concat [name diff --git a/persistent/Database/Persist/Sql/Raw.hs b/persistent/Database/Persist/Sql/Raw.hs index 91e593123..de0d0860d 100644 --- a/persistent/Database/Persist/Sql/Raw.hs +++ b/persistent/Database/Persist/Sql/Raw.hs @@ -50,9 +50,6 @@ rawExecute :: (MonadIO m, BackendCompatible SqlBackend backend) -> [PersistValue] -- ^ Values to fill the placeholders. -> ReaderT backend m () rawExecute x y = do - -- TODO: remove this altogether when done debugging - liftIO $ putStrLn $ T.unpack x - liftIO $ putStrLn $ show y liftM (const ()) $ rawExecuteCount x y -- | Execute a raw SQL statement and return the number of From f5c40e1c44f900cd0b6d11b56b891d2a90137718 Mon Sep 17 00:00:00 2001 From: Dylan Martin Date: Tue, 6 Apr 2021 12:49:37 -0700 Subject: [PATCH 24/41] haddock update --- persistent-postgresql/Database/Persist/Postgresql.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index b9024f99f..a4feb9e05 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -1774,7 +1774,7 @@ copyUnlessNull field = CopyUnlessEq field Nothing -- definition for 'mempty'. Useful for 'Text', 'String', 'ByteString', etc. -- -- The resulting 'HandleUpdateCollision' type is useful for the --- 'insertManyOnDuplicateKeyUpdate' function. +-- 'upsertManyWhere' function. -- -- @since 2.12.1 copyUnlessEmpty :: (Monoid.Monoid typ, PersistField typ) => EntityField record typ -> HandleUpdateCollision record From 22cdeb63090fb0e027e31e4cb03e3eb3fa8a703b Mon Sep 17 00:00:00 2001 From: Dylan Martin Date: Tue, 6 Apr 2021 12:56:29 -0700 Subject: [PATCH 25/41] finishing the rest of the haddocks --- .../Database/Persist/Postgresql.hs | 18 +++++++++--------- .../Persist/Sql/Orphan/PersistQuery.hs | 2 +- 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index a4feb9e05..fadc77d3a 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -1755,7 +1755,7 @@ repsertManySql ent n = putManySql' conflictColumns fields ent n -- @INSERT ... ON CONFLICT KEY UPDATE@ functionality, exposed via -- 'upsertWhere' and 'upsertManyWhere' in this library. -- --- @since 2.12.1 +-- @since 2.12.1.0 data HandleUpdateCollision record where -- | Copy the field directly from the record. CopyField :: EntityField record typ -> HandleUpdateCollision record @@ -1765,7 +1765,7 @@ data HandleUpdateCollision record where -- | Copy the field into the database only if the value in the -- corresponding record is non-@NULL@. -- --- @since 2.12.1 +-- @since 2.12.1.0 copyUnlessNull :: PersistField typ => EntityField record (Maybe typ) -> HandleUpdateCollision record copyUnlessNull field = CopyUnlessEq field Nothing @@ -1776,7 +1776,7 @@ copyUnlessNull field = CopyUnlessEq field Nothing -- The resulting 'HandleUpdateCollision' type is useful for the -- 'upsertManyWhere' function. -- --- @since 2.12.1 +-- @since 2.12.1.0 copyUnlessEmpty :: (Monoid.Monoid typ, PersistField typ) => EntityField record typ -> HandleUpdateCollision record copyUnlessEmpty field = CopyUnlessEq field Monoid.mempty @@ -1787,13 +1787,13 @@ copyUnlessEmpty field = CopyUnlessEq field Monoid.mempty -- The resulting 'HandleUpdateCollision' type is useful for the -- 'upsertMany' function. -- --- @since 2.6.2 +-- @since 2.12.1.0 copyUnlessEq :: PersistField typ => EntityField record typ -> typ -> HandleUpdateCollision record copyUnlessEq = CopyUnlessEq -- | Copy the field directly from the record. -- --- @since 2.6.2 +-- @since 2.12.1.0 copyField :: PersistField typ => EntityField record typ -> HandleUpdateCollision record copyField = CopyField @@ -1808,7 +1808,7 @@ copyField = CopyField -- Called thusly, this method will insert a new record (if none exists) OR update a recordField with a new value -- assuming the condition in the last block is met. -- --- @since 2.12.1 +-- @since 2.12.1.0 upsertWhere :: ( backend ~ PersistEntityBackend record , PersistEntity record @@ -1835,7 +1835,7 @@ upsertWhere record updates filts = -- Called thusly, this method will insert a new record (if none exists) OR update a recordField with a new value -- assuming the condition in the last block is met. -- --- -- @since 2.12.0.1 +-- -- @since 2.12.1.0 upsertManyWhere :: forall record backend m. ( backend ~ PersistEntityBackend record, @@ -1850,7 +1850,7 @@ upsertManyWhere :: [HandleUpdateCollision record] -> -- | A list of the updates to apply that aren't dependent on the record being inserted. [Update record] -> - -- a filter condition + -- | A filter condition that dictates the scope of the updates [Filter record] -> ReaderT backend m () upsertManyWhere [] _ _ _ = return () @@ -1869,7 +1869,7 @@ mkBulkUpsertQuery -> SqlBackend -> [HandleUpdateCollision record] -- ^ A list of the fields you want to copy over. -> [Update record] -- ^ A list of the updates to apply that aren't dependent on the record being inserted. - -> [Filter record] + -> [Filter record] -- ^ A filter condition that dictates the scope of the updates -> (Text, [PersistValue]) mkBulkUpsertQuery records conn fieldValues updates filters = (q, recordValues <> updsValues <> copyUnlessValues <> whereVals) diff --git a/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs b/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs index 008740394..785373bcb 100644 --- a/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs +++ b/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs @@ -235,7 +235,7 @@ data OrNull = OrNullYes | OrNullNo filterClauseHelper :: (PersistEntity val, PersistEntityBackend val ~ SqlBackend) => Bool -- ^ include table name? -> Bool -- ^ include WHERE? - -> Bool -- ^ use postgresl EXCLUDE + -> Bool -- ^ include PostgresSQL EXCLUDED -> SqlBackend -> OrNull -> [Filter val] From bb05bfeb5b03c44bcb9959470e61fe24a6052b6c Mon Sep 17 00:00:00 2001 From: Dylan Martin Date: Tue, 6 Apr 2021 13:01:25 -0700 Subject: [PATCH 26/41] don't need to touch Raw --- persistent/Database/Persist/Sql/Raw.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/persistent/Database/Persist/Sql/Raw.hs b/persistent/Database/Persist/Sql/Raw.hs index de0d0860d..b3bd2b72e 100644 --- a/persistent/Database/Persist/Sql/Raw.hs +++ b/persistent/Database/Persist/Sql/Raw.hs @@ -17,7 +17,6 @@ import qualified Data.Text as T import Database.Persist import Database.Persist.Sql.Types import Database.Persist.Sql.Class -import Debug.Trace rawQuery :: (MonadResource m, MonadReader env m, BackendCompatible SqlBackend env) => Text @@ -49,8 +48,7 @@ rawExecute :: (MonadIO m, BackendCompatible SqlBackend backend) => Text -- ^ SQL statement, possibly with placeholders. -> [PersistValue] -- ^ Values to fill the placeholders. -> ReaderT backend m () -rawExecute x y = do - liftM (const ()) $ rawExecuteCount x y +rawExecute x y = liftM (const ()) $ rawExecuteCount x y -- | Execute a raw SQL statement and return the number of -- rows it has modified. From 365b1b448e1619e88b639ff26e7b2b5b1f701664 Mon Sep 17 00:00:00 2001 From: Dylan Martin Date: Tue, 6 Apr 2021 14:46:03 -0700 Subject: [PATCH 27/41] remodeled the data --- .../Database/Persist/Postgresql.hs | 2 +- persistent/Database/Persist/Sql.hs | 1 + .../Persist/Sql/Orphan/PersistQuery.hs | 75 ++++++++++--------- 3 files changed, 40 insertions(+), 38 deletions(-) diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index fadc77d3a..005d92408 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -1909,7 +1909,7 @@ mkBulkUpsertQuery records conn fieldValues updates filters = updsValues = map (\(Update _ val _) -> toPersistValue val) updates (wher, whereVals) = if null filters then ("", []) - else (filterClauseWithVals False conn filters) + else (filterClauseWithVals (Just PrefixExcluded) conn filters) updateText = case fieldSets <> upds <> condFieldSets of [] -> T.concat [firstField, "=EXCLUDED.", firstField] xs -> Util.commaSeparated xs diff --git a/persistent/Database/Persist/Sql.hs b/persistent/Database/Persist/Sql.hs index e423c3245..33676da55 100644 --- a/persistent/Database/Persist/Sql.hs +++ b/persistent/Database/Persist/Sql.hs @@ -15,6 +15,7 @@ module Database.Persist.Sql , filterClause , filterClauseHelper , filterClauseWithVals + , FilterTablePrefix (..) , transactionSave , transactionSaveWithIsolation , transactionUndo diff --git a/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs b/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs index 785373bcb..7a74a24bc 100644 --- a/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs +++ b/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs @@ -9,6 +9,7 @@ module Database.Persist.Sql.Orphan.PersistQuery , filterClause , filterClauseHelper , filterClauseWithVals + , FilterTablePrefix (..) , decorateSQLWithLimitOffset ) where @@ -39,7 +40,7 @@ instance PersistQueryRead SqlBackend where conn <- ask let wher = if null filts then "" - else filterClause False conn filts + else filterClause Nothing conn filts let sql = mconcat [ "SELECT COUNT(*) FROM " , connEscapeTableName conn t @@ -62,7 +63,7 @@ instance PersistQueryRead SqlBackend where conn <- ask let wher = if null filts then "" - else filterClause False conn filts + else filterClause Nothing conn filts let sql = mconcat [ "SELECT EXISTS(SELECT 1 FROM " , connEscapeTableName conn t @@ -96,7 +97,7 @@ instance PersistQueryRead SqlBackend where t = entityDef $ dummyFromFilts filts wher conn = if null filts then "" - else filterClause False conn filts + else filterClause Nothing conn filts ord conn = case map (orderClause False conn) orders of [] -> "" @@ -122,7 +123,7 @@ instance PersistQueryRead SqlBackend where wher conn = if null filts then "" - else filterClause False conn filts + else filterClause Nothing conn filts sql conn = connLimitOffset conn (limit,offset) (not (null orders)) $ mconcat [ "SELECT " , cols conn @@ -186,7 +187,7 @@ deleteWhereCount filts = withCompatibleBackend $ do let t = entityDef $ dummyFromFilts filts let wher = if null filts then "" - else filterClause False conn filts + else filterClause Nothing conn filts sql = mconcat [ "DELETE FROM " , connEscapeTableName conn t @@ -206,7 +207,7 @@ updateWhereCount filts upds = withCompatibleBackend $ do conn <- ask let wher = if null filts then "" - else filterClause False conn filts + else filterClause Nothing conn filts let sql = mconcat [ "UPDATE " , connEscapeTableName conn t @@ -228,19 +229,22 @@ dummyFromFilts _ = Nothing getFiltsValues :: forall val. (PersistEntity val, PersistEntityBackend val ~ SqlBackend) => SqlBackend -> [Filter val] -> [PersistValue] -getFiltsValues conn = snd . filterClauseHelper False False False conn OrNullNo +getFiltsValues conn = snd . filterClauseHelper Nothing False conn OrNullNo data OrNull = OrNullYes | OrNullNo +data FilterTablePrefix + = PrefixTableName + | PrefixExcluded + filterClauseHelper :: (PersistEntity val, PersistEntityBackend val ~ SqlBackend) - => Bool -- ^ include table name? - -> Bool -- ^ include WHERE? - -> Bool -- ^ include PostgresSQL EXCLUDED + => Maybe FilterTablePrefix -- ^ include table name or PostgresSQL EXCLUDED + -> Bool -- ^ include WHERE -> SqlBackend -> OrNull -> [Filter val] -> (Text, [PersistValue]) -filterClauseHelper includeTable includeWhere includeExcluded conn orNull filters = +filterClauseHelper tablePrefix includeWhere conn orNull filters = (if not (T.null sql) && includeWhere then " WHERE " <> sql else sql, vals) @@ -295,52 +299,51 @@ filterClauseHelper includeTable includeWhere includeExcluded conn orNull filters error $ "unhandled error for composite/non id primary keys filter=" ++ show pfilter ++ " persistList=" ++ show allVals ++ " pdef=" ++ show pdef _ -> case (isNull, pfilter, length notNullVals) of - (True, Eq, _) -> (T.concat - [ name - , " IS NULL" - ],[]) - (True, Ne, _) -> (T.concat - [ name - , " IS NOT NULL" - ],[]) + (True, Eq, _) -> (name <> " IS NULL", []) + (True, Ne, _) -> (name <> " IS NOT NULL", []) (False, Ne, _) -> (T.concat - [ name + [ "(" + , name , " IS NULL OR " , name , " <> " , qmarks + , ")" ], notNullVals) -- We use 1=2 (and below 1=1) to avoid using TRUE and FALSE, since -- not all databases support those words directly. (_, In, 0) -> ("1=2" <> orNullSuffix, []) (False, In, _) -> (name <> " IN " <> qmarks <> orNullSuffix, allVals) (True, In, _) -> (T.concat - [ name + [ "(" + , name , " IS NULL OR " , name , " IN " , qmarks + , ")" ], notNullVals) (False, NotIn, 0) -> ("1=1", []) (True, NotIn, 0) -> (name <> " IS NOT NULL", []) (False, NotIn, _) -> (T.concat - [ name + [ "(" + , name , " IS NULL OR " , name , " NOT IN " , qmarks + , ")" ], notNullVals) (True, NotIn, _) -> (T.concat - [ name + [ "(" + , name , " IS NOT NULL AND " , name , " NOT IN " , qmarks + , ")" ], notNullVals) - _ -> (T.concat - [name - <> showSqlFilter pfilter <> "?" <> orNullSuffix - ], allVals) + _ -> (name <> showSqlFilter pfilter <> "?" <> orNullSuffix, allVals) where isCompFilter Lt = True @@ -371,12 +374,10 @@ filterClauseHelper includeTable includeWhere includeExcluded conn orNull filters allVals = filterValueToPersistValues value tn = connEscapeTableName conn $ entityDef $ dummyFromFilts [Filter field value pfilter] name = - (if includeTable - then ((tn <> ".") <>) - else if includeExcluded -- need this for PostgreSQL queries - then (("EXCLUDED.") <>) - else id) - $ connEscapeFieldName conn (fieldName field) + case tablePrefix of + Just PrefixTableName -> ((tn <> ".") <>) $ connEscapeFieldName conn (fieldName field) + Just PrefixExcluded -> (("EXCLUDED.") <>) $ connEscapeFieldName conn (fieldName field) + _ -> id $ connEscapeFieldName conn (fieldName field) qmarks = case value of FilterValue{} -> "(?)" UnsafeValue{} -> "(?)" @@ -397,18 +398,18 @@ filterClauseHelper includeTable includeWhere includeExcluded conn orNull filters showSqlFilter (BackendSpecificFilter s) = s filterClause :: (PersistEntity val, PersistEntityBackend val ~ SqlBackend) - => Bool -- ^ include table name? + => Maybe FilterTablePrefix -- ^ include table name or EXCLUDED -> SqlBackend -> [Filter val] -> Text -filterClause b c = fst . filterClauseHelper b True False c OrNullNo +filterClause b c = fst . filterClauseHelper b True c OrNullNo filterClauseWithVals :: (PersistEntity val, PersistEntityBackend val ~ SqlBackend) - => Bool -- ^ include table name? + => Maybe FilterTablePrefix -- ^ include table name or EXCLUDED -> SqlBackend -> [Filter val] -> (Text, [PersistValue]) -filterClauseWithVals b c = filterClauseHelper b True True c OrNullNo +filterClauseWithVals b c = filterClauseHelper b True c OrNullNo orderClause :: (PersistEntity val, PersistEntityBackend val ~ SqlBackend) => Bool -- ^ include the table name From 078ae4d17bd8c527c080a3d749c3afeee6d725b5 Mon Sep 17 00:00:00 2001 From: Dylan Martin Date: Tue, 6 Apr 2021 16:31:12 -0700 Subject: [PATCH 28/41] Update persistent-postgresql/Database/Persist/Postgresql.hs Co-authored-by: Matt Parsons --- persistent-postgresql/Database/Persist/Postgresql.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index 005d92408..e45457c95 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -1840,7 +1840,6 @@ upsertManyWhere :: forall record backend m. ( backend ~ PersistEntityBackend record, BackendCompatible SqlBackend backend, - PersistEntityBackend record ~ SqlBackend, PersistEntity record, MonadIO m ) => From a75421a4c980b4092efec5c3bd9efc8d70f8512f Mon Sep 17 00:00:00 2001 From: Dylan Martin Date: Tue, 6 Apr 2021 16:31:30 -0700 Subject: [PATCH 29/41] Update persistent-postgresql/Database/Persist/Postgresql.hs Co-authored-by: Matt Parsons --- persistent-postgresql/Database/Persist/Postgresql.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index e45457c95..9d3f2c095 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -1803,7 +1803,9 @@ copyField = CopyField -- it will only do this update on a user-supplied condition. -- For example, here's how this method could be called like such: -- +-- @ -- upsertWhere record [recordField =. newValue] [recordField /= newValue] +-- @ -- -- Called thusly, this method will insert a new record (if none exists) OR update a recordField with a new value -- assuming the condition in the last block is met. From 84bcb35bd2730c9af04914754b5c80da8d0dbc0d Mon Sep 17 00:00:00 2001 From: Dylan Martin Date: Tue, 6 Apr 2021 17:01:25 -0700 Subject: [PATCH 30/41] Update persistent-postgresql/Database/Persist/Postgresql.hs Co-authored-by: Matt Parsons --- persistent-postgresql/Database/Persist/Postgresql.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index 9d3f2c095..0b0f6158b 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -1865,7 +1865,7 @@ upsertManyWhere records fieldValues updates filters = do -- a dummy/no-op update using the first field of the record. This avoids -- duplicate key exceptions. mkBulkUpsertQuery - :: (PersistEntity record, PersistEntityBackend record ~ SqlBackend) + :: (PersistEntity record) => [record] -- ^ A list of the records you want to insert, or update -> SqlBackend -> [HandleUpdateCollision record] -- ^ A list of the fields you want to copy over. From ace05692815563a488df6fb2ee316d1c1c0df06c Mon Sep 17 00:00:00 2001 From: Dylan Martin Date: Wed, 7 Apr 2021 09:53:49 -0700 Subject: [PATCH 31/41] fix formatting --- .../Database/Persist/Postgresql.hs | 33 ++++++++++--------- 1 file changed, 17 insertions(+), 16 deletions(-) diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index 0b0f6158b..8ffdbb59a 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -1839,21 +1839,22 @@ upsertWhere record updates filts = -- -- -- @since 2.12.1.0 upsertManyWhere :: - forall record backend m. - ( backend ~ PersistEntityBackend record, - BackendCompatible SqlBackend backend, - PersistEntity record, - MonadIO m - ) => - -- | A list of the records you want to insert, or update - [record] -> - -- | A list of the fields you want to copy over. - [HandleUpdateCollision record] -> - -- | A list of the updates to apply that aren't dependent on the record being inserted. - [Update record] -> - -- | A filter condition that dictates the scope of the updates - [Filter record] -> - ReaderT backend m () + forall record backend m. + ( backend ~ PersistEntityBackend record, + BackendCompatible SqlBackend backend, + PersistEntityBackend record ~ SqlBackend, + PersistEntity record, + MonadIO m + ) => + -- | A list of the records you want to insert, or update + [record] -> + -- | A list of the fields you want to copy over. + [HandleUpdateCollision record] -> + -- | A list of the updates to apply that aren't dependent on the record being inserted. + [Update record] -> + -- | A filter condition that dictates the scope of the updates + [Filter record] -> + ReaderT backend m () upsertManyWhere [] _ _ _ = return () upsertManyWhere records fieldValues updates filters = do conn <- asks projectBackend @@ -1865,7 +1866,7 @@ upsertManyWhere records fieldValues updates filters = do -- a dummy/no-op update using the first field of the record. This avoids -- duplicate key exceptions. mkBulkUpsertQuery - :: (PersistEntity record) + :: (PersistEntity record, PersistEntityBackend record ~ SqlBackend) => [record] -- ^ A list of the records you want to insert, or update -> SqlBackend -> [HandleUpdateCollision record] -- ^ A list of the fields you want to copy over. From de8f0776a8a8bf6a1c1e9d224476756f4a7bebd3 Mon Sep 17 00:00:00 2001 From: Dylan Martin Date: Wed, 7 Apr 2021 11:01:07 -0700 Subject: [PATCH 32/41] latest changes real quick --- .../Database/Persist/Postgresql.hs | 5 ++-- .../Database/Persist/Postgresql/Util.hs | 30 ------------------- .../Persist/Sql/Orphan/PersistQuery.hs | 14 ++++----- persistent/Database/Persist/Sql/Raw.hs | 4 ++- persistent/Database/Persist/Sql/Util.hs | 3 +- 5 files changed, 14 insertions(+), 42 deletions(-) delete mode 100644 persistent-postgresql/Database/Persist/Postgresql/Util.hs diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index 8ffdbb59a..ab35befdc 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -104,7 +104,6 @@ import System.Environment (getEnvironment) import Database.Persist.Sql import qualified Database.Persist.Sql.Util as Util -import Database.Persist.Postgresql.Util as Util -- | A @libpq@ connection string. A simple example of connection -- string would be @\"host=localhost port=5432 user=test @@ -1907,11 +1906,11 @@ mkBulkUpsertQuery records conn fieldValues updates filters = ] condFieldSets = map (uncurry mkCondFieldSet) fieldsToMaybeCopy fieldSets = map (\n -> T.concat [n, "=EXCLUDED.", n, ""]) updateFieldNames - upds = map (Util.mkPostgresUpdateText (escapeF) id) updates + upds = map (Util.mkUpdateText' (escapeF) (\n -> T.concat [nameOfTable, ".", n])) updates updsValues = map (\(Update _ val _) -> toPersistValue val) updates (wher, whereVals) = if null filters then ("", []) - else (filterClauseWithVals (Just PrefixExcluded) conn filters) + else (filterClauseWithVals (Just PrefixTableName) conn filters) updateText = case fieldSets <> upds <> condFieldSets of [] -> T.concat [firstField, "=EXCLUDED.", firstField] xs -> Util.commaSeparated xs diff --git a/persistent-postgresql/Database/Persist/Postgresql/Util.hs b/persistent-postgresql/Database/Persist/Postgresql/Util.hs deleted file mode 100644 index 5eb0d4549..000000000 --- a/persistent-postgresql/Database/Persist/Postgresql/Util.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Database.Persist.Postgresql.Util ( - mkPostgresUpdateText -) where - -import Data.Monoid ((<>)) -import Data.Text (Text) -import qualified Data.Text as T - -import Database.Persist (FieldNameDB, PersistEntity (..), PersistUpdate(..), Update(..), updateUpdate, fieldDB, FieldDef) - - -mkPostgresUpdateText :: PersistEntity record => (FieldNameDB -> Text) -> (Text -> Text) -> Update record -> Text -mkPostgresUpdateText escapeName refColumn x = - case updateUpdate x of - Assign -> n <> "=?" - Add -> T.concat [n, "=EXCLUDED.", refColumn n, "+?"] - Subtract -> T.concat [n, "=EXCLUDED.", refColumn n, "-?"] - Multiply -> T.concat [n, "=EXCLUDED.", refColumn n, "*?"] - Divide -> T.concat [n, "=EXCLUDED.", refColumn n, "/?"] - BackendSpecificUpdate up -> - error . T.unpack $ "mkUpdateText: BackendSpecificUpdate " <> up <> " not supported" - where - n = escapeName . fieldDB . updateFieldDef $ x - --- | Gets the 'FieldDef' for an 'Update'. -updateFieldDef :: PersistEntity v => Update v -> FieldDef -updateFieldDef (Update f _ _) = persistFieldDef f -updateFieldDef BackendUpdate {} = error "updateFieldDef: did not expect BackendUpdate" \ No newline at end of file diff --git a/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs b/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs index 7a74a24bc..a593bf4e1 100644 --- a/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs +++ b/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs @@ -221,13 +221,13 @@ updateWhereCount filts upds = withCompatibleBackend $ do where t = entityDef $ dummyFromFilts filts -fieldName :: forall record typ. (PersistEntity record, PersistEntityBackend record ~ SqlBackend) => EntityField record typ -> FieldNameDB +fieldName :: forall record typ. (PersistEntity record) => EntityField record typ -> FieldNameDB fieldName f = fieldDB $ persistFieldDef f dummyFromFilts :: [Filter v] -> Maybe v dummyFromFilts _ = Nothing -getFiltsValues :: forall val. (PersistEntity val, PersistEntityBackend val ~ SqlBackend) +getFiltsValues :: forall val. (PersistEntity val) => SqlBackend -> [Filter val] -> [PersistValue] getFiltsValues conn = snd . filterClauseHelper Nothing False conn OrNullNo @@ -237,7 +237,7 @@ data FilterTablePrefix = PrefixTableName | PrefixExcluded -filterClauseHelper :: (PersistEntity val, PersistEntityBackend val ~ SqlBackend) +filterClauseHelper :: (PersistEntity val) => Maybe FilterTablePrefix -- ^ include table name or PostgresSQL EXCLUDED -> Bool -- ^ include WHERE -> SqlBackend @@ -397,21 +397,21 @@ filterClauseHelper tablePrefix includeWhere conn orNull filters = showSqlFilter NotIn = " NOT IN " showSqlFilter (BackendSpecificFilter s) = s -filterClause :: (PersistEntity val, PersistEntityBackend val ~ SqlBackend) +filterClause :: (PersistEntity val) => Maybe FilterTablePrefix -- ^ include table name or EXCLUDED -> SqlBackend -> [Filter val] -> Text filterClause b c = fst . filterClauseHelper b True c OrNullNo -filterClauseWithVals :: (PersistEntity val, PersistEntityBackend val ~ SqlBackend) +filterClauseWithVals :: (PersistEntity val) => Maybe FilterTablePrefix -- ^ include table name or EXCLUDED -> SqlBackend -> [Filter val] -> (Text, [PersistValue]) filterClauseWithVals b c = filterClauseHelper b True c OrNullNo -orderClause :: (PersistEntity val, PersistEntityBackend val ~ SqlBackend) +orderClause :: (PersistEntity val) => Bool -- ^ include the table name -> SqlBackend -> SelectOpt val @@ -427,7 +427,7 @@ orderClause includeTable conn o = tn = connEscapeTableName conn (entityDef $ dummyFromOrder o) - name :: (PersistEntityBackend record ~ SqlBackend, PersistEntity record) + name :: (PersistEntity record) => EntityField record typ -> Text name x = (if includeTable diff --git a/persistent/Database/Persist/Sql/Raw.hs b/persistent/Database/Persist/Sql/Raw.hs index b3bd2b72e..11855e2ab 100644 --- a/persistent/Database/Persist/Sql/Raw.hs +++ b/persistent/Database/Persist/Sql/Raw.hs @@ -48,7 +48,9 @@ rawExecute :: (MonadIO m, BackendCompatible SqlBackend backend) => Text -- ^ SQL statement, possibly with placeholders. -> [PersistValue] -- ^ Values to fill the placeholders. -> ReaderT backend m () -rawExecute x y = liftM (const ()) $ rawExecuteCount x y +rawExecute x y = do + liftIO $ putStrLn $ T.unpack x + liftM (const ()) $ rawExecuteCount x y -- | Execute a raw SQL statement and return the number of -- rows it has modified. diff --git a/persistent/Database/Persist/Sql/Util.hs b/persistent/Database/Persist/Sql/Util.hs index 980cc6e08..d68e55320 100644 --- a/persistent/Database/Persist/Sql/Util.hs +++ b/persistent/Database/Persist/Sql/Util.hs @@ -207,6 +207,7 @@ commaSeparated = T.intercalate ", " mkUpdateText :: PersistEntity record => SqlBackend -> Update record -> Text mkUpdateText conn = mkUpdateText' (connEscapeFieldName conn) id +-- TODO: incorporate the table names into a sum type mkUpdateText' :: PersistEntity record => (FieldNameDB -> Text) -> (Text -> Text) -> Update record -> Text mkUpdateText' escapeName refColumn x = case updateUpdate x of @@ -223,7 +224,7 @@ mkUpdateText' escapeName refColumn x = parenWrapped :: Text -> Text parenWrapped t = T.concat ["(", t, ")"] --- | Make a list 'PersistValue' suitable for detabase inserts. Pairs nicely +-- | Make a list 'PersistValue' suitable for database inserts. Pairs nicely -- with the function 'mkInsertPlaceholders'. -- -- Does not include generated columns. From b8676f9cfde73a1ebff6b55a62ecffa3611edf3a Mon Sep 17 00:00:00 2001 From: Dylan Martin Date: Wed, 7 Apr 2021 11:40:23 -0700 Subject: [PATCH 33/41] this should all compile but there's no sum type yet. Just taking stock of what we have --- .../Database/Persist/Postgresql.hs | 32 +++++++++++++++++-- .../Database/Persist/Postgresql/Util.hs | 30 +++++++++++++++++ .../persistent-postgresql.cabal | 1 - persistent-postgresql/test/UpsertWhere.hs | 12 +++++++ 4 files changed, 71 insertions(+), 4 deletions(-) create mode 100644 persistent-postgresql/Database/Persist/Postgresql/Util.hs diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index ab35befdc..7ad194ba9 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -30,6 +30,7 @@ module Database.Persist.Postgresql , copyUnlessNull , copyUnlessEmpty , copyUnlessEq + , excludedNotEqualToOriginal , PostgresConf (..) , PgInterval (..) , upsertWhere @@ -1825,6 +1826,29 @@ upsertWhere upsertWhere record updates filts = upsertManyWhere [record] [] updates filts +excludedNotEqualToOriginal :: + (PersistField typ + , PersistEntity rec) => + EntityField rec typ -> + Filter rec +excludedNotEqualToOriginal field = + Filter + { filterField = + field, + filterFilter = + Ne, + filterValue = + UnsafeValue $ + PersistLiteral_ + Unescaped + bsForExcludedField + } + where + bsForExcludedField = + T.encodeUtf8 $ + "EXCLUDED." + <> fieldName field + -- | Postgres specific 'upsertManyWhere'. This method does the following: -- It will insert a record if no matching unique key exists. -- If a unique key exists, it will update the relevant field with a user-supplied value, however, @@ -1898,9 +1922,11 @@ mkBulkUpsertQuery records conn fieldValues updates filters = , "EXCLUDED." , n , "," - , "?" - , ")" - , ",ITEM." + , "?" + , ")" + , "," + , nameOfTable + , "." , n ,")" ] diff --git a/persistent-postgresql/Database/Persist/Postgresql/Util.hs b/persistent-postgresql/Database/Persist/Postgresql/Util.hs new file mode 100644 index 000000000..5eb0d4549 --- /dev/null +++ b/persistent-postgresql/Database/Persist/Postgresql/Util.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Database.Persist.Postgresql.Util ( + mkPostgresUpdateText +) where + +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T + +import Database.Persist (FieldNameDB, PersistEntity (..), PersistUpdate(..), Update(..), updateUpdate, fieldDB, FieldDef) + + +mkPostgresUpdateText :: PersistEntity record => (FieldNameDB -> Text) -> (Text -> Text) -> Update record -> Text +mkPostgresUpdateText escapeName refColumn x = + case updateUpdate x of + Assign -> n <> "=?" + Add -> T.concat [n, "=EXCLUDED.", refColumn n, "+?"] + Subtract -> T.concat [n, "=EXCLUDED.", refColumn n, "-?"] + Multiply -> T.concat [n, "=EXCLUDED.", refColumn n, "*?"] + Divide -> T.concat [n, "=EXCLUDED.", refColumn n, "/?"] + BackendSpecificUpdate up -> + error . T.unpack $ "mkUpdateText: BackendSpecificUpdate " <> up <> " not supported" + where + n = escapeName . fieldDB . updateFieldDef $ x + +-- | Gets the 'FieldDef' for an 'Update'. +updateFieldDef :: PersistEntity v => Update v -> FieldDef +updateFieldDef (Update f _ _) = persistFieldDef f +updateFieldDef BackendUpdate {} = error "updateFieldDef: did not expect BackendUpdate" \ No newline at end of file diff --git a/persistent-postgresql/persistent-postgresql.cabal b/persistent-postgresql/persistent-postgresql.cabal index 46df1702d..4f7a8eb69 100644 --- a/persistent-postgresql/persistent-postgresql.cabal +++ b/persistent-postgresql/persistent-postgresql.cabal @@ -36,7 +36,6 @@ library , unliftio-core exposed-modules: Database.Persist.Postgresql , Database.Persist.Postgresql.JSON - other-modules: Database.Persist.Postgresql.Util ghc-options: -Wall default-language: Haskell2010 diff --git a/persistent-postgresql/test/UpsertWhere.hs b/persistent-postgresql/test/UpsertWhere.hs index 513975633..8389525c9 100644 --- a/persistent-postgresql/test/UpsertWhere.hs +++ b/persistent-postgresql/test/UpsertWhere.hs @@ -132,3 +132,15 @@ specs = describe "UpsertWhere" $ do [ItemDescription ==. "bye friends!"] dbItems <- sort . fmap entityVal <$> selectList [] [] dbItems @== sort (newItem : items) + it "inserts an item and excludes a field if it matches the filter" $ + runConnAssert $ do + let newItem = Item "item3" "hello world" Nothing Nothing + deleteWhere ([] :: [Filter Item]) + insertMany_ items + upsertManyWhere + (newItem : items) + [] + [] + [excludedNotEqualToOriginal ItemDescription] + dbItems <- sort . fmap entityVal <$> selectList [] [] + dbItems @== sort (newItem : items) From b89405924655564c73c4311cae3a3e7d9d366619 Mon Sep 17 00:00:00 2001 From: Dylan Martin Date: Wed, 7 Apr 2021 12:24:12 -0700 Subject: [PATCH 34/41] remove debug logs --- persistent/Database/Persist/Sql/Raw.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/persistent/Database/Persist/Sql/Raw.hs b/persistent/Database/Persist/Sql/Raw.hs index 11855e2ab..b3bd2b72e 100644 --- a/persistent/Database/Persist/Sql/Raw.hs +++ b/persistent/Database/Persist/Sql/Raw.hs @@ -48,9 +48,7 @@ rawExecute :: (MonadIO m, BackendCompatible SqlBackend backend) => Text -- ^ SQL statement, possibly with placeholders. -> [PersistValue] -- ^ Values to fill the placeholders. -> ReaderT backend m () -rawExecute x y = do - liftIO $ putStrLn $ T.unpack x - liftM (const ()) $ rawExecuteCount x y +rawExecute x y = liftM (const ()) $ rawExecuteCount x y -- | Execute a raw SQL statement and return the number of -- rows it has modified. From 83f36488e50a29657daa9a9d5ee8fe4229eaf421 Mon Sep 17 00:00:00 2001 From: Dylan Martin Date: Wed, 7 Apr 2021 12:27:14 -0700 Subject: [PATCH 35/41] add sum type todo --- persistent-postgresql/Database/Persist/Postgresql.hs | 10 ++++++++-- persistent-postgresql/test/UpsertWhere.hs | 2 +- 2 files changed, 9 insertions(+), 3 deletions(-) diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index 7ad194ba9..252fca50f 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -1826,12 +1826,18 @@ upsertWhere upsertWhere record updates filts = upsertManyWhere [record] [] updates filts -excludedNotEqualToOriginal :: +-- | Exclude any record field if it doesn't match the filter record. Used only in `upsertWhere` and +-- `upsertManyWhere` +-- +-- @since 2.12.1.0 +-- TODO: we could probably make a sum type for the `Filter` record that's passed into the `upserWhere` and +-- `upsertManyWhere` methods that has similar behavior to the HandleCollisionUpdate type. +excludeNotEqualToOriginal :: (PersistField typ , PersistEntity rec) => EntityField rec typ -> Filter rec -excludedNotEqualToOriginal field = +excludeNotEqualToOriginal field = Filter { filterField = field, diff --git a/persistent-postgresql/test/UpsertWhere.hs b/persistent-postgresql/test/UpsertWhere.hs index 8389525c9..378fe1c2c 100644 --- a/persistent-postgresql/test/UpsertWhere.hs +++ b/persistent-postgresql/test/UpsertWhere.hs @@ -141,6 +141,6 @@ specs = describe "UpsertWhere" $ do (newItem : items) [] [] - [excludedNotEqualToOriginal ItemDescription] + [excludeNotEqualToOriginal ItemDescription] dbItems <- sort . fmap entityVal <$> selectList [] [] dbItems @== sort (newItem : items) From fed25a9b92f288c735d5f7a265f3dcdf7a0c91cf Mon Sep 17 00:00:00 2001 From: Dylan Martin Date: Wed, 7 Apr 2021 12:37:27 -0700 Subject: [PATCH 36/41] this should work --- .../Database/Persist/Postgresql.hs | 2 +- .../Database/Persist/Postgresql/Util.hs | 30 ------------------- 2 files changed, 1 insertion(+), 31 deletions(-) delete mode 100644 persistent-postgresql/Database/Persist/Postgresql/Util.hs diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index 252fca50f..2fa1fed6b 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -30,7 +30,7 @@ module Database.Persist.Postgresql , copyUnlessNull , copyUnlessEmpty , copyUnlessEq - , excludedNotEqualToOriginal + , excludeNotEqualToOriginal , PostgresConf (..) , PgInterval (..) , upsertWhere diff --git a/persistent-postgresql/Database/Persist/Postgresql/Util.hs b/persistent-postgresql/Database/Persist/Postgresql/Util.hs deleted file mode 100644 index 5eb0d4549..000000000 --- a/persistent-postgresql/Database/Persist/Postgresql/Util.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Database.Persist.Postgresql.Util ( - mkPostgresUpdateText -) where - -import Data.Monoid ((<>)) -import Data.Text (Text) -import qualified Data.Text as T - -import Database.Persist (FieldNameDB, PersistEntity (..), PersistUpdate(..), Update(..), updateUpdate, fieldDB, FieldDef) - - -mkPostgresUpdateText :: PersistEntity record => (FieldNameDB -> Text) -> (Text -> Text) -> Update record -> Text -mkPostgresUpdateText escapeName refColumn x = - case updateUpdate x of - Assign -> n <> "=?" - Add -> T.concat [n, "=EXCLUDED.", refColumn n, "+?"] - Subtract -> T.concat [n, "=EXCLUDED.", refColumn n, "-?"] - Multiply -> T.concat [n, "=EXCLUDED.", refColumn n, "*?"] - Divide -> T.concat [n, "=EXCLUDED.", refColumn n, "/?"] - BackendSpecificUpdate up -> - error . T.unpack $ "mkUpdateText: BackendSpecificUpdate " <> up <> " not supported" - where - n = escapeName . fieldDB . updateFieldDef $ x - --- | Gets the 'FieldDef' for an 'Update'. -updateFieldDef :: PersistEntity v => Update v -> FieldDef -updateFieldDef (Update f _ _) = persistFieldDef f -updateFieldDef BackendUpdate {} = error "updateFieldDef: did not expect BackendUpdate" \ No newline at end of file From 6420304eeee63fd965e596085f256de19f2d716b Mon Sep 17 00:00:00 2001 From: Dylan Martin Date: Wed, 7 Apr 2021 15:04:05 -0700 Subject: [PATCH 37/41] we got the tests rocking! --- persistent-postgresql/test/UpsertWhere.hs | 41 ++++++++++++++++++++--- 1 file changed, 36 insertions(+), 5 deletions(-) diff --git a/persistent-postgresql/test/UpsertWhere.hs b/persistent-postgresql/test/UpsertWhere.hs index 378fe1c2c..43fe1922d 100644 --- a/persistent-postgresql/test/UpsertWhere.hs +++ b/persistent-postgresql/test/UpsertWhere.hs @@ -32,13 +32,13 @@ specs = describe "UpsertWhere" $ do let item1 = Item "item1" "" (Just 3) Nothing item2 = Item "item2" "hello world" Nothing (Just 2) items = [item1, item2] + describe "upsertWhere" $ do it "inserts appropriately" $ runConnAssert $ do deleteWhere ([] :: [Filter Item]) upsertWhere item1 [ItemDescription =. "i am item 1"] [] Just item <- get (ItemKey "item1") item @== item1 - it "performs only updates given if record already exists" $ runConnAssert $ do deleteWhere ([] :: [Filter Item]) let newDescription = "I am a new description" @@ -64,12 +64,15 @@ specs = describe "UpsertWhere" $ do sort dbItems @== sort (newItem : items) it "updates existing records" $ runConnAssert $ do deleteWhere ([] :: [Filter Item]) + let postUpdate = map (\i -> i { itemQuantity = fmap (+1) (itemQuantity i) }) items insertMany_ items upsertManyWhere items [] [ItemQuantity +=. Just 1] [] + dbItems <- sort . fmap entityVal <$> selectList [] [] + dbItems @== sort postUpdate it "only copies passing values" $ runConnAssert $ do deleteWhere ([] :: [Filter Item]) insertMany_ items @@ -120,7 +123,7 @@ specs = describe "UpsertWhere" $ do [ItemDescription ==. "hi friends!"] dbItems <- sort . fmap entityVal <$> selectList [] [] dbItems @== sort (newItem : items) - it "inserts and modifies existing records if there are updates specified and the filter doesn't apply" $ + it "inserts new records but does not update existing records if there are updates specified but the modification condition is not triggered" $ runConnAssert $ do let newItem = Item "item3" "hi friends!" Nothing Nothing deleteWhere ([] :: [Filter Item]) @@ -129,18 +132,46 @@ specs = describe "UpsertWhere" $ do (newItem : items) [] [ItemQuantity +=. Just 1] - [ItemDescription ==. "bye friends!"] + [excludeNotEqualToOriginal ItemDescription] dbItems <- sort . fmap entityVal <$> selectList [] [] dbItems @== sort (newItem : items) - it "inserts an item and excludes a field if it matches the filter" $ + it "inserts new records but does not update existing records if there are updates specified and the modification condition is not triggered" $ runConnAssert $ do - let newItem = Item "item3" "hello world" Nothing Nothing + let newItem = Item "item3" "hello world" Nothing Nothing deleteWhere ([] :: [Filter Item]) insertMany_ items upsertManyWhere (newItem : items) [] + [ItemQuantity +=. Just 1] + [excludeNotEqualToOriginal ItemDescription] + dbItems <- sort . fmap entityVal <$> selectList [] [] + dbItems @== sort (newItem : items) + it "inserts new records and updates existing records if there are updates specified and the modification filter condition is triggered" $ + runConnAssert $ do + let newItem = Item "item3" "hi friends!" Nothing Nothing + postUpdate = map (\i -> i {itemQuantity = fmap (+1) (itemQuantity i)}) items + deleteWhere ([] :: [Filter Item]) + insertMany_ items + upsertManyWhere + (newItem : items) + [ + copyUnlessEq ItemDescription "hi friends!" + , copyField ItemPrice + ] + [ItemQuantity +=. Just 1] + [ItemDescription !=. "bye friends!"] + dbItems <- sort . fmap entityVal <$> selectList [] [] + dbItems @== sort (newItem : postUpdate) + it "inserts an item and doesn't apply the update if the filter condition is triggered" $ + runConnAssert $ do + let newItem = Item "item3" "hello world" Nothing Nothing + deleteWhere ([] :: [Filter Item]) + insertMany_ items + upsertManyWhere + (newItem : items) [] + [ItemQuantity +=. Just 1] [excludeNotEqualToOriginal ItemDescription] dbItems <- sort . fmap entityVal <$> selectList [] [] dbItems @== sort (newItem : items) From cc750ec6edbbd20e1318c280dd1fe7f8958cb42f Mon Sep 17 00:00:00 2001 From: Dylan Martin Date: Wed, 7 Apr 2021 15:14:10 -0700 Subject: [PATCH 38/41] add an assertion to the mysql test --- persistent-mysql/test/InsertDuplicateUpdate.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/persistent-mysql/test/InsertDuplicateUpdate.hs b/persistent-mysql/test/InsertDuplicateUpdate.hs index 595d13b60..dbb3c7a9d 100644 --- a/persistent-mysql/test/InsertDuplicateUpdate.hs +++ b/persistent-mysql/test/InsertDuplicateUpdate.hs @@ -61,12 +61,15 @@ specs = describe "DuplicateKeyUpdate" $ do dbItems <- map entityVal <$> selectList [] [] sort dbItems @== sort (newItem : items) it "updates existing records" $ db $ do + let postUpdate = map (\i -> i { itemPrice = fmap (*2) (itemPrice i) }) items deleteWhere ([] :: [Filter Item]) insertMany_ items insertManyOnDuplicateKeyUpdate items [] [ItemQuantity +=. Just 1] + dbItems <- sort . fmap entityVal <$> selectList [] [] + dbItems @== sort postUpdate it "only copies passing values" $ db $ do deleteWhere ([] :: [Filter Item]) insertMany_ items From ae9d88a28ac3430319e2a23fee33479198bbedc1 Mon Sep 17 00:00:00 2001 From: Dylan Martin Date: Wed, 7 Apr 2021 15:33:16 -0700 Subject: [PATCH 39/41] ooops gotta update the mysql test to make it correct --- persistent-mysql/test/InsertDuplicateUpdate.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/persistent-mysql/test/InsertDuplicateUpdate.hs b/persistent-mysql/test/InsertDuplicateUpdate.hs index dbb3c7a9d..2a786ab17 100644 --- a/persistent-mysql/test/InsertDuplicateUpdate.hs +++ b/persistent-mysql/test/InsertDuplicateUpdate.hs @@ -61,7 +61,7 @@ specs = describe "DuplicateKeyUpdate" $ do dbItems <- map entityVal <$> selectList [] [] sort dbItems @== sort (newItem : items) it "updates existing records" $ db $ do - let postUpdate = map (\i -> i { itemPrice = fmap (*2) (itemPrice i) }) items + let postUpdate = map (\i -> i { itemPrice = fmap (+1) (itemPrice i) }) items deleteWhere ([] :: [Filter Item]) insertMany_ items insertManyOnDuplicateKeyUpdate From 4d5e689a567a4675c92042619981aa65be9ade54 Mon Sep 17 00:00:00 2001 From: Dylan Martin Date: Wed, 7 Apr 2021 15:56:03 -0700 Subject: [PATCH 40/41] omg DERP --- persistent-mysql/test/InsertDuplicateUpdate.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/persistent-mysql/test/InsertDuplicateUpdate.hs b/persistent-mysql/test/InsertDuplicateUpdate.hs index 2a786ab17..437120792 100644 --- a/persistent-mysql/test/InsertDuplicateUpdate.hs +++ b/persistent-mysql/test/InsertDuplicateUpdate.hs @@ -61,7 +61,7 @@ specs = describe "DuplicateKeyUpdate" $ do dbItems <- map entityVal <$> selectList [] [] sort dbItems @== sort (newItem : items) it "updates existing records" $ db $ do - let postUpdate = map (\i -> i { itemPrice = fmap (+1) (itemPrice i) }) items + let postUpdate = map (\i -> i { itemQuantity = fmap (+1) (itemQuantity i) }) items deleteWhere ([] :: [Filter Item]) insertMany_ items insertManyOnDuplicateKeyUpdate From b5b0c78d0805a0bdfb99bd3851429f5b2710df54 Mon Sep 17 00:00:00 2001 From: Dylan Martin Date: Wed, 7 Apr 2021 16:25:46 -0700 Subject: [PATCH 41/41] updating tests and also re-running CI --- persistent-postgresql/test/UpsertWhere.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/persistent-postgresql/test/UpsertWhere.hs b/persistent-postgresql/test/UpsertWhere.hs index 43fe1922d..626f83443 100644 --- a/persistent-postgresql/test/UpsertWhere.hs +++ b/persistent-postgresql/test/UpsertWhere.hs @@ -99,7 +99,7 @@ specs = describe "UpsertWhere" $ do [] dbItems <- sort . fmap entityVal <$> selectList [] [] dbItems @== sort (newItem : items) - it "inserts without modifying existing records if no updates specified and there's a filter" $ + it "inserts without modifying existing records if no updates specified and there's a filter with True condition" $ runConnAssert $ do let newItem = Item "item3" "hi friends!" Nothing Nothing deleteWhere ([] :: [Filter Item]) @@ -111,7 +111,7 @@ specs = describe "UpsertWhere" $ do [ItemDescription ==. "hi friends!"] dbItems <- sort . fmap entityVal <$> selectList [] [] dbItems @== sort (newItem : items) - it "inserts without modifying existing records if there are updates specified but there's a filter" $ + it "inserts without updating existing records if there are updates specified but there's a filter with a False condition" $ runConnAssert $ do let newItem = Item "item3" "hi friends!" Nothing Nothing deleteWhere ([] :: [Filter Item]) @@ -123,7 +123,7 @@ specs = describe "UpsertWhere" $ do [ItemDescription ==. "hi friends!"] dbItems <- sort . fmap entityVal <$> selectList [] [] dbItems @== sort (newItem : items) - it "inserts new records but does not update existing records if there are updates specified but the modification condition is not triggered" $ + it "inserts new records but does not update existing records if there are updates specified but the modification condition is False" $ runConnAssert $ do let newItem = Item "item3" "hi friends!" Nothing Nothing deleteWhere ([] :: [Filter Item]) @@ -135,18 +135,19 @@ specs = describe "UpsertWhere" $ do [excludeNotEqualToOriginal ItemDescription] dbItems <- sort . fmap entityVal <$> selectList [] [] dbItems @== sort (newItem : items) - it "inserts new records but does not update existing records if there are updates specified and the modification condition is not triggered" $ + it "inserts new records and updates existing records if there are updates specified and the modification condition is True (because it's empty)" $ runConnAssert $ do let newItem = Item "item3" "hello world" Nothing Nothing + postUpdate = map (\i -> i {itemQuantity = fmap (+ 1) (itemQuantity i)}) items deleteWhere ([] :: [Filter Item]) insertMany_ items upsertManyWhere (newItem : items) [] [ItemQuantity +=. Just 1] - [excludeNotEqualToOriginal ItemDescription] + [] dbItems <- sort . fmap entityVal <$> selectList [] [] - dbItems @== sort (newItem : items) + dbItems @== sort (newItem : postUpdate) it "inserts new records and updates existing records if there are updates specified and the modification filter condition is triggered" $ runConnAssert $ do let newItem = Item "item3" "hi friends!" Nothing Nothing