diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,36 @@ +# 0.7.0.0 + +## Interface changes + +* The legacy module-level `runInsertReturningList` and `runDeleteReturningList` + functions exported from `Database.Beam.Sqlite` (which run a + `SqliteInsertReturning` / `SqliteDeleteReturning` value) have been renamed + to `runSqliteInsertReturningList` and `runSqliteDeleteReturningList` to + avoid clashing with the `MonadBeamInsertReturning` / + `MonadBeamDeleteReturning` class methods of the same name. This matches + the existing `runSqliteUpdateReturningList`. +* `BeamSqlBackendHasSerial` for `Sqlite` is now polymorphic over the column + type via a new `IsSqliteSerialIntegerType` constraint, so `genericSerial` + can be used for any supported integer width rather than only `Int` (#534). + +## Added features + +* Added a `MonadBeamDeleteReturning Sqlite SqliteM` instance, allowing + `runDeleteReturningList` (and `runDeleteReturningListWith`) to be used + directly against `SqliteM` without going through the legacy + `SqliteDeleteReturning` builder. +* Implemented the new `runInsertReturningListWith` / + `runUpdateReturningListWith` / `runDeleteReturningListWith` class methods + on `SqliteM`, allowing callers to project a subset of columns from the + affected rows of an `INSERT` / `UPDATE` / `DELETE ... RETURNING` (#801). +* Implemented `weekField` for SQLite `EXTRACT`, mapped to + `strftime('%W', ...)`, in support of the new backend-agnostic `week_` + extract field from `beam-core`. + +## Updated dependencies + +* Bumped the lower bound on `beam-core` to `0.11`. + # 0.6.0.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 @@ -16,11 +16,11 @@ -- ** @INSERT ... RETURNING@ , SqliteInsertReturning - , insertReturning, insertOnConflictReturning, runInsertReturningList + , insertReturning, insertOnConflictReturning, runSqliteInsertReturningList -- ** @DELETE ... RETURNING@ , SqliteDeleteReturning - , deleteReturning, runDeleteReturningList + , deleteReturning, runSqliteDeleteReturningList -- ** @UPDATE ... RETURNING@ , SqliteUpdateReturning @@ -69,7 +69,7 @@ import Database.SQLite.Simple.Types (Null) import Control.Exception (SomeException(..)) -import Control.Monad (forM_) +import Control.Monad (forM, forM_) import Control.Monad.Base (MonadBase) import Control.Monad.Fail (MonadFail(..)) import Control.Monad.Free.Church @@ -194,7 +194,7 @@ field' _ _ nm ty _ collation constraints SqliteHasDefault = field' (Proxy @'True) (Proxy @'False) nm ty Nothing collation constraints -instance BeamSqlBackendHasSerial Sqlite where +instance (IsSqliteSerialIntegerType n) => BeamSqlBackendHasSerial n Sqlite where genericSerial nm = Beam.field nm (DataType sqliteSerialType) SqliteHasDefault -- | 'MonadBeam' instance inside which SQLite queries are run. See the @@ -386,21 +386,28 @@ go acc = f >>= maybe (pure acc) (\x -> go (x : acc)) instance Beam.MonadBeamInsertReturning Sqlite SqliteM where - runInsertReturningList SqlInsertNoRows = pure [] - runInsertReturningList (SqlInsert _ insertCommand) = runReturningList $ SqliteCommandInsert insertCommand + runInsertReturningListWith SqlInsertNoRows _ = pure [] + runInsertReturningListWith (SqlInsert tblSettings (SqliteInsertSyntax tbl fields values onConflict)) mkProjection = + fmap concat $ forM (sqliteGroupByDefaults fields values) $ \(fields', values') -> + runReturningList $ SqliteCommandSyntax $ + formatSqliteInsertOnConflict tbl fields' values' onConflict + <> returningClauseWithProjection tblSettings mkProjection -- | -- @since 0.6.0.0 instance Beam.MonadBeamUpdateReturning Sqlite SqliteM where - runUpdateReturningList :: forall table. ( - Beamable table, Projectible Sqlite (table (QExpr Sqlite ())), FromBackendRow Sqlite (table Identity) - ) => SqlUpdate Sqlite table -> SqliteM [table Identity] - runUpdateReturningList SqlIdentityUpdate = pure [] - runUpdateReturningList (SqlUpdate tblSettings sqliteUpdate) = + runUpdateReturningListWith SqlIdentityUpdate _ = pure [] + runUpdateReturningListWith (SqlUpdate tblSettings sqliteUpdate) mkProjection = runReturningList $ SqliteCommandSyntax $ fromSqliteUpdate sqliteUpdate - <> returningClauseWithProjection tblSettings (id :: table (QExpr Sqlite ()) -> table (QExpr Sqlite ())) + <> returningClauseWithProjection tblSettings mkProjection +instance Beam.MonadBeamDeleteReturning Sqlite SqliteM where + runDeleteReturningListWith (SqlDelete tblSettings sqliteDelete) mkProjection = + runReturningList $ SqliteCommandSyntax $ + fromSqliteDelete sqliteDelete + <> returningClauseWithProjection tblSettings mkProjection + newtype SqliteInsertReturning a = SqliteInsertReturning [SqliteSyntax] newtype SqliteDeleteReturning a = SqliteDeleteReturning SqliteSyntax newtype SqliteUpdateReturning a = SqliteUpdateReturning (Maybe SqliteSyntax) @@ -445,14 +452,14 @@ -- Preserve manually-written queries [(flds, orig)] -runDeleteReturningList +runSqliteDeleteReturningList :: ( MonadBeam be m , BeamSqlBackendSyntax be ~ SqliteCommandSyntax , FromBackendRow be a ) => SqliteDeleteReturning a -> m [a] -runDeleteReturningList (SqliteDeleteReturning syntax) = +runSqliteDeleteReturningList (SqliteDeleteReturning syntax) = runReturningList $ SqliteCommandSyntax syntax -- | SQLite @DELETE ... RETURNING@ statement support. The last @@ -549,14 +556,14 @@ -- | Runs a 'SqliteInsertReturning' statement and returns a result for each -- inserted row. -runInsertReturningList +runSqliteInsertReturningList :: ( MonadBeam be m , BeamSqlBackendSyntax be ~ SqliteCommandSyntax , FromBackendRow be a ) => SqliteInsertReturning a -> m [a] -runInsertReturningList (SqliteInsertReturning syntaxes) = +runSqliteInsertReturningList (SqliteInsertReturning syntaxes) = concat <$> traverse (\syntax -> runReturningList $ SqliteCommandSyntax syntax) syntaxes 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 @@ -971,6 +971,7 @@ ExtractFieldDateTimeYear -> extractStrftime "%Y" ExtractFieldDateTimeMonth -> extractStrftime "%m" ExtractFieldDateTimeDay -> extractStrftime "%d" + ExtractFieldDateTimeWeek -> extractStrftime "%W" ExtractFieldDateTimeHour -> extractStrftime "%H" ExtractFieldDateTimeMinute -> extractStrftime "%M" ExtractFieldDateTimeSecond -> extractStrftime "%S" 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.6.0.0 +version: 0.7.0.0 synopsis: Beam driver for SQLite description: Beam driver for the embedded database. See @@ -26,8 +26,8 @@ other-modules: Database.Beam.Sqlite.SqliteSpecific build-depends: base >=4.11 && <5, - beam-core >=0.10 && <0.11, - beam-migrate >=0.5.4.0 && <0.6, + beam-core >=0.11 && <0.12, + beam-migrate >=0.6 && <0.7, sqlite-simple >=0.4 && <0.5, containers >=0.6 && <0.9, 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 @@ -5,7 +5,7 @@ import Data.Time (LocalTime, Day(..), UTCTime(..), fromGregorian, getCurrentTime, secondsToDiffTime) import Database.Beam import Database.Beam.Backend.SQL.BeamExtensions -import Database.Beam.Sqlite hiding (runInsertReturningList) +import Database.Beam.Sqlite import Database.SQLite.Simple (execute_) import Test.Tasty import Test.Tasty.ExpectedFailure diff --git a/test/Database/Beam/Sqlite/Test/InsertOnConflictReturning.hs b/test/Database/Beam/Sqlite/Test/InsertOnConflictReturning.hs --- a/test/Database/Beam/Sqlite/Test/InsertOnConflictReturning.hs +++ b/test/Database/Beam/Sqlite/Test/InsertOnConflictReturning.hs @@ -8,6 +8,7 @@ import Data.Int (Int32) import Data.Text (Text) +import Database.Beam import Database.Beam ( Beamable, Columnar, @@ -31,26 +32,22 @@ insertOnConflict, onConflictUpdateSetWhere ), - MonadBeamInsertReturning (runInsertReturningList), - ) -import Database.Beam.Sqlite (Sqlite, runBeamSqlite) -import Database.Beam.Sqlite.Test (withTestDb) -import Database.SQLite.Simple (execute_) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (testCase, (@?=)) - -import Database.Beam -import Database.Beam.Backend.SQL.BeamExtensions ( conflictingFields, insertOnConflict, onConflictUpdateSetWhere, runInsertReturningList, + runInsertReturningListWith, ) import Database.Beam.Migrate (defaultMigratableDbSettings) import Database.Beam.Migrate.Simple (CheckedDatabaseSettings, autoMigrate) +import Database.Beam.Sqlite (Sqlite, runBeamSqlite) import Database.Beam.Sqlite (Sqlite, runBeamSqliteDebug) import Database.Beam.Sqlite.Migrate (migrationBackend) +import Database.Beam.Sqlite.Test (withTestDb) +import Database.SQLite.Simple (execute_) import Database.SQLite.Simple (open) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) tests :: TestTree tests = @@ -112,8 +109,8 @@ , User{userId = 2, userName = "different_user2"} ] - runInsertReturningList $ - insertOnConflict + runInsertReturningListWith + (insertOnConflict (usersTable testDb) (insertValues newUsers) (conflictingFields userId) @@ -126,7 +123,8 @@ (User{userName = excl}) -> current_ fld /=. excl ) - ) + )) + userId -- Expecting that the conflicting user, User id 2, is also returned - userId <$> conflicts @?= [1, 2] + conflicts @?= [1, 2] diff --git a/test/Database/Beam/Sqlite/Test/Returning.hs b/test/Database/Beam/Sqlite/Test/Returning.hs --- a/test/Database/Beam/Sqlite/Test/Returning.hs +++ b/test/Database/Beam/Sqlite/Test/Returning.hs @@ -15,21 +15,21 @@ import Database.Beam import Database.Beam.Backend.SQL.BeamExtensions - (conflictingFields, onConflictUpdateSet, onConflictUpdateSetWhere, runUpdateReturningList) + ( conflictingFields, onConflictUpdateSetWhere + , runInsertReturningListWith, runUpdateReturningListWith, runDeleteReturningListWith + ) import Database.Beam.Migrate (defaultMigratableDbSettings) import Database.Beam.Migrate.Simple (CheckedDatabaseSettings, autoMigrate) -import Database.Beam.Sqlite (Sqlite, runBeamSqlite, insertOnConflictReturning) +import Database.Beam.Sqlite ( + Sqlite, runBeamSqlite + , insertOnConflictReturning + , runSqliteInsertReturningList + , runSqliteUpdateReturningList + , runSqliteDeleteReturningList + ) +import qualified Database.Beam.Sqlite as Sqlite (deleteReturning, insertReturning, updateReturning) import Database.Beam.Sqlite.Migrate (migrationBackend) -import Database.Beam.Sqlite - ( deleteReturning - , insertReturning - , runDeleteReturningList - , runInsertReturningList - , runSqliteUpdateReturningList - , updateReturning - ) - import Database.Beam.Sqlite.Test (withTestDb) @@ -39,8 +39,11 @@ "SQLite RETURNING statement tests" [ testInsertOnConflictReturning , testSqliteUpdateReturning - , testUpdateReturning , testDeleteReturning + + , testClassInsertReturning + , testClassUpdateReturning + , testClassDeleteReturning ] -- | Database Schema Definition @@ -104,7 +107,7 @@ ] -- Run 'INSERT .. ON CONFLICT (id) DO UPDATE SET .. WHERE .. RETURNING ..' - runInsertReturningList $ + runSqliteInsertReturningList $ insertOnConflictReturning (usersTable testDb) (insertValues newUsers) @@ -144,7 +147,7 @@ -- Update user 2 and return projected columns from the updated row runSqliteUpdateReturningList $ - updateReturning + Sqlite.updateReturning (usersTable testDb) (\u -> userName u <-. val_ "updated_user2") (\u -> userId u ==. val_ 2) @@ -152,33 +155,6 @@ updatedUsers @?= [(2, "updated_user2", 22)] --- | Test @UPDATE ... RETURNING@ using MonadBeamUpdateReturning's runUpdateReturningList -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 $ - update - (usersTable testDb) - (\u -> userName u <-. val_ "updated_user2") - (\u -> userId u ==. val_ 2) - - - fmap (\u -> (userId u, userName u, userInfo2 u)) updatedUsers @?= [(2, "updated_user2", 22)] - -- | Test @DELETE .. RETURNING@ testDeleteReturning :: TestTree testDeleteReturning = testCase "DELETE .. RETURNING" $ @@ -197,10 +173,65 @@ ] -- Delete user 3 and return projected columns from the deleted row - runDeleteReturningList $ - deleteReturning + runSqliteDeleteReturningList $ + Sqlite.deleteReturning (usersTable testDb) (\u -> userId u ==. val_ 3) (\u -> (userName u, userInfo2 u)) deletedUsers @?= [("user3", 33)] + +-- | Test class-level @INSERT .. RETURNING@ with custom projection +testClassInsertReturning :: TestTree +testClassInsertReturning = testCase "Class INSERT .. RETURNING" $ + withTestDb $ \conn -> do + results <- + runBeamSqlite conn $ do + autoMigrate migrationBackend checkedDb + runInsertReturningListWith + (insert (usersTable testDb) $ + insertValues + [ User {userId = 1, userName = "user1", userInfo1 = "info1", userInfo2 = 11 } + , User {userId = 2, userName = "user2", userInfo1 = "info2", userInfo2 = 22 } + ]) + (\u -> (userId u, userName u)) + results @?= [(1, "user1"), (2, "user2")] + +-- | Test class-level @UPDATE .. RETURNING@ with custom projection +testClassUpdateReturning :: TestTree +testClassUpdateReturning = testCase "Class UPDATE .. RETURNING" $ + withTestDb $ \conn -> do + results <- + runBeamSqlite conn $ do + autoMigrate migrationBackend checkedDb + runInsert $ + insert (usersTable testDb) $ + insertValues + [ User {userId = 1, userName = "user1", userInfo1 = "info1", userInfo2 = 11 } + , User {userId = 2, userName = "user2", userInfo1 = "info2", userInfo2 = 22 } + ] + runUpdateReturningListWith + (update (usersTable testDb) + (\u -> userName u <-. val_ "updated") + (\u -> userId u ==. val_ 2)) + (\u -> (userId u, userName u)) + results @?= [(2, "updated")] + +-- | Test class-level @DELETE .. RETURNING@ with custom projection +testClassDeleteReturning :: TestTree +testClassDeleteReturning = testCase "Class DELETE .. RETURNING" $ + withTestDb $ \conn -> do + results <- + runBeamSqlite conn $ do + autoMigrate migrationBackend checkedDb + runInsert $ + insert (usersTable testDb) $ + insertValues + [ User {userId = 1, userName = "user1", userInfo1 = "info1", userInfo2 = 11 } + , User {userId = 2, userName = "user2", userInfo1 = "info2", userInfo2 = 22 } + ] + runDeleteReturningListWith + (delete (usersTable testDb) + (\u -> userId u ==. val_ 2)) + (\u -> (userName u, userInfo2 u)) + results @?= [("user2", 22)] diff --git a/test/Database/Beam/Sqlite/Test/Select.hs b/test/Database/Beam/Sqlite/Test/Select.hs --- a/test/Database/Beam/Sqlite/Test/Select.hs +++ b/test/Database/Beam/Sqlite/Test/Select.hs @@ -6,6 +6,7 @@ import Database.Beam import Database.Beam.Sqlite +import Data.List.NonEmpty (NonEmpty(..)) import Test.Tasty import Test.Tasty.ExpectedFailure import Test.Tasty.HUnit @@ -51,5 +52,5 @@ testExceptValues = testCase "EXCEPT with VALUES works" $ withTestDb $ \conn -> do result <- runBeamSqlite conn $ runSelectReturningList $ select $ - values_ [as_ @Bool $ val_ True, val_ False] `except_` values_ [val_ False] + values_ ((as_ @Bool $ val_ True) :| [val_ False]) `except_` values_ (val_ False :| []) assertEqual "result" [True] result