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

@@ -58,6 +58,7 @@ clean:
 	$(STACK) clean
 
 .PHONY: init-pgsql
+
 init-pgsql:
 	sudo -u postgres -- createuser -s esqutest
 

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

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

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,36 +290,70 @@ 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.
 --
 -- 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

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]

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