From 0f7b8744eb130c44f6d745f139063c8291e91e7a Mon Sep 17 00:00:00 2001 From: Matt Parsons Date: Fri, 27 Dec 2024 11:18:01 -0700 Subject: [PATCH] Support upsert with empty updates (#301) * Support upsert with empty updates * stylish, changelog link * clean * remove focus * oh no * update with new api * tests pass --- Makefile | 1 + changelog.md | 5 + esqueleto.cabal | 3 +- src/Database/Esqueleto/PostgreSQL.hs | 156 +++++++++++++++++++++------ stack-9.0.yaml | 3 +- test/Common/Test.hs | 3 + test/PostgreSQL/Test.hs | 100 +++++++++-------- test/Spec.hs | 1 - 8 files changed, 185 insertions(+), 87 deletions(-) diff --git a/Makefile b/Makefile index f0b35becc..7ac864507 100644 --- a/Makefile +++ b/Makefile @@ -58,6 +58,7 @@ clean: $(STACK) clean .PHONY: init-pgsql + init-pgsql: sudo -u postgres -- createuser -s esqutest diff --git a/changelog.md b/changelog.md index 83c1b6e9f..cab8173ea 100644 --- a/changelog.md +++ b/changelog.md @@ -1,6 +1,11 @@ 3.6.0.0 ======= - @parsonsmatt + - [#301](https://github.com/bitemyapp/esqueleto/pull/301) + - Postgresql `upsert` and `upsertBy` now require a `NonEmpty` list of + updates. If you want to provide an empty list of updates, you'll need + to use `upsertMaybe` and `upsertMaybeBe` instead. Postgres does not + return rows from the database if no updates are performed. - [#413](https://github.com/bitemyapp/esqueleto/pull/413) - The ability to `coerce` `SqlExpr` was removed. Instead, use `veryUnsafeCoerceSqlExpr`. See the documentation on diff --git a/esqueleto.cabal b/esqueleto.cabal index ec7a43b2e..d412e8512 100644 --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -1,7 +1,6 @@ cabal-version: 1.12 name: esqueleto - version: 3.6.0.0 synopsis: Type-safe EDSL for SQL queries on persistent backends. description: @esqueleto@ is a bare bones, type-safe EDSL for SQL queries that works with unmodified @persistent@ SQL backends. Its language closely resembles SQL, so you don't have to learn new concepts, just new syntax, and it's fairly easy to predict the generated SQL and optimize it for your backend. Most kinds of errors committed when writing SQL are caught as compile-time errors---although it is possible to write type-checked @esqueleto@ queries that fail at runtime. @@ -53,7 +52,7 @@ library hs-source-dirs: src/ build-depends: - base >=4.8 && <5.0 + base >=4.12 && <5.0 , aeson >=1.0 , attoparsec >= 0.13 && < 0.15 , blaze-html diff --git a/src/Database/Esqueleto/PostgreSQL.hs b/src/Database/Esqueleto/PostgreSQL.hs index 5bb4bde5c..5802fcb25 100644 --- a/src/Database/Esqueleto/PostgreSQL.hs +++ b/src/Database/Esqueleto/PostgreSQL.hs @@ -24,7 +24,9 @@ module Database.Esqueleto.PostgreSQL , now_ , random_ , upsert + , upsertMaybe , upsertBy + , upsertMaybeBy , insertSelectWithConflict , insertSelectWithConflictCount , noWait @@ -46,9 +48,6 @@ module Database.Esqueleto.PostgreSQL , unsafeSqlAggregateFunction ) where -#if __GLASGOW_HASKELL__ < 804 -import Data.Semigroup -#endif import Control.Arrow (first) import Control.Exception (throw) import Control.Monad (void) @@ -59,6 +58,7 @@ import Data.Int (Int64) import qualified Data.List.NonEmpty as NE import Data.Maybe import Data.Proxy (Proxy(..)) +import qualified Data.Text as Text import qualified Data.Text.Internal.Builder as TLB import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TLB @@ -73,6 +73,7 @@ import Database.Esqueleto.Internal.Internal hiding (From(..), from, on, random_) import Database.Esqueleto.Internal.PersistentImport hiding (uniqueFields, upsert, upsertBy) import Database.Persist.SqlBackend +import GHC.Stack -- | (@random()@) Split out into database specific modules -- because MySQL uses `rand()`. @@ -198,6 +199,15 @@ chr = unsafeSqlFunction "chr" now_ :: SqlExpr (Value UTCTime) now_ = unsafeSqlFunction "NOW" () +-- | Perform an @upsert@ operation on the given record. +-- +-- If the record exists in the database already, then the updates will be +-- performed on that record. If the record does not exist, then the +-- provided record will be inserted. +-- +-- If you wish to provide an empty list of updates (ie "if the record +-- exists, do nothing"), then you will need to call 'upsertMaybe'. Postgres +-- will not return anything if there are no modifications or inserts made. upsert :: ( MonadIO m @@ -208,17 +218,57 @@ upsert ) => record -- ^ new record to insert - -> [SqlExpr (Entity record) -> SqlExpr Update] + -> NE.NonEmpty (SqlExpr (Entity record) -> SqlExpr Update) -- ^ updates to perform if the record already exists -> R.ReaderT SqlBackend m (Entity record) -- ^ the record in the database after the operation -upsert record updates = do - uniqueKey <- onlyUnique record - upsertBy uniqueKey record updates +upsert record = + upsertBy (onlyUniqueP record) record -upsertBy +-- | Like 'upsert', but permits an empty list of updates to be performed. +-- +-- If no updates are provided and the record already was present in the +-- database, then this will return 'Nothing'. If you want to fetch the +-- record out of the database, you can write: +-- +-- @ +-- mresult <- upsertMaybe record [] +-- case mresult of +-- Nothing -> +-- 'getBy' ('onlyUniqueP' record) +-- Just res -> +-- pure (Just res) +-- @ +-- +-- @since 3.6.0.0 +upsertMaybe + :: + ( MonadIO m + , PersistEntity record + , OnlyOneUniqueKey record + , PersistRecordBackend record SqlBackend + , IsPersistBackend (PersistEntityBackend record) + ) + => record + -- ^ new record to insert + -> [SqlExpr (Entity record) -> SqlExpr Update] + -- ^ updates to perform if the record already exists + -> R.ReaderT SqlBackend m (Maybe (Entity record)) + -- ^ the record in the database after the operation +upsertMaybe rec upds = do + upsertMaybeBy (onlyUniqueP rec) rec upds + +-- | Attempt to insert a @record@ into the database. If the @record@ +-- already exists for the given @'Unique' record@, then a list of updates +-- will be performed. +-- +-- If you provide an empty list of updates, then this function will return +-- 'Nothing' if the record already exists in the database. +-- +-- @since 3.6.0.0 +upsertMaybeBy :: - (MonadIO m + ( MonadIO m , PersistEntity record , IsPersistBackend (PersistEntityBackend record) ) @@ -228,9 +278,9 @@ upsertBy -- ^ new record to insert -> [SqlExpr (Entity record) -> SqlExpr Update] -- ^ updates to perform if the record already exists - -> R.ReaderT SqlBackend m (Entity record) + -> R.ReaderT SqlBackend m (Maybe (Entity record)) -- ^ the record in the database after the operation -upsertBy uniqueKey record updates = do +upsertMaybeBy uniqueKey record updates = do sqlB <- R.ask case getConnUpsertSql sqlB of Nothing -> @@ -240,25 +290,62 @@ upsertBy uniqueKey record updates = do Just upsertSql -> handler sqlB upsertSql where - addVals l = map toPersistValue (toPersistFields record) ++ l ++ persistUniqueToValues uniqueKey - entDef = entityDef (Just record) - updatesText conn = first builderToText $ renderUpdates conn updates -#if MIN_VERSION_persistent(2,11,0) + addVals l = + map toPersistValue (toPersistFields record) ++ l ++ case updates of + [] -> + [] + _ -> + persistUniqueToValues uniqueKey + entDef = + entityDef (Just record) + updatesText conn = + first builderToText $ renderUpdates conn updates uniqueFields = persistUniqueToFieldNames uniqueKey handler sqlB upsertSql = do let (updateText, updateVals) = updatesText sqlB - queryText = + queryTextUnmodified = upsertSql entDef uniqueFields updateText + queryText = + case updates of + [] -> + let + (okay, _bad) = + Text.breakOn "DO UPDATE" queryTextUnmodified + good = + okay <> "DO NOTHING RETURNING ??" + in + good + _ -> + queryTextUnmodified + queryVals = addVals updateVals xs <- rawSql queryText queryVals - pure (head xs) -#else - uDef = toUniqueDef uniqueKey - handler conn f = fmap head $ uncurry rawSql $ - (***) (f entDef (uDef :| [])) addVals $ updatesText conn -#endif + pure (listToMaybe xs) + +upsertBy + :: + ( MonadIO m + , PersistEntity record + , IsPersistBackend (PersistEntityBackend record) + , HasCallStack + ) + => Unique record + -- ^ uniqueness constraint to find by + -> record + -- ^ new record to insert + -> NE.NonEmpty (SqlExpr (Entity record) -> SqlExpr Update) + -- ^ updates to perform if the record already exists + -> R.ReaderT SqlBackend m (Entity record) + -- ^ the record in the database after the operation +upsertBy uniqueKey record updates = do + mrec <- upsertMaybeBy uniqueKey record (NE.toList updates) + case mrec of + Nothing -> + error "non-empty list of updates should have resulted in a row being returned" + Just rec -> + pure rec -- | Inserts into a table the results of a query similar to 'insertSelect' but allows -- to update values that violate a constraint during insertions. @@ -266,10 +353,7 @@ upsertBy uniqueKey record updates = do -- Example of usage: -- -- @ --- share [ mkPersist sqlSettings --- , mkDeleteCascade sqlSettings --- , mkMigrate "migrate" --- ] [persistLowerCase| +-- 'mkPersist' 'sqlSettings' ['persistLowerCase'| -- Bar -- num Int -- deriving Eq Show @@ -279,17 +363,19 @@ upsertBy uniqueKey record updates = do -- deriving Eq Show -- |] -- --- insertSelectWithConflict --- UniqueFoo -- (UniqueFoo undefined) or (UniqueFoo anyNumber) would also work --- (from $ \b -> --- return $ Foo <# (b ^. BarNum) --- ) --- (\current excluded -> --- [FooNum =. (current ^. FooNum) +. (excluded ^. FooNum)] --- ) +-- action = do +-- 'insertSelectWithConflict' +-- UniqueFoo -- (UniqueFoo undefined) or (UniqueFoo anyNumber) would also work +-- (do +-- b <- from $ table \@Bar +-- return $ Foo <# (b ^. BarNum) +-- ) +-- (\\current excluded -> +-- [FooNum =. (current ^. FooNum) +. (excluded ^. FooNum)] +-- ) -- @ -- --- Inserts to table Foo all Bar.num values and in case of conflict SomeFooUnique, +-- Inserts to table @Foo@ all @Bar.num@ values and in case of conflict @SomeFooUnique@, -- the conflicting value is updated to the current plus the excluded. -- -- @since 3.1.3 diff --git a/stack-9.0.yaml b/stack-9.0.yaml index 49a504ea7..067a3735e 100644 --- a/stack-9.0.yaml +++ b/stack-9.0.yaml @@ -1,4 +1,4 @@ -resolver: lts-19.13 +resolver: lts-23.1 packages: - '.' @@ -8,7 +8,6 @@ allow-newer: true extra-deps: - lift-type-0.1.0.1 -- persistent-2.14.0.2 nix: packages: [zlib, libmysqlclient, pcre, postgresql] diff --git a/test/Common/Test.hs b/test/Common/Test.hs index 823b4c9a7..8db726301 100644 --- a/test/Common/Test.hs +++ b/test/Common/Test.hs @@ -65,6 +65,7 @@ module Common.Test , DateTruncTest(..) , DateTruncTestId , Key(..) + , assertJust ) where import Common.Test.Import hiding (from, on) @@ -2573,3 +2574,5 @@ testGetTable = pure (person, blogPost, profile, reply) asserting noExceptions +assertJust :: HasCallStack => Maybe a -> IO a +assertJust = maybe (expectationFailure "Expected Just, got Nothing" >> error "asdf") pure diff --git a/test/PostgreSQL/Test.hs b/test/PostgreSQL/Test.hs index 62c020051..8762e4be2 100644 --- a/test/PostgreSQL/Test.hs +++ b/test/PostgreSQL/Test.hs @@ -57,6 +57,38 @@ import Common.Test import Common.Test.Import hiding (from, on) import PostgreSQL.MigrateJSON +spec :: Spec +spec = beforeAll mkConnectionPool $ do + tests + + describe "PostgreSQL specific tests" $ do + testAscRandom random_ + testRandomMath + testSelectDistinctOn + testPostgresModule + testPostgresqlOneAscOneDesc + testPostgresqlTwoAscFields + testPostgresqlSum + testPostgresqlRandom + testPostgresqlUpdate + testPostgresqlCoalesce + testPostgresqlTextFunctions + testInsertUniqueViolation + testUpsert + testInsertSelectWithConflict + testFilterWhere + testCommonTableExpressions + setDatabaseState insertJsonValues cleanJSON + $ describe "PostgreSQL JSON tests" $ do + testJSONInsertions + testJSONOperators + testLateralQuery + testValuesExpression + testSubselectAliasingBehavior + testPostgresqlLocking + testPostgresqlNullsOrdering + + returningType :: forall a m . m a -> m a returningType a = a @@ -1044,18 +1076,29 @@ testInsertUniqueViolation = sqlErrorHint = ""} testUpsert :: SpecDb -testUpsert = - describe "Upsert test" $ do +testUpsert = describe "Upsert test" $ do itDb "Upsert can insert like normal" $ do - u1e <- EP.upsert u1 [OneUniqueName =. val "fifth"] - liftIO $ entityVal u1e `shouldBe` u1 + u1e <- EP.upsert u1 (pure (OneUniqueName =. val "fifth")) + liftIO $ entityVal u1e `shouldBe` u1 itDb "Upsert performs update on collision" $ do - u1e <- EP.upsert u1 [OneUniqueName =. val "fifth"] - liftIO $ entityVal u1e `shouldBe` u1 - u2e <- EP.upsert u2 [OneUniqueName =. val "fifth"] - liftIO $ entityVal u2e `shouldBe` u2 - u3e <- EP.upsert u3 [OneUniqueName =. val "fifth"] - liftIO $ entityVal u3e `shouldBe` u1{oneUniqueName="fifth"} + u1e <- EP.upsert u1 (pure (OneUniqueName =. val "fifth")) + liftIO $ entityVal u1e `shouldBe` u1 + u2e <- EP.upsert u2 (pure (OneUniqueName =. val "fifth")) + liftIO $ entityVal u2e `shouldBe` u2 + u3e <- EP.upsert u3 (pure (OneUniqueName =. val "fifth")) + liftIO $ entityVal u3e `shouldBe` u1{oneUniqueName="fifth"} + describe "With no updates" $ do + itDb "Works with no updates" $ do + _ <- EP.upsertMaybe u1 [] + pure () + itDb "Works with no updates, twice" $ do + mu1 <- EP.upsertMaybe u1 [] + Entity u1Key u1' <- liftIO $ assertJust mu1 + mu2 <- EP.upsertMaybe u1 { oneUniqueName = "Something Else" } [] + asserting $ do + mu2 `shouldBe` Nothing + -- liftIO $ do + -- u1 `shouldBe` u1' testInsertSelectWithConflict :: SpecDb testInsertSelectWithConflict = @@ -1730,43 +1773,6 @@ selectJSON f = select $ from $ \v -> do f $ just (v ^. JsonValue) return v ---------------- JSON --------------- JSON --------------- JSON --------------- ---------------- JSON --------------- JSON --------------- JSON --------------- ---------------- JSON --------------- JSON --------------- JSON --------------- - - - -spec :: Spec -spec = beforeAll mkConnectionPool $ do - tests - - describe "PostgreSQL specific tests" $ do - testAscRandom random_ - testRandomMath - testSelectDistinctOn - testPostgresModule - testPostgresqlOneAscOneDesc - testPostgresqlTwoAscFields - testPostgresqlSum - testPostgresqlRandom - testPostgresqlUpdate - testPostgresqlCoalesce - testPostgresqlTextFunctions - testInsertUniqueViolation - testUpsert - testInsertSelectWithConflict - testFilterWhere - testCommonTableExpressions - setDatabaseState insertJsonValues cleanJSON - $ describe "PostgreSQL JSON tests" $ do - testJSONInsertions - testJSONOperators - testLateralQuery - testValuesExpression - testSubselectAliasingBehavior - testPostgresqlLocking - testPostgresqlNullsOrdering - insertJsonValues :: SqlPersistT IO () insertJsonValues = do insertIt Null diff --git a/test/Spec.hs b/test/Spec.hs index f6201f104..8d0bcd9f7 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -19,4 +19,3 @@ spec = do sequential $ MySQL.spec describe "Postgresql" $ do sequential $ Postgres.spec -