diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/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) diff --git a/Database/Persist/Postgresql.hs b/Database/Persist/Postgresql.hs --- a/Database/Persist/Postgresql.hs +++ b/Database/Persist/Postgresql.hs @@ -1,4 +1,8 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -6,7 +10,6 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -fno-warn-deprecations #-} -- Pattern match 'PersistDbSpecific' -- | A postgresql backend for persistent. module Database.Persist.Postgresql @@ -21,8 +24,16 @@ , createPostgresqlPoolWithConf , module Database.Persist.Sql , ConnectionString + , HandleUpdateCollision + , copyField + , copyUnlessNull + , copyUnlessEmpty + , copyUnlessEq + , excludeNotEqualToOriginal , PostgresConf (..) , PgInterval (..) + , upsertWhere + , upsertManyWhere , openSimpleConn , openSimpleConnWithVersion , tableName @@ -36,29 +47,29 @@ import qualified Database.PostgreSQL.LibPQ as LibPQ import qualified Database.PostgreSQL.Simple as PG -import qualified Database.PostgreSQL.Simple.Internal as PG import qualified Database.PostgreSQL.Simple.FromField as PGFF +import qualified Database.PostgreSQL.Simple.Internal as PG +import Database.PostgreSQL.Simple.Ok (Ok(..)) import qualified Database.PostgreSQL.Simple.ToField as PGTF import qualified Database.PostgreSQL.Simple.Transaction as PG -import qualified Database.PostgreSQL.Simple.Types as PG import qualified Database.PostgreSQL.Simple.TypeInfo.Static as PS -import Database.PostgreSQL.Simple.Ok (Ok (..)) +import qualified Database.PostgreSQL.Simple.Types as PG import Control.Arrow import Control.Exception (Exception, throw, throwIO) import Control.Monad import Control.Monad.Except -import Control.Monad.IO.Unlift (MonadIO (..), MonadUnliftIO) +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(..), asks, runReaderT) import Control.Monad.Trans.Writer (WriterT(..), runWriterT) import qualified Blaze.ByteString.Builder.Char8 as BBB import Data.Acquire (Acquire, mkAcquire, with) import Data.Aeson import Data.Aeson.Types (modifyFailure) -import qualified Data.Attoparsec.Text as AT import qualified Data.Attoparsec.ByteString.Char8 as P +import qualified Data.Attoparsec.Text as AT import Data.Bits ((.&.)) import Data.ByteString (ByteString) import qualified Data.ByteString.Builder as BB @@ -66,20 +77,21 @@ 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) +import Data.IORef import Data.Int (Int64) import qualified Data.IntMap as I -import Data.IORef -import Data.List (find, sort, groupBy, foldl') -import Data.List.NonEmpty (NonEmpty) +import Data.List (find, foldl', groupBy, sort) import qualified Data.List as List +import Data.List.NonEmpty (NonEmpty) 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) @@ -87,7 +99,7 @@ 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 Data.Time (NominalDiffTime, localTimeToUTC, utc) import System.Environment (getEnvironment) import Database.Persist.Sql @@ -397,7 +409,6 @@ ] ] - upsertSql' :: EntityDef -> NonEmpty (FieldNameHS, FieldNameDB) -> Text -> Text upsertSql' ent uniqs updateVal = T.concat @@ -1496,6 +1507,7 @@ escapeF :: FieldNameDB -> Text escapeF = escapeWith escape + escape :: Text -> Text escape s = T.pack $ '"' : go (T.unpack s) ++ "\"" @@ -1737,6 +1749,214 @@ where 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 diff --git a/persistent-postgresql.cabal b/persistent-postgresql.cabal --- a/persistent-postgresql.cabal +++ b/persistent-postgresql.cabal @@ -1,5 +1,5 @@ name: persistent-postgresql -version: 2.12.0.0 +version: 2.12.1.0 license: MIT license-file: LICENSE author: Felipe Lessa, Michael Snoyman @@ -16,7 +16,7 @@ library build-depends: base >= 4.9 && < 5 - , persistent >= 2.12 && < 3 + , persistent >= 2.12.1.0 && < 2.13 , aeson >= 1.0 , attoparsec , blaze-builder @@ -53,6 +53,7 @@ JSONTest CustomConstraintTest PgIntervalTest + UpsertWhere ghc-options: -Wall build-depends: base >= 4.9 && < 5 diff --git a/test/PgInit.hs b/test/PgInit.hs --- a/test/PgInit.hs +++ b/test/PgInit.hs @@ -56,7 +56,7 @@ 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) diff --git a/test/UpsertWhere.hs b/test/UpsertWhere.hs new file mode 100644 --- /dev/null +++ b/test/UpsertWhere.hs @@ -0,0 +1,178 @@ +{-# 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 "upsertWhereMigrate"] [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]) + 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 + 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) + 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]) + insertMany_ items + upsertManyWhere + (newItem : items) + [] + [] + [ItemDescription ==. "hi friends!"] + dbItems <- sort . fmap entityVal <$> selectList [] [] + dbItems @== sort (newItem : items) + 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]) + insertMany_ items + upsertManyWhere + (newItem : items) + [] + [ItemQuantity +=. Just 1] + [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 False" $ + runConnAssert $ do + let newItem = Item "item3" "hi friends!" 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 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] + [] + dbItems <- sort . fmap entityVal <$> selectList [] [] + 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 + 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) diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -51,6 +51,7 @@ 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 @@ , ForeignKey.compositeMigrate , MigrationTest.migrationMigrate , PgIntervalTest.pgIntervalMigrate + , UpsertWhere.upsertWhereMigrate ] PersistentTest.cleanDB ForeignKey.cleanDB @@ -195,6 +197,7 @@ 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