adding upsertWhere and upsertManyWhere to persistent-postgresql

.github/workflows/haskell.yml

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

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:
 -- > +------+-------------+-------+----------+

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 { itemQuantity = fmap (+1) (itemQuantity 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

persistent-postgresql/ChangeLog.md

@@ -1,5 +1,9 @@
 # Changelog for persistent-postgresql
 
+## 2.12.1.0
+
+* 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)

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 #-}
@@ -21,8 +25,16 @@ module Database.Persist.Postgresql
     , createPostgresqlPoolWithConf
     , module Database.Persist.Sql
     , ConnectionString
+    , HandleUpdateCollision
+    , copyField
+    , copyUnlessNull
+    , copyUnlessEmpty
+    , copyUnlessEq
+    , excludeNotEqualToOriginal
     , PostgresConf (..)
     , PgInterval (..)
+    , upsertWhere
+    , upsertManyWhere
     , openSimpleConn
     , openSimpleConnWithVersion
     , tableName
@@ -50,7 +62,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, asks)
 import Control.Monad.Trans.Writer (WriterT(..), runWriterT)
 
 import qualified Blaze.ByteString.Builder.Char8 as BBB
@@ -66,7 +78,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)
@@ -80,6 +92,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)
@@ -397,7 +410,6 @@ insertSql' ent vals =
                 ]
         ]
 
-
 upsertSql' :: EntityDef -> NonEmpty (FieldNameHS, FieldNameDB) -> Text -> Text
 upsertSql' ent uniqs updateVal =
     T.concat
@@ -1496,6 +1508,7 @@ escapeE = escapeWith escape
 escapeF :: FieldNameDB -> Text
 escapeF = escapeWith escape
 
+
 escape :: Text -> Text
 escape s =
     T.pack $ '"' : go (T.unpack s) ++ "\""
@@ -1738,6 +1751,214 @@ 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 Postgres'
+-- @INSERT ... ON CONFLICT KEY UPDATE@ functionality, exposed via
+-- 'upsertWhere' and 'upsertManyWhere' in this library.
+--
+-- @since 2.12.1.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
+
+-- | Copy the field into the database only if the value in the
+-- corresponding record is non-@NULL@.
+--
+-- @since  2.12.1.0
+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
+-- 'upsertManyWhere' function.
+--
+-- @since  2.12.1.0
+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
+-- 'upsertMany' function.
+--
+-- @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.12.1.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,
+-- 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.1.0
+upsertWhere
+  :: ( backend ~ PersistEntityBackend record
+     , PersistEntity record
+     , PersistEntityBackend record ~ SqlBackend
+     , MonadIO m
+     , PersistStore backend
+     , BackendCompatible SqlBackend backend
+     )
+  => record
+  -> [Update record]
+  -> [Filter record]
+  -> ReaderT backend m ()
+upsertWhere record updates filts =
+  upsertManyWhere [record] [] updates filts
+
+-- | 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
+excludeNotEqualToOriginal 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,
+-- 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.1.0
+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] ->
+    -- | 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
+  uncurry rawExecute $
+    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
+-- 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] -- ^ A filter condition that dictates the scope of the updates
+    -> (Text, [PersistValue])
+mkBulkUpsertQuery records conn fieldValues updates filters =
+  (q, recordValues <> updsValues <> copyUnlessValues <> whereVals)
+  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 = 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
+    entityFieldNames = map fieldDbToText (entityFields 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
+    mkCondFieldSet n _ =
+      T.concat
+        [ n
+        , "=COALESCE("
+        ,   "NULLIF("
+        ,     "EXCLUDED."
+        ,       n
+        ,         ","
+        ,           "?"
+        ,         ")"
+        ,       ","
+        ,     nameOfTable
+        ,   "."
+        ,   n
+        ,")"
+        ]
+    condFieldSets = map (uncurry mkCondFieldSet) fieldsToMaybeCopy
+    fieldSets = map (\n -> T.concat [n, "=EXCLUDED.", n, ""]) updateFieldNames
+    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 PrefixTableName) conn filters)
+    updateText = case fieldSets <> upds <> condFieldSets of
+        [] -> T.concat [firstField, "=EXCLUDED.", firstField]
+        xs -> Util.commaSeparated xs
+    q = T.concat
+        [ "INSERT INTO "
+        , nameOfTable
+        , Util.parenWrapped . Util.commaSeparated $ entityFieldNames
+        , " VALUES "
+        , recordPlaceholders
+        , " ON CONFLICT "
+        , Util.parenWrapped $ Util.commaSeparated $ conflictColumns
+        , " DO UPDATE SET "
+        , updateText
+        , wher
+        ]
+
 putManySql' :: [Text] -> [FieldDef] -> EntityDef -> Int -> Text
 putManySql' conflictColumns (filter isFieldNotGenerated -> fields) ent n = q
   where

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?)

persistent-postgresql/persistent-postgresql.cabal

@@ -53,6 +53,7 @@ test-suite test
                      JSONTest
                      CustomConstraintTest
                      PgIntervalTest
+                     UpsertWhere
     ghc-options:     -Wall
 
     build-depends:   base                 >= 4.9 && < 5

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)