diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,10 @@ +# 0.5.6.0 + +## Performance optimizations + +* `insertReturning` / `deleteReturning` / `updateReturning` now generate optimal SQL queries, minimizing the number + of separate statements, by grouping similar statements in the presence of the `DEFAULT` keyword (#785). + # 0.5.5.0 ## Added features diff --git a/Database/Beam/Sqlite/Connection.hs b/Database/Beam/Sqlite/Connection.hs --- a/Database/Beam/Sqlite/Connection.hs +++ b/Database/Beam/Sqlite/Connection.hs @@ -4,6 +4,7 @@ {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeOperators #-} module Database.Beam.Sqlite.Connection ( Sqlite(..), SqliteM(..) @@ -11,7 +12,19 @@ , runBeamSqlite, runBeamSqliteDebug - , insertReturning, runInsertReturningList + -- * Support for @RETURNING@ with additional projection + + -- ** @INSERT ... RETURNING@ + , SqliteInsertReturning + , insertReturning, insertOnConflictReturning, runInsertReturningList + + -- ** @DELETE ... RETURNING@ + , SqliteDeleteReturning + , deleteReturning, runDeleteReturningList + + -- ** @UPDATE ... RETURNING@ + , SqliteUpdateReturning + , updateReturning, runUpdateReturningList ) where import Prelude hiding (fail) @@ -25,11 +38,13 @@ import qualified Database.Beam.Migrate.SQL as Beam import Database.Beam.Migrate.SQL.BeamExtensions import Database.Beam.Query ( SqlInsert(..), SqlInsertValues(..) + , SqlDelete(..) , HasQBuilder(..), HasSqlEqualityCheck , HasSqlQuantifiedEqualityCheck , DataType(..) , HasSqlInTable(..) - , insert, current_ ) + , QExprToIdentity + , insert, current_, delete, SqlUpdate (..), update ) import Database.Beam.Query.Internal import Database.Beam.Query.SQL92 import Database.Beam.Schema.Tables ( Beamable @@ -71,6 +86,9 @@ import qualified Data.DList as D import Data.Int import Data.IORef (newIORef, atomicModifyIORef') +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet +import qualified Data.List.NonEmpty as NE import Data.Maybe (mapMaybe) import Data.Proxy (Proxy(..)) import Data.Scientific (Scientific) @@ -80,6 +98,7 @@ import Data.Time ( LocalTime, UTCTime, Day , ZonedTime, utc, utcToLocalTime ) import Data.Typeable (cast) +import Data.Void (Void) import Data.Word import GHC.IORef (atomicModifyIORef'_) import GHC.TypeLits @@ -332,26 +351,15 @@ Nothing -> pure Nothing Just (BeamSqliteRow row) -> pure row runReaderT (runSqliteM (action nextRow')) (logger, conn) - runReturningMany (SqliteCommandInsert (SqliteInsertSyntax tbl fields vs onConflict)) action - | SqliteInsertExpressions es <- vs, any (any (== SqliteExpressionDefault)) es = - -- SQLite's handling of default values differs from other DBMses because - -- it lacks support for DEFAULT. In order to insert a default value in a column, - -- the column's name should be omitted from the INSERT statement. - -- - -- This is problematic if you insert multiple rows, some of which have defaults; - -- you must use multiple INSERT statements. This is what we do below. - -- - -- However, to respect the 'runReturningMany' interface, be must accumulate the - -- results of all those inserts into an 'IORef [a]', and then feed the results - -- incrementally to 'action'. + runReturningMany (SqliteCommandInsert (SqliteInsertSyntax tbl fields vs onConflict)) action = + -- The DEFAULT grouping happens at query construction time, so we just + -- handle the already-grouped statements here. SqliteM $ do (logger, conn) <- ask resultsRef <- liftIO (newIORef []) - forM_ es $ \row -> do - -- RETURNING is only supported by SQLite 3.35+, which requires direct-sqlite 2.3.27+ + forM_ (sqliteGroupByDefaults fields vs) $ \(fields', vs') -> do let returningClause = emit " RETURNING " <> commas (map quotedIdentifier fields) - (insertFields, insertRow) = unzip $ filter ((/= SqliteExpressionDefault) . snd) $ zip fields row - SqliteSyntax cmd vals = formatSqliteInsertOnConflict tbl insertFields (SqliteInsertExpressions [ insertRow ]) onConflict <> returningClause + SqliteSyntax cmd vals = formatSqliteInsertOnConflict tbl fields' vs' onConflict <> returningClause cmdString = BL.unpack (toLazyByteString (withPlaceholders cmd)) liftIO $ do @@ -369,21 +377,6 @@ (BeamSqliteRow h:rest) -> (rest, Just h) [] -> ([], Nothing) runSqliteM (action nextRow') - | otherwise = - SqliteM $ do - (logger, conn) <- ask - let returningClause = emit " RETURNING " <> commas (map quotedIdentifier fields) - SqliteSyntax cmd vals = formatSqliteInsertOnConflict tbl fields vs onConflict <> returningClause - cmdString = BL.unpack (toLazyByteString (withPlaceholders cmd)) - liftIO $ do - logger (cmdString ++ ";\n-- With values: " ++ show (D.toList vals)) - withStatement conn (fromString cmdString) $ \stmt -> - do bind stmt (BeamSqliteParams (D.toList vals)) - let nextRow' = liftIO (nextRow stmt) >>= \x -> - case x of - Nothing -> pure Nothing - Just (BeamSqliteRow row) -> pure row - runReaderT (runSqliteM (action nextRow')) (logger, conn) unfoldM :: Monad m => m (Maybe a) -> m [a] @@ -392,8 +385,89 @@ go acc = f >>= maybe (pure acc) (\x -> go (x : acc)) instance Beam.MonadBeamInsertReturning Sqlite SqliteM where - runInsertReturningList = runInsertReturningList + runInsertReturningList SqlInsertNoRows = pure [] + runInsertReturningList (SqlInsert _ insertCommand) = runReturningList $ SqliteCommandInsert insertCommand +newtype SqliteInsertReturning a = SqliteInsertReturning [SqliteSyntax] +newtype SqliteDeleteReturning a = SqliteDeleteReturning SqliteSyntax +newtype SqliteUpdateReturning a = SqliteUpdateReturning (Maybe SqliteSyntax) + +-- | SQLite cannot deal with DEFAULT in insertion. Instead, it expects these +-- fields to be omitted from the INSERT. +-- +-- This means that, for any given INSERT query, the row value being inserted +-- must have a fixed set of fields with DEFAULT value. +-- +-- This function groups the inserted values by the set of DEFAULT fields, so +-- that we can perform a separate INSERT for each set of DEFAULT fields. +sqliteGroupByDefaults :: [T.Text] -> SqliteInsertValuesSyntax -> [([T.Text], SqliteInsertValuesSyntax)] +sqliteGroupByDefaults flds (SqliteInsertExpressions es) = + let + partitionDefaultsFrom :: (IntSet, [SqliteExpressionSyntax]) -> Int -> [SqliteExpressionSyntax] -> (IntSet, [SqliteExpressionSyntax]) + partitionDefaultsFrom (dflts, acc) _ [] = (dflts, reverse acc) + partitionDefaultsFrom (dflts, acc) i (x:xs) + | x == SqliteExpressionDefault + = partitionDefaultsFrom (IntSet.insert i dflts, acc) (i + 1) xs + | otherwise + = partitionDefaultsFrom (dflts, x : acc) (i + 1) xs + + grouped :: [(IntSet, NE.NonEmpty [SqliteExpressionSyntax])] + grouped = + map (\xs -> (fst (NE.head xs), fmap snd xs)) $ + NE.groupBy (\(d1, _) (d2, _) -> d1 == d2) + [ partitionDefaultsFrom (IntSet.empty, []) 0 e + | e <- es + ] + + mkSyntax :: IntSet -> NE.NonEmpty [SqliteExpressionSyntax] -> ([T.Text], SqliteInsertValuesSyntax) + mkSyntax dflts xs = + ( [fld | (i, fld) <- zip [0..] flds + , not $ i `IntSet.member` dflts + ] + , SqliteInsertExpressions $ NE.toList xs + ) + in + map (uncurry mkSyntax) grouped +sqliteGroupByDefaults flds orig@(SqliteInsertFromSql {}) = + -- Preserve manually-written queries + [(flds, orig)] + +runDeleteReturningList + :: ( MonadBeam be m + , BeamSqlBackendSyntax be ~ SqliteCommandSyntax + , FromBackendRow be a + ) + => SqliteDeleteReturning a + -> m [a] +runDeleteReturningList (SqliteDeleteReturning syntax) = + runReturningList $ SqliteCommandSyntax syntax + +-- | SQLite @DELETE ... RETURNING@ statement support. The last +-- argument takes the deleted row and returns the values to be returned. +-- +-- Use 'runDeleteReturningList' to get the results. +deleteReturning :: forall a table be. Projectible Sqlite a + => DatabaseEntity Sqlite be (TableEntity table) + -- ^ table to delete from + -> (forall s. table (QExpr Sqlite s) -> QExpr Sqlite s Bool) + -- ^ predicate selecting rows to delete + -> (table (QExpr Sqlite Void) -> a) + -- ^ projection describing what to return + -> SqliteDeleteReturning (QExprToIdentity a) +deleteReturning table@(DatabaseEntity (DatabaseTable { dbTableSettings = tblSettings })) + mkWhere + mkProjection = + SqliteDeleteReturning $ + fromSqliteDelete sqliteDelete + <> + emit " RETURNING " <> commas (map fromSqliteExpression (project (Proxy @Sqlite) (mkProjection tblQ) "t")) + where + + SqlDelete _ sqliteDelete = delete table (\t -> mkWhere t) -- eta-expand for compatibility with shallow subsumption + tblQ = changeBeamRep getFieldName tblSettings + getFieldName (Columnar' fd) = + Columnar' $ QExpr $ pure $ fieldE (unqualifiedField (_fieldName fd)) + runSqliteInsert :: (String -> IO ()) -> Connection -> SqliteInsertSyntax -> IO () runSqliteInsert logger conn (SqliteInsertSyntax tbl fields vs onConflict) -- If all expressions are simple expressions (no default), then just @@ -411,23 +485,73 @@ logger (cmdString ++ ";\n-- With values: " ++ show (D.toList vals)) execute conn (fromString cmdString) (D.toList vals) --- * INSERT returning support - -- | Build a 'SqliteInsertReturning' representing inserting the given values --- into the given table. Use 'runInsertReturningList' +-- into the given table and returning all inserted rows. +-- +-- Use 'runInsertReturningList' to get the results. insertReturning :: Beamable table => DatabaseEntity Sqlite db (TableEntity table) + -- ^ table to insert into -> SqlInsertValues Sqlite (table (QExpr Sqlite s)) - -> SqlInsert Sqlite table -insertReturning = insert + -- ^ values/expressions to insert + -> SqliteInsertReturning (table Identity) +insertReturning table vals = + SqliteInsertReturning $ + case insert table vals of + SqlInsert _ (SqliteInsertSyntax tbl fields values onConflict) -> + [ formatSqliteInsertOnConflict tbl fields' values' onConflict <> + emit " RETURNING " <> commas (map quotedIdentifier fields) + | (fields', values') <- sqliteGroupByDefaults fields values + ] + SqlInsertNoRows -> [] +-- | SQLite @INSERT ... RETURNING@ statement support with conflict handling. +-- The last argument takes the newly inserted row and returns the values to be +-- returned. +-- +-- Use 'runInsertReturningList' to get the results. +insertOnConflictReturning + :: forall s a table db + . (Beamable table, Projectible Sqlite a) + => DatabaseEntity Sqlite db (TableEntity table) + -- ^ table to insert into + -> SqlInsertValues Sqlite (table (QExpr Sqlite s)) + -- ^ values/expressions to insert + -> Beam.SqlConflictTarget Sqlite table + -- ^ the target of the conflict (e.g. the row primary key) + -> Beam.SqlConflictAction Sqlite table + -- ^ what to do on conflict (e.g. nothing, override, etc) + -> (table (QExpr Sqlite Void) -> a) + -- ^ projection describing what to return + -> SqliteInsertReturning (QExprToIdentity a) +insertOnConflictReturning + table@(DatabaseEntity (DatabaseTable { dbTableSettings = tblSettings })) + vals tgt action mkProjection = + SqliteInsertReturning $ + case Beam.insertOnConflict table vals tgt action of + SqlInsert _ (SqliteInsertSyntax tbl fields values onConflict) -> + [ formatSqliteInsertOnConflict tbl fields' values' onConflict <> + emit " RETURNING " <> commas (map fromSqliteExpression (project (Proxy @Sqlite) (mkProjection tblQ) "t")) + | (fields', values') <- sqliteGroupByDefaults fields values + ] + SqlInsertNoRows -> [] + where + tblQ = changeBeamRep getFieldName tblSettings + getFieldName (Columnar' fd) = + Columnar' $ QExpr $ pure $ fieldE (unqualifiedField (_fieldName fd)) + -- | Runs a 'SqliteInsertReturning' statement and returns a result for each -- inserted row. -runInsertReturningList :: (Beamable table, FromBackendRow Sqlite (table Identity)) - => SqlInsert Sqlite table - -> SqliteM [ table Identity ] -runInsertReturningList SqlInsertNoRows = pure [] -runInsertReturningList (SqlInsert _ insertCommand) = runReturningList $ SqliteCommandInsert insertCommand +runInsertReturningList + :: ( MonadBeam be m + , BeamSqlBackendSyntax be ~ SqliteCommandSyntax + , FromBackendRow be a + ) + => SqliteInsertReturning a + -> m [a] +runInsertReturningList (SqliteInsertReturning syntaxes) = + concat <$> + traverse (\syntax -> runReturningList $ SqliteCommandSyntax syntax) syntaxes instance Beam.BeamHasInsertOnConflict Sqlite where newtype SqlConflictTarget Sqlite table = SqliteConflictTarget @@ -508,3 +632,45 @@ excluded table = changeBeamRep excludedField table where excludedField (Columnar' (QField _ _ name)) = Columnar' $ QExpr $ const $ fieldE $ qualifiedField "excluded" name + +-- | Use in conjunction with 'updateReturning'. +runUpdateReturningList + :: ( MonadBeam be m + , BeamSqlBackendSyntax be ~ SqliteCommandSyntax + , FromBackendRow be a + ) + => SqliteUpdateReturning a + -> m [a] +runUpdateReturningList (SqliteUpdateReturning Nothing) = pure [] +runUpdateReturningList (SqliteUpdateReturning (Just syntax)) = + runReturningList $ SqliteCommandSyntax syntax + +-- | SQLite @UPDATE ... RETURNING@ statement support. The last +-- argument takes the updated row and returns the values to be returned. +-- +-- Use 'runUpdateReturningList' to get the results. +updateReturning :: forall a table db. Projectible Sqlite a + => DatabaseEntity Sqlite db (TableEntity table) + -- ^ table to update + -> (forall s. table (QField s) -> QAssignment Sqlite s) + -- ^ assignment for the update + -> (forall s. table (QExpr Sqlite s) -> QExpr Sqlite s Bool) + -- ^ predicate selecting rows to update + -> (table (QExpr Sqlite Void) -> a) + -- ^ projection describing what to return + -> SqliteUpdateReturning (QExprToIdentity a) +updateReturning table@(DatabaseEntity (DatabaseTable { dbTableSettings = tblSettings })) + mkAssignments + mkWhere + mkProjection = + SqliteUpdateReturning $ + case update table mkAssignments mkWhere of + SqlIdentityUpdate -> Nothing + SqlUpdate _ sqliteUpdate -> + Just $ fromSqliteUpdate sqliteUpdate + <> emit " RETURNING " + <> commas (map fromSqliteExpression (project (Proxy @Sqlite) (mkProjection tblQ) "t")) + where + tblQ = changeBeamRep getFieldName tblSettings + getFieldName (Columnar' fd) = + Columnar' $ QExpr $ pure $ fieldE (unqualifiedField (_fieldName fd)) diff --git a/Database/Beam/Sqlite/Syntax.hs b/Database/Beam/Sqlite/Syntax.hs --- a/Database/Beam/Sqlite/Syntax.hs +++ b/Database/Beam/Sqlite/Syntax.hs @@ -133,7 +133,7 @@ -- | Convert the first argument of 'SQLiteSyntax' to a 'ByteString' 'Builder', -- where all the data has been replaced by @"?"@ placeholders. withPlaceholders :: ((SQLData -> Builder) -> Builder) -> Builder -withPlaceholders build = build (\_ -> "?") +withPlaceholders build = build (const "?") -- | Embed a 'ByteString' directly in the syntax emit :: ByteString -> SqliteSyntax diff --git a/beam-sqlite.cabal b/beam-sqlite.cabal --- a/beam-sqlite.cabal +++ b/beam-sqlite.cabal @@ -1,5 +1,5 @@ name: beam-sqlite -version: 0.5.5.0 +version: 0.5.6.0 synopsis: Beam driver for SQLite description: Beam driver for the embedded database. See @@ -14,7 +14,7 @@ build-type: Simple extra-source-files: README.md extra-doc-files: ChangeLog.md -bug-reports: https://github.com/haskell-beam/beam/issues +bug-reports: https://github.com/haskell-beam/beam/issues cabal-version: 1.18 library @@ -29,6 +29,7 @@ beam-migrate >=0.5.3.2 && <0.6, sqlite-simple >=0.4 && <0.5, + containers >=0.6 && <0.9, text >=1.0 && <2.2, bytestring >=0.10 && <0.13, hashable >=1.2 && <1.6, @@ -76,6 +77,7 @@ Database.Beam.Sqlite.Test.Insert Database.Beam.Sqlite.Test.InsertOnConflictReturning Database.Beam.Sqlite.Test.Migrate + Database.Beam.Sqlite.Test.Returning Database.Beam.Sqlite.Test.Select default-language: Haskell2010 default-extensions: diff --git a/test/Database/Beam/Sqlite/Test/Insert.hs b/test/Database/Beam/Sqlite/Test/Insert.hs --- a/test/Database/Beam/Sqlite/Test/Insert.hs +++ b/test/Database/Beam/Sqlite/Test/Insert.hs @@ -18,6 +18,7 @@ [ testInsertReturningColumnOrder , testInsertOnlyDefaults , expectFail testUpsertOnlyDefaults + , testInsertSomeDefaults ] data TestTableT f @@ -67,7 +68,7 @@ , TestTable 1 "sally" "apple" 33 dateJoined oneUtcTime , TestTable 4 "blah" "blah" (-1) dateJoined now ] - assertEqual "insert values" inserted expected + assertEqual "insert values" expected inserted data WithDefaultsT f = WithDefaults { _id :: C f (SqlSerial Int32) @@ -99,10 +100,11 @@ [ WithDefaults default_ default_ , WithDefaults default_ $ val_ "other" ] - assertEqual "inserted values" inserted + assertEqual "inserted values" [ WithDefaults 1 "unknown" , WithDefaults 2 "other" ] + inserted testUpsertOnlyDefaults :: TestTree testUpsertOnlyDefaults = testCase "upsert only default values" $ @@ -117,7 +119,55 @@ ) anyConflict onConflictDoNothing - assertEqual "inserted values" inserted + assertEqual "inserted values" [ WithDefaults 1 "unknown" , WithDefaults 2 "other" ] + inserted + + +data MixTableT f + = MixTable + { mtId :: C f (SqlSerial Int32) + , mtField1 :: C f Int32 + , mtField2 :: C f Int32 + , mtField3 :: C f Int32 + } deriving (Generic, Beamable) + +deriving instance Show (MixTableT Identity) +deriving instance Eq (MixTableT Identity) + +instance Table MixTableT where + data PrimaryKey MixTableT f = MixTableKey (C f (SqlSerial Int32)) + deriving (Generic, Beamable) + primaryKey (MixTable { mtId = i }) = MixTableKey i + +data MixTableDb entity + = MixTableDb + { dbMixTable :: entity (TableEntity MixTableT) + } deriving (Generic, Database Sqlite) + +mixDatabase :: DatabaseSettings be MixTableDb +mixDatabase = defaultDbSettings + +-- | Test grouping logic for queries containing different DEFAULT column layouts. +testInsertSomeDefaults :: TestTree +testInsertSomeDefaults = testCase "insert mix of default values" $ do + withTestDb $ \conn -> do + execute_ conn "CREATE TABLE mix_table ( id INTEGER PRIMARY KEY AUTOINCREMENT, field1 INT DEFAULT 11, field2 INT DEFAULT 22, field3 INT DEFAULT 33)" + inserted <- + runBeamSqlite conn $ runInsertReturningList $ + insert (dbMixTable mixDatabase) $ + insertExpressions [ MixTable default_ default_ 1001 10001 + , MixTable 202 2 default_ default_ + , MixTable 303 3 default_ default_ + , MixTable default_ default_ 4004 40004 + ] + + let expected = [ MixTable 1 11 1001 10001 + , MixTable 202 2 22 33 + , MixTable 303 3 22 33 + , MixTable 304 11 4004 40004 + ] + + assertEqual "insert values" expected inserted diff --git a/test/Database/Beam/Sqlite/Test/Returning.hs b/test/Database/Beam/Sqlite/Test/Returning.hs new file mode 100644 --- /dev/null +++ b/test/Database/Beam/Sqlite/Test/Returning.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Database.Beam.Sqlite.Test.Returning (tests) where + +import Data.Int (Int32) +import Data.Text (Text) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) + +import Database.Beam +import Database.Beam.Backend.SQL.BeamExtensions + (conflictingFields, onConflictUpdateSet, onConflictUpdateSetWhere) +import Database.Beam.Migrate (defaultMigratableDbSettings) +import Database.Beam.Migrate.Simple (CheckedDatabaseSettings, autoMigrate) +import Database.Beam.Sqlite (Sqlite, runBeamSqlite, insertOnConflictReturning) +import Database.Beam.Sqlite.Migrate (migrationBackend) + +import Database.Beam.Sqlite + ( deleteReturning + , insertReturning + , runDeleteReturningList + , runInsertReturningList + , runUpdateReturningList + , updateReturning + ) + +import Database.Beam.Sqlite.Test (withTestDb) + + +tests :: TestTree +tests = + testGroup + "SQLite RETURNING statement tests" + [ testInsertOnConflictReturning + , testUpdateReturning + , testDeleteReturning + ] + +-- | Database Schema Definition +data TestDb f + = TestDb + { usersTable :: f (TableEntity User) + } + deriving stock (Generic) + +deriving anyclass instance Database be TestDb + +testDb :: DatabaseSettings be TestDb +testDb = defaultDbSettings + +checkedDb :: CheckedDatabaseSettings Sqlite TestDb +checkedDb = defaultMigratableDbSettings + +data User f + = User + { userId :: !( Columnar f Int32 ) + , userName :: !( Columnar f Text ) + , userInfo1 :: !( Columnar f Text ) + , userInfo2 :: !( Columnar f Int32 ) + } + deriving stock (Generic) +deriving stock instance (Eq (Columnar f Int32), Eq (Columnar f Text)) => Eq (User f) +deriving stock instance (Show (Columnar f Int32), Show (Columnar f Text)) => Show (User f) + +instance Table User where + newtype PrimaryKey User f = UserId (Columnar f Int32) + deriving stock (Generic) + primaryKey = UserId . userId + +deriving anyclass instance Beamable User +deriving anyclass instance Beamable (PrimaryKey User) + +-- | Test @INSERT .. ON CONFLICT .. RETURNING@ +testInsertOnConflictReturning :: TestTree +testInsertOnConflictReturning = testCase "INSERT .. ON CONFLICT .. RETURNING" $ + withTestDb $ \conn -> do + results <- + runBeamSqlite conn $ do + autoMigrate migrationBackend checkedDb + + -- Seed data + runInsert $ + insert + (usersTable testDb) + $ insertValues + [ User {userId = 1, userName = "initial_user1", userInfo1 = "user1Info", userInfo2 = 11 } + , User {userId = 3, userName = "initial_user3", userInfo1 = "user3Info", userInfo2 = 33 } + , User {userId = 4, userName = "initial_user4", userInfo1 = "user4Info", userInfo2 = 44 } + ] + + let + newUsers = + [ User {userId = 1, userName = "upserted_user1", userInfo1 = "user1Info2", userInfo2 = 111 } + , User {userId = 2, userName = "new_user2" , userInfo1 = "info1" , userInfo2 = 222 } + , User {userId = 3, userName = "upserted_user3", userInfo1 = "info1b" , userInfo2 = 333 } + , User {userId = 4, userName = "not_upserted_4", userInfo1 = "ignore" , userInfo2 = 444 } + ] + + -- Run 'INSERT .. ON CONFLICT (id) DO UPDATE SET .. WHERE .. RETURNING ..' + runInsertReturningList $ + insertOnConflictReturning + (usersTable testDb) + (insertValues newUsers) + (conflictingFields userId) + (onConflictUpdateSetWhere + ( \(User{userName = fld}) (User{userName = excl}) -> + fld <-. excl + ) + ( \(User{userName = fld}) (User{userName = excl, userInfo1 = exclInfo1 }) -> + (current_ fld /=. excl) &&. (exclInfo1 /=. "ignore") + ) + ) + (\u -> (userId u, userName u, userInfo2 u)) + + results @?= + [ (1, "upserted_user1", 11) + , (2, "new_user2" , 222) + , (3, "upserted_user3", 33) + ] + +-- | Test @UPDATE ... RETURNING@ +testUpdateReturning :: TestTree +testUpdateReturning = testCase "UPDATE .. RETURNING" $ + withTestDb $ \conn -> do + updatedUsers <- + runBeamSqlite conn $ do + autoMigrate migrationBackend checkedDb + + -- Seed data + runInsert $ + insert (usersTable testDb) $ + insertValues + [ User {userId = 1, userName = "user1", userInfo1 = "user1Info1", userInfo2 = 11 } + , User {userId = 2, userName = "user2", userInfo1 = "user2Info1", userInfo2 = 22 } + , User {userId = 3, userName = "user3", userInfo1 = "user3Info1", userInfo2 = 33 } + ] + + -- Update user 2 and return projected columns from the updated row + runUpdateReturningList $ + updateReturning + (usersTable testDb) + (\u -> userName u <-. val_ "updated_user2") + (\u -> userId u ==. val_ 2) + (\u -> (userId u, userName u, userInfo2 u)) + + updatedUsers @?= [(2, "updated_user2", 22)] + +-- | Test @DELETE .. RETURNING@ +testDeleteReturning :: TestTree +testDeleteReturning = testCase "DELETE .. RETURNING" $ + withTestDb $ \conn -> do + deletedUsers <- + runBeamSqlite conn $ do + autoMigrate migrationBackend checkedDb + + -- Seed data + runInsert $ + insert (usersTable testDb) $ + insertValues + [ User { userId = 1, userName = "user1", userInfo1 = "user1Info1", userInfo2 = 11 } + , User { userId = 2, userName = "user2", userInfo1 = "user2Info1", userInfo2 = 22 } + , User { userId = 3, userName = "user3", userInfo1 = "user3Info1", userInfo2 = 33 } + ] + + -- Delete user 3 and return projected columns from the deleted row + runDeleteReturningList $ + deleteReturning + (usersTable testDb) + (\u -> userId u ==. val_ 3) + (\u -> (userName u, userInfo2 u)) + + deletedUsers @?= [("user3", 33)] diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -6,6 +6,7 @@ import qualified Database.Beam.Sqlite.Test.Insert as Insert import qualified Database.Beam.Sqlite.Test.InsertOnConflictReturning as InsertOnConflictReturning import qualified Database.Beam.Sqlite.Test.Select as Select +import qualified Database.Beam.Sqlite.Test.Returning as Returning main :: IO () main = defaultMain $ testGroup "beam-sqlite tests" @@ -13,4 +14,5 @@ , Select.tests , Insert.tests , InsertOnConflictReturning.tests + , Returning.tests ]