diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,20 @@ +# 0.6.0.0 + +## Added features + +* `SqliteM` now supports `runUpdateReturningList` via a `MonadBeamUpdateReturning` instance. The type is almost identical, + but not quite, as the `runUpdateReturningList` function from previous releases. Instead, `runUpdateReturningList` has been + renamed `runSqliteUpdateReturningList`. + +* Support for temporary tables. + +* `getDbConstraints` now discovers foreign key constraints via `PRAGMA foreign_key_list`, including `ON DELETE` / `ON UPDATE` actions. + +## Bug fixes + +* The SQLite migration framework no longer incorrectly concludes a migration + would lose data due to the presence of internal `sqlite_*` tables. + # 0.5.7.0 ## Added features diff --git a/Database/Beam/Sqlite.hs b/Database/Beam/Sqlite.hs --- a/Database/Beam/Sqlite.hs +++ b/Database/Beam/Sqlite.hs @@ -1,6 +1,7 @@ module Database.Beam.Sqlite ( module Database.Beam.Sqlite.Connection , module Database.Beam.Sqlite.Migrate + , module Database.Beam.Sqlite.TempTable -- * SQLite syntaxes , SqliteCommandSyntax(..), SqliteSyntax @@ -19,3 +20,4 @@ import Database.Beam.Sqlite.SqliteSpecific import Database.Beam.Sqlite.Connection import Database.Beam.Sqlite.Migrate (sqliteText, sqliteBlob, sqliteBigInt) +import Database.Beam.Sqlite.TempTable 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 @@ -24,7 +24,7 @@ -- ** @UPDATE ... RETURNING@ , SqliteUpdateReturning - , updateReturning, runUpdateReturningList + , updateReturning, runSqliteUpdateReturningList ) where import Prelude hiding (fail) @@ -53,6 +53,7 @@ , DatabaseEntityDescriptor(..) , TableEntity , TableField(..) + , TableSettings , changeBeamRep ) import Database.Beam.Sqlite.Syntax @@ -388,6 +389,18 @@ runInsertReturningList SqlInsertNoRows = pure [] runInsertReturningList (SqlInsert _ insertCommand) = runReturningList $ SqliteCommandInsert insertCommand +-- | +-- @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) = + runReturningList $ SqliteCommandSyntax $ + fromSqliteUpdate sqliteUpdate + <> returningClauseWithProjection tblSettings (id :: table (QExpr Sqlite ()) -> table (QExpr Sqlite ())) + newtype SqliteInsertReturning a = SqliteInsertReturning [SqliteSyntax] newtype SqliteDeleteReturning a = SqliteDeleteReturning SqliteSyntax newtype SqliteUpdateReturning a = SqliteUpdateReturning (Maybe SqliteSyntax) @@ -458,15 +471,9 @@ mkWhere mkProjection = SqliteDeleteReturning $ - fromSqliteDelete sqliteDelete - <> - emit " RETURNING " <> commas (map fromSqliteExpression (project (Proxy @Sqlite) (mkProjection tblQ) "t")) + fromSqliteDelete sqliteDelete <> returningClauseWithProjection tblSettings mkProjection 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) @@ -634,21 +641,23 @@ Columnar' $ QExpr $ const $ fieldE $ qualifiedField "excluded" name -- | Use in conjunction with 'updateReturning'. -runUpdateReturningList +-- +-- @since 0.6.0.0 +runSqliteUpdateReturningList :: ( MonadBeam be m , BeamSqlBackendSyntax be ~ SqliteCommandSyntax , FromBackendRow be a ) => SqliteUpdateReturning a -> m [a] -runUpdateReturningList (SqliteUpdateReturning Nothing) = pure [] -runUpdateReturningList (SqliteUpdateReturning (Just syntax)) = +runSqliteUpdateReturningList (SqliteUpdateReturning Nothing) = pure [] +runSqliteUpdateReturningList (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. +-- Use 'runSqliteUpdateReturningList' to get the results. updateReturning :: forall a table db. Projectible Sqlite a => DatabaseEntity Sqlite db (TableEntity table) -- ^ table to update @@ -667,10 +676,14 @@ case update table mkAssignments mkWhere of SqlIdentityUpdate -> Nothing SqlUpdate _ sqliteUpdate -> - Just $ fromSqliteUpdate sqliteUpdate - <> emit " RETURNING " - <> commas (map fromSqliteExpression (project (Proxy @Sqlite) (mkProjection tblQ) "t")) + Just $ fromSqliteUpdate sqliteUpdate <> returningClauseWithProjection tblSettings mkProjection + +-- | Build a SQLite @RETURNING@ clause from table settings and a projection. +returningClauseWithProjection :: (Beamable table, Projectible Sqlite a) => TableSettings table -> (table (QExpr Sqlite s) -> a) -> SqliteSyntax +returningClauseWithProjection tblSettings mkProjection = + emit " RETURNING " <> commas (map fromSqliteExpression (project (Proxy @Sqlite) (mkProjection (tableFieldExprs tblSettings)) "t")) where - tblQ = changeBeamRep getFieldName tblSettings - getFieldName (Columnar' fd) = - Columnar' $ QExpr $ pure $ fieldE (unqualifiedField (_fieldName fd)) + -- | Build column expressions from table settings, for use in @RETURNING@ clauses. + tableFieldExprs :: Beamable table => TableSettings table -> table (QExpr Sqlite s) + tableFieldExprs = changeBeamRep (\(Columnar' fd) -> + Columnar' $ QExpr $ pure $ fieldE (unqualifiedField (_fieldName fd))) diff --git a/Database/Beam/Sqlite/Migrate.hs b/Database/Beam/Sqlite/Migrate.hs --- a/Database/Beam/Sqlite/Migrate.hs +++ b/Database/Beam/Sqlite/Migrate.hs @@ -40,9 +40,10 @@ import qualified Data.ByteString.Lazy.Char8 as BL import Data.Char (isSpace) import Data.Int (Int64) -import Data.List (sortBy) +import Data.List (sortBy, groupBy) import qualified Data.List.NonEmpty as NE (nonEmpty) import Data.Maybe (mapMaybe, isJust) +import Data.Function (on) import Data.Monoid (Endo(..)) import Data.Ord (comparing) import Data.String (fromString) @@ -262,8 +263,6 @@ let hdl = connectionHandle conn in exec hdl t --- TODO constraints and foreign keys - -- | Get a list of database predicates for the current database. This is beam's -- best guess at providing a schema for the current database. Note that SQLite -- type names are not standardized, and the so-called column "affinities" are @@ -275,7 +274,20 @@ getDbConstraints :: A.Parser SqliteDataTypeSyntax -> SqliteM [Db.SomeDatabasePredicate] getDbConstraints extraParser = SqliteM . ReaderT $ \(_, conn) -> do - tblNames <- query_ conn "SELECT name, sql from sqlite_master where type='table'" + -- Exclude SQLite-internal tables (sqlite_sequence, sqlite_stat1, etc.). + -- These are created automatically by SQLite (e.g. sqlite_sequence appears + -- whenever any table uses AUTOINCREMENT). + -- + -- Failing to filter them out would mean we would try to drop them, which + -- would incorrectly look like data loss. + -- + -- NB: (https://www.sqlite.org/lang_createtable.html) + -- + -- Table names that begin with "sqlite_" are reserved for internal use. + -- It is an error to attempt to create a table with a name that starts with "sqlite_". + tblNames <- + query_ conn + "SELECT name, sql FROM sqlite_master WHERE type='table' AND name NOT LIKE 'sqlite\\_%' ESCAPE '\\'" tblPreds <- fmap mconcat . forM tblNames $ \(tblNameStr, sql) -> do let tblName = QualifiedName Nothing tblNameStr @@ -348,10 +360,43 @@ [ Db.SomeDatabasePredicate (Db.TableHasIndex @Sqlite tblName idxNm colsNE opts) ] + -- Collect foreign key constraints via PRAGMA foreign_key_list. + -- Each row: (id, seq, table, from, to, on_update, on_delete, match) + -- Rows sharing the same 'id' form a composite foreign key, + -- with 'seq' providing the ordering. + fkRows <- query_ conn (fromString ("PRAGMA foreign_key_list('" <> T.unpack tblNameStr <> "')") + ) :: IO [(Int, Int, T.Text, T.Text, T.Text, T.Text, T.Text, T.Text)] + let fkPreds = + concatMap mkFkPred $ + groupBy ((==) `on` (\(fkId, _, _, _, _, _, _, _) -> fkId)) $ + sortBy (comparing (\(fkId, seqNo, _, _, _, _, _, _) -> (fkId, seqNo))) fkRows + mkFkPred [] = [] + mkFkPred rows@((_, _, refTblStr, _, _, onUpdateStr, onDeleteStr, _):_) = + let localCols = map (\(_, _, _, from, _, _, _, _) -> from) rows + refCols = map (\(_, _, _, _, to, _, _, _) -> to) rows + refTable = QualifiedName Nothing refTblStr + onUpdate = parseForeignKeyAction onUpdateStr + onDelete = parseForeignKeyAction onDeleteStr + in case (NE.nonEmpty localCols, NE.nonEmpty refCols) of + (Just lcNE, Just rcNE) -> + [ Db.SomeDatabasePredicate + (Db.TableHasForeignKey tblName lcNE refTable rcNE onUpdate onDelete) ] + _ -> [] + pure ( [ Db.SomeDatabasePredicate (Db.TableExistsPredicate tblName) ] - ++ pkPred ++ columnPreds ++ idxPreds ) + ++ pkPred ++ columnPreds ++ idxPreds ++ fkPreds ) pure tblPreds + +parseForeignKeyAction :: T.Text -> Db.ForeignKeyAction +parseForeignKeyAction t = case T.toUpper t of + "CASCADE" -> Db.ForeignKeyActionCascade + "SET NULL" -> Db.ForeignKeyActionSetNull + "SET DEFAULT"-> Db.ForeignKeyActionSetDefault + "RESTRICT" -> Db.ForeignKeyActionRestrict + "NO ACTION" -> Db.ForeignKeyNoAction + _ -> error $ + "parseForeignKeyAction: unrecognised foreign key action: " ++ T.unpack t sqliteText :: Db.DataType Sqlite T.Text sqliteText = Db.DataType sqliteTextType 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 @@ -65,7 +65,7 @@ import qualified Data.DList as DL import Data.Hashable import Data.Int -import qualified Data.List.NonEmpty as NE (toList) +import qualified Data.List.NonEmpty as NE (NonEmpty(..), toList) import Data.Maybe import Data.Scientific import Data.String @@ -282,7 +282,7 @@ data SqliteTableConstraintSyntax = SqliteTableConstraintSyntax { fromSqliteTableConstraint :: SqliteSyntax - , sqliteTableConstraintPrimaryKey :: Maybe [ T.Text ] } + , sqliteTableConstraintPrimaryKey :: Maybe (NE.NonEmpty T.Text) } data SqliteMatchTypeSyntax = SqliteMatchTypeSyntax { fromSqliteMatchType :: SqliteSyntax @@ -476,11 +476,27 @@ referentialActionSetDefaultSyntax = SqliteReferentialActionSyntax (emit "SET DEFAULT") referentialActionSetDefaultSyntax referentialActionNoActionSyntax = SqliteReferentialActionSyntax (emit "NO ACTION") referentialActionNoActionSyntax +sqliteForeignKeyAction :: ForeignKeyAction -> SqliteSyntax +sqliteForeignKeyAction ForeignKeyActionCascade = emit "CASCADE" +sqliteForeignKeyAction ForeignKeyActionSetNull = emit "SET NULL" +sqliteForeignKeyAction ForeignKeyActionSetDefault = emit "SET DEFAULT" +sqliteForeignKeyAction ForeignKeyActionRestrict = emit "RESTRICT" +sqliteForeignKeyAction ForeignKeyNoAction = emit "NO ACTION" + instance IsSql92TableConstraintSyntax SqliteTableConstraintSyntax where primaryKeyConstraintSyntax fields = SqliteTableConstraintSyntax - (emit "PRIMARY KEY" <> parens (commas (map quotedIdentifier fields))) + (emit "PRIMARY KEY" <> parens (commas (map quotedIdentifier $ NE.toList fields))) (Just fields) + foreignKeyConstraintSyntax localCols refTbl refCols onUpdate onDelete = + SqliteTableConstraintSyntax syntax Nothing + where + syntax = + emit "FOREIGN KEY" <> parens (commas (map quotedIdentifier $ NE.toList localCols)) <> + emit " REFERENCES " <> quotedIdentifier refTbl <> + parens (commas (map quotedIdentifier $ NE.toList refCols)) <> + emit " ON UPDATE " <> sqliteForeignKeyAction onUpdate <> + emit " ON DELETE " <> sqliteForeignKeyAction onDelete instance IsSql92CreateTableSyntax SqliteCreateTableSyntax where type Sql92CreateTableColumnSchemaSyntax SqliteCreateTableSyntax = SqliteColumnSchemaSyntax @@ -511,7 +527,7 @@ [field] -> case constraintPks of [] -> error "A column claims to have a primary key, but there is no key on this table" - [[fieldPk]] + [fieldPk NE.:| _] | field /= fieldPk -> error "Two columns claim to be a primary key on this table" | otherwise -> createTableNoPkConstraint _ -> error "There are multiple primary key constraints on this table" diff --git a/Database/Beam/Sqlite/TempTable.hs b/Database/Beam/Sqlite/TempTable.hs new file mode 100644 --- /dev/null +++ b/Database/Beam/Sqlite/TempTable.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE TypeApplications #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Database.Beam.Sqlite.TempTable + ( -- * Temporary tables + + -- ** @CREATE TEMPORARY TABLE@ + runCreateTempTable + + -- ** Options + , TempTableCreateMode(..) + , TempTableOptions(..) + , defaultTempTableOptions + + -- ** Schema constraint + , HasDefaultSqliteTempTableSchema + + ) where + +import Database.Beam.Migrate.TempTable + ( BeamHasTempTables(..) + , HasDefaultTempTableSchema + , TempTableCreateMode(..) + , TempTableOptions(..) + , defaultTempTableOptions + , runCreateTempTable + ) +import Database.Beam.Sqlite.Connection (Sqlite) +import Database.Beam.Sqlite.Syntax + ( SqliteCommandSyntax(..) + , fromSqliteColumnSchema, sqliteIsSerialColumn + , emit, quotedIdentifier, parens, commas + ) + +-------------------------------------------------------------------------------- + +-- | Tables for which @CREATE TEMPORARY TABLE@ statements can be emitted +-- automatically. +type HasDefaultSqliteTempTableSchema tbl = HasDefaultTempTableSchema Sqlite tbl + +instance BeamHasTempTables Sqlite where + createTempTableCmd nm colDefs pkCols ifNotExists = + SqliteCommandSyntax $ + emit "CREATE TEMPORARY TABLE " + <> (if ifNotExists then emit "IF NOT EXISTS " else mempty) + <> quotedIdentifier nm + <> parens (commas (colDefPieces ++ pkPiece)) + where + colDefPieces = + map (\(n, s) -> quotedIdentifier n <> emit " " <> fromSqliteColumnSchema s) + colDefs + + -- SQLite's INTEGER PRIMARY KEY AUTOINCREMENT already encodes the + -- primary key constraint, so a separate PRIMARY KEY constraint would + -- constitute a syntax error. + hasSerial = any (sqliteIsSerialColumn . snd) colDefs + pkPiece + | hasSerial || null pkCols = [] + | otherwise = + [ emit "PRIMARY KEY " + <> parens (commas (map quotedIdentifier pkCols)) ] + + dropTempTableIfExistsCmd nm = + SqliteCommandSyntax $ + emit "DROP TABLE IF EXISTS " <> quotedIdentifier nm diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -10,3 +10,36 @@ Due to SQLite's embedded nature, there are currently no plans to get rid of these. However, proposals and PRs to fix these corner cases are welcome, where appropriate. + +## Migration support + +`beam-sqlite` supports schema introspection and verification via +`Database.Beam.Sqlite.Migrate`, including: + +- Tables, columns, and their types, +- `NOT NULL` constraints, +- Primary keys, +- User-created secondary indices (via `PRAGMA index_list` / `PRAGMA index_info`), +- Foreign key constraints (via `PRAGMA foreign_key_list`), including + `ON DELETE` / `ON UPDATE` actions. + +### Declaring foreign keys + +Use `addTableForeignKey` from `beam-migrate` to declare a foreign key on a +checked table entity: + +```haskell +let db = defaultMigratableDbSettings `withDbModification` + (dbModification @_ @Sqlite) + { _orders = + addTableForeignKey (_customers db) + (\t -> selectorColumnName _order_customer_id t NE.:| []) + primaryKeyColumns + ForeignKeyNoAction -- ON UPDATE NO ACTION (default) + ForeignKeyActionCascade -- ON DELETE CASCADE + } +``` + +> **Note:** SQLite disables foreign key enforcement by default. Issue +> `PRAGMA foreign_keys = ON` on each connection (or set it in your open hook) +> to enable it at runtime. 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.7.0 +version: 0.6.0.0 synopsis: Beam driver for SQLite description: Beam driver for the embedded database. See @@ -22,6 +22,7 @@ Database.Beam.Sqlite.Syntax Database.Beam.Sqlite.Connection Database.Beam.Sqlite.Migrate + Database.Beam.Sqlite.TempTable other-modules: Database.Beam.Sqlite.SqliteSpecific build-depends: base >=4.11 && <5, @@ -79,6 +80,7 @@ Database.Beam.Sqlite.Test.Migrate Database.Beam.Sqlite.Test.Returning Database.Beam.Sqlite.Test.Select + Database.Beam.Sqlite.Test.TempTable default-language: Haskell2010 default-extensions: DeriveAnyClass, diff --git a/test/Database/Beam/Sqlite/Test/Migrate.hs b/test/Database/Beam/Sqlite/Test/Migrate.hs --- a/test/Database/Beam/Sqlite/Test/Migrate.hs +++ b/test/Database/Beam/Sqlite/Test/Migrate.hs @@ -1,5 +1,7 @@ module Database.Beam.Sqlite.Test.Migrate (tests) where +import Control.Exception (try, IOException) +import Data.List (isInfixOf) import Database.SQLite.Simple import Test.Tasty import Test.Tasty.HUnit @@ -7,6 +9,7 @@ import qualified Data.List.NonEmpty as NE import Data.Int (Int32) import Database.Beam +import Database.Beam.Backend.SQL.BeamExtensions (SqlSerial(..)) import Database.Beam.Sqlite import Database.Beam.Sqlite.Migrate import Database.Beam.Migrate @@ -21,6 +24,12 @@ , verifiesNoPrimaryKey , verifiesIndex , verifiesUniqueIndex + , migrateNonUniqueToUniqueIndex + , verifiesForeignKey + , addingForeignKeyFails + , verifiesForeignKeyActions + , foreignKeyActionsWork + , idempotentMigration ] newtype WithPkT f = WithPkT @@ -121,3 +130,251 @@ addTableIndex "idx_tbl_value_uniq" idxOpts (\t -> selectorColumnName _idx_value t NE.:| []) } testVerifySchema conn db + +-- | Check that we can change the uniqueness of an index in a migration +migrateNonUniqueToUniqueIndex :: TestTree +migrateNonUniqueToUniqueIndex = + testCase "autoMigrate can change a non-unique index to a unique index" $ + withTestDb $ \conn -> do + let nonUnique :: CheckedDatabaseSettings Sqlite IdxDb + nonUnique = + defaultMigratableDbSettings `withDbModification` + (dbModification @_ @Sqlite) + { _idx_tbl = + addTableIndex "idx_tbl_value" + (defaultIndexOptions @SqliteCommandSyntax) + (\t -> selectorColumnName _idx_value t NE.:| []) } + unique :: CheckedDatabaseSettings Sqlite IdxDb + unique = + defaultMigratableDbSettings `withDbModification` + (dbModification @_ @Sqlite) + { _idx_tbl = + addTableIndex "idx_tbl_value" + (setUniqueIndexOptions @SqliteCommandSyntax True $ + defaultIndexOptions @SqliteCommandSyntax) + (\t -> selectorColumnName _idx_value t NE.:| []) } + runBeamSqlite conn $ autoMigrate migrationBackend nonUnique + runBeamSqlite conn $ autoMigrate migrationBackend unique + +-- Foreign key tests + +data ParentT f = ParentT + { _parent_id :: C f Int32 + } deriving (Generic, Beamable) + +instance Table ParentT where + newtype PrimaryKey ParentT f = ParentPk (C f Int32) + deriving (Generic, Beamable) + primaryKey = ParentPk . _parent_id + +data ChildT f = ChildT + { _child_id :: C f Int32 + , _child_parent_id :: PrimaryKey ParentT f + } deriving (Generic, Beamable) + +instance Table ChildT where + newtype PrimaryKey ChildT f = ChildPk (C f Int32) + deriving (Generic, Beamable) + primaryKey = ChildPk . _child_id + +data FkDb entity = FkDb + { _fk_parent :: entity (TableEntity ParentT) + , _fk_child :: entity (TableEntity ChildT) + } deriving (Generic, Database Sqlite) + +verifiesForeignKey :: TestTree +verifiesForeignKey = testCase "verifySchema detects a plain foreign key" $ + withTestDb $ \conn -> do + execute_ conn "create table fk_parent (parent_id int not null primary key)" + execute_ conn "create table fk_child (child_id int not null primary key, \ + \child_parent_id int not null, \ + \foreign key (child_parent_id) references fk_parent (parent_id))" + let db :: CheckedDatabaseSettings Sqlite FkDb + db = defaultMigratableDbSettings `withDbModification` + (dbModification @_ @Sqlite) + { _fk_child = + addTableForeignKey (_fk_parent db) + (foreignKeyColumns _child_parent_id) + primaryKeyColumns + ForeignKeyNoAction + ForeignKeyNoAction + <> modifyCheckedTable id + (ChildT { _child_id = "child_id" + , _child_parent_id = ParentPk "child_parent_id" }) } + testVerifySchema conn db + +-- Schema used to test solver behaviour when a foreign key migration is impossible. +-- Needs to be somewhat large to trigger the exponential blowup in search space. + +data WideParentT f = WideParentT + { _wp_id :: C f Int32 + , _wp_a :: C f Int32 + , _wp_b :: C f Int32 + , _wp_c :: C f Int32 + , _wp_d :: C f Int32 + } deriving (Generic, Beamable) + +instance Table WideParentT where + newtype PrimaryKey WideParentT f = WideParentPk (C f Int32) + deriving (Generic, Beamable) + primaryKey = WideParentPk . _wp_id + +data WideChildT f = WideChildT + { _wc_id :: C f Int32 + , _wc_parent_id :: PrimaryKey WideParentT f + , _wc_a :: C f Int32 + , _wc_b :: C f Int32 + , _wc_c :: C f Int32 + , _wc_d :: C f Int32 + } deriving (Generic, Beamable) + +instance Table WideChildT where + newtype PrimaryKey WideChildT f = WideChildPk (C f Int32) + deriving (Generic, Beamable) + primaryKey = WideChildPk . _wc_id + +data WideFkDb entity = WideFkDb + { _wide_parent :: entity (TableEntity WideParentT) + , _wide_child :: entity (TableEntity WideChildT) + } deriving (Generic, Database Sqlite) + +-- | Check that the solver doesn't grow an enormous search space trying to find +-- a way to add a foreign key constraint (which SQLite cannot do to an existing +-- table). +addingForeignKeyFails :: TestTree +addingForeignKeyFails = + testCase "autoMigrate fails promptly when asked to add a foreign key" $ + withTestDb $ \conn -> do + let noFk :: CheckedDatabaseSettings Sqlite WideFkDb + noFk = defaultMigratableDbSettings + withFk :: CheckedDatabaseSettings Sqlite WideFkDb + withFk = noFk `withDbModification` + (dbModification @_ @Sqlite) + { _wide_child = + addTableForeignKey (_wide_parent withFk) + (foreignKeyColumns _wc_parent_id) + primaryKeyColumns + ForeignKeyNoAction + ForeignKeyNoAction } + runBeamSqlite conn $ autoMigrate migrationBackend noFk + result <- try @IOException (runBeamSqlite conn $ autoMigrate migrationBackend withFk) + case result of + Left e + | "Could not determine migration" `isInfixOf` show e + -> return () + Left e -> assertFailure $ unlines + [ "unexpected exception from autoMigrate:" + , " - " ++ show e + ] + Right _ -> assertFailure $ unlines + [ "expected autoMigrate to fail:" + , " SQLite cannot add foreign key constraints to existing tables" + ] + +verifiesForeignKeyActions :: TestTree +verifiesForeignKeyActions = + testCase "verifySchema detects a foreign key with ON DELETE & ON UPDATE actions" $ + withTestDb $ \conn -> do + execute_ conn "create table fk_parent (parent_id int not null primary key)" + execute_ conn "create table fk_child (child_id int not null primary key, \ + \child_parent_id int not null, \ + \foreign key (child_parent_id) references fk_parent (parent_id) \ + \on delete cascade on update restrict)" + let db :: CheckedDatabaseSettings Sqlite FkDb + db = defaultMigratableDbSettings `withDbModification` + (dbModification @_ @Sqlite) + { _fk_child = + addTableForeignKey (_fk_parent db) + (foreignKeyColumns _child_parent_id) + primaryKeyColumns + ForeignKeyActionRestrict + ForeignKeyActionCascade + <> modifyCheckedTable id + (ChildT { _child_id = "child_id" + , _child_parent_id = ParentPk "child_parent_id" }) } + testVerifySchema conn db + +-- | Verifies that foreign key actions are enforced at runtime. +foreignKeyActionsWork :: TestTree +foreignKeyActionsWork = + testCase "foreign key actions" $ + withTestDb $ \conn -> do + -- Enable foreign key support (required for SQLite) + execute_ conn "PRAGMA foreign_keys = ON" + let db :: CheckedDatabaseSettings Sqlite FkDb + db = defaultMigratableDbSettings `withDbModification` + (dbModification @_ @Sqlite) + { _fk_child = + addTableForeignKey (_fk_parent db) + (foreignKeyColumns _child_parent_id) + primaryKeyColumns + ForeignKeyActionCascade + ForeignKeyActionCascade + } + unc = unCheckDatabase db + runBeamSqlite conn $ autoMigrate migrationBackend db + + -- Insert two parents and three children (two for parent 1, one for parent 2). + runBeamSqlite conn $ do + runInsert $ insert (_fk_parent unc) $ insertValues + [ ParentT 1, ParentT 2 ] + runInsert $ insert (_fk_child unc) $ insertValues + [ ChildT 1 (ParentPk 1), ChildT 2 (ParentPk 1), ChildT 3 (ParentPk 2) ] + + -- ON UPDATE CASCADE: changing parent_id 1 → 10 should cascade to child rows. + runBeamSqlite conn $ + runUpdate $ update (_fk_parent unc) + (\p -> _parent_id p <-. val_ 10) + (\p -> _parent_id p ==. val_ 1) + childrenOf10 <- runBeamSqlite conn $ runSelectReturningList $ select $ + filter_ (\c -> let ParentPk pid = _child_parent_id c in pid ==. val_ 10) $ all_ (_fk_child unc) + assertEqual "two children should now reference updated parent id 10" + 2 (length childrenOf10) + childrenOf1 <- runBeamSqlite conn $ runSelectReturningList $ select $ + filter_ (\c -> let ParentPk pid = _child_parent_id c in pid ==. val_ 1) $ all_ (_fk_child unc) + assertEqual "no children should still reference old parent id 1" + 0 (length childrenOf1) + + -- ON DELETE CASCADE: deleting parent 2 should remove its child row. + runBeamSqlite conn $ + runDelete $ delete (_fk_parent unc) (\p -> _parent_id p ==. val_ 2) + childrenOf2 <- runBeamSqlite conn $ runSelectReturningList $ select $ + filter_ (\c -> let ParentPk pid = _child_parent_id c in pid ==. val_ 2) $ all_ (_fk_child unc) + assertEqual "child of deleted parent 2 should be removed" + 0 (length childrenOf2) + allChildren <- runBeamSqlite conn $ runSelectReturningList $ select $ + all_ (_fk_child unc) + assertEqual "only the two children of parent 10 should remain" + 2 (length allChildren) + +-------------------------------------------------------------------------------- +-- Ensure migration is idempotent (no data loss due to internal tables) + +data SimpleT f = SimpleT + { _auto_incr_id :: C f (SqlSerial Int32) + } deriving (Generic, Beamable) + +instance Table SimpleT where + newtype PrimaryKey SimpleT f = AutoIncrPk (C f (SqlSerial Int32)) + deriving (Generic, Beamable) + primaryKey = AutoIncrPk . _auto_incr_id + +data SimpleDb entity = SimpleDb + { _simple_tbl :: entity (TableEntity SimpleT) + } deriving (Generic, Database Sqlite) + +simpleCheckedDb :: CheckedDatabaseSettings Sqlite SimpleDb +simpleCheckedDb = defaultMigratableDbSettings + +idempotentMigration :: TestTree +idempotentMigration = + testCase "autoMigrate is idempotent" $ + withTestDb $ \conn -> do + runBeamSqlite conn $ autoMigrate migrationBackend simpleCheckedDb + -- Insert a row so that sqlite_sequence is populated in sqlite_master. + execute_ conn "INSERT INTO simple_tbl DEFAULT VALUES" + -- Make sure we don't think a migration would lose data due to the + -- presence of the sqlite_sequence table. + runBeamSqlite conn $ autoMigrate migrationBackend simpleCheckedDb + +-------------------------------------------------------------------------------- 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,7 +15,7 @@ import Database.Beam import Database.Beam.Backend.SQL.BeamExtensions - (conflictingFields, onConflictUpdateSet, onConflictUpdateSetWhere) + (conflictingFields, onConflictUpdateSet, onConflictUpdateSetWhere, runUpdateReturningList) import Database.Beam.Migrate (defaultMigratableDbSettings) import Database.Beam.Migrate.Simple (CheckedDatabaseSettings, autoMigrate) import Database.Beam.Sqlite (Sqlite, runBeamSqlite, insertOnConflictReturning) @@ -26,7 +26,7 @@ , insertReturning , runDeleteReturningList , runInsertReturningList - , runUpdateReturningList + , runSqliteUpdateReturningList , updateReturning ) @@ -38,6 +38,7 @@ testGroup "SQLite RETURNING statement tests" [ testInsertOnConflictReturning + , testSqliteUpdateReturning , testUpdateReturning , testDeleteReturning ] @@ -124,9 +125,9 @@ , (3, "upserted_user3", 33) ] --- | Test @UPDATE ... RETURNING@ -testUpdateReturning :: TestTree -testUpdateReturning = testCase "UPDATE .. RETURNING" $ +-- | Test @UPDATE ... RETURNING@ using the Sqlite-specific runSqliteUpdateReturningList +testSqliteUpdateReturning :: TestTree +testSqliteUpdateReturning = testCase "UPDATE .. RETURNING" $ withTestDb $ \conn -> do updatedUsers <- runBeamSqlite conn $ do @@ -142,7 +143,7 @@ ] -- Update user 2 and return projected columns from the updated row - runUpdateReturningList $ + runSqliteUpdateReturningList $ updateReturning (usersTable testDb) (\u -> userName u <-. val_ "updated_user2") @@ -150,6 +151,33 @@ (\u -> (userId u, userName u, userInfo2 u)) 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 diff --git a/test/Database/Beam/Sqlite/Test/TempTable.hs b/test/Database/Beam/Sqlite/Test/TempTable.hs new file mode 100644 --- /dev/null +++ b/test/Database/Beam/Sqlite/Test/TempTable.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Database.Beam.Sqlite.Test.TempTable (tests) where + +import Data.Int (Int32) +import Data.Kind (Type) +import GHC.Exts (Any) + +import Database.Beam +import Database.Beam.Sqlite +import Database.SQLite.Simple (execute_) + +import Test.Tasty +import Test.Tasty.HUnit + +import Database.Beam.Sqlite.Test + +tests :: TestTree +tests = testGroup "Temporary table tests" + [ testStageFilteredRows + , testDropAndCreate + ] + +-- | A permanent table of items. +data ItemT f = Item + { itemId :: C f Int32 + , itemValue :: C f Int32 + } deriving (Generic, Beamable) + +deriving instance Show (ItemT Identity) +deriving instance Eq (ItemT Identity) + +instance Table ItemT where + data PrimaryKey ItemT f = ItemKey (C f Int32) + deriving (Generic, Beamable) + primaryKey = ItemKey . itemId + +data ItemDb entity = ItemDb + { dbItems :: entity (TableEntity ItemT) + } deriving (Generic, Database Sqlite) + +itemDb :: DatabaseSettings be ItemDb +itemDb = defaultDbSettings + +testStageFilteredRows :: TestTree +testStageFilteredRows = testCase "sanity test" $ + withTestDb $ \conn -> do + execute_ conn "CREATE TABLE items (id INT PRIMARY KEY, value INT NOT NULL)" + result <- runBeamSqlite conn $ do + runInsert $ insert (dbItems itemDb) $ insertValues + [ Item 1 5, Item 2 10, Item 3 15, Item 4 20, Item 5 25 ] + scratch <- runCreateTempTable @_ @Any @ItemT + defaultTempTableOptions "high_value_items" + runInsert $ insert scratch $ insertFrom $ + filter_ (\r -> itemValue r >. val_ 15) $ + all_ (dbItems itemDb) + runSelectReturningList $ select $ + orderBy_ (asc_ . itemId) $ all_ scratch + assertEqual "high-value items staged" [Item 4 20, Item 5 25] result + +-- | 'DropAndCreate' resets the temp table so a second pass populates a +-- clean table, with no leftovers from the first pass. +testDropAndCreate :: TestTree +testDropAndCreate = testCase "drop-and-create" $ + withTestDb $ \conn -> do + execute_ conn "CREATE TABLE items (id INT PRIMARY KEY, value INT NOT NULL)" + result <- runBeamSqlite conn $ do + runInsert $ insert (dbItems itemDb) $ insertValues + [ Item 1 5, Item 2 10, Item 3 15, Item 4 20, Item 5 25 ] + -- First pass: stage low-value items. + scratch <- runCreateTempTable @_ @Any @ItemT + defaultTempTableOptions "scratch" + runInsert $ insert scratch $ insertFrom $ + filter_ (\r -> itemValue r <=. val_ 15) $ + all_ (dbItems itemDb) + -- Second pass: drop and recreate, then stage high-value items only. + scratch' <- runCreateTempTable @_ @Any @ItemT + (defaultTempTableOptions { tempTableCreateMode = DropAndCreate }) + "scratch" + runInsert $ insert scratch' $ insertFrom $ + filter_ (\r -> itemValue r >. val_ 15) $ + all_ (dbItems itemDb) + runSelectReturningList $ select $ + orderBy_ (asc_ . itemId) $ all_ scratch' + assertEqual "only high-value items after reset" [Item 4 20, Item 5 25] result diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -7,6 +7,7 @@ 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 +import qualified Database.Beam.Sqlite.Test.TempTable as TempTable main :: IO () main = defaultMain $ testGroup "beam-sqlite tests" @@ -15,4 +16,5 @@ , Insert.tests , InsertOnConflictReturning.tests , Returning.tests + , TempTable.tests ]