beam-sqlite 0.5.7.0 → 0.6.0.0

raw patch · 12 files changed

+600/−34 lines, 12 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +17/−0
• Database/Beam/Sqlite.hs +2/−0
• Database/Beam/Sqlite/Connection.hs +31/−18
• Database/Beam/Sqlite/Migrate.hs +50/−5
• Database/Beam/Sqlite/Syntax.hs +20/−4
• Database/Beam/Sqlite/TempTable.hs +66/−0
• README.md +33/−0
• beam-sqlite.cabal +3/−1
• test/Database/Beam/Sqlite/Test/Migrate.hs +257/−0
• test/Database/Beam/Sqlite/Test/Returning.hs +34/−6
• test/Database/Beam/Sqlite/Test/TempTable.hs +85/−0
• test/Main.hs +2/−0

@@ -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

@@ -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

@@ -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)))

@@ -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

@@ -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"

@@ -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

@@ -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.

@@ -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 <https://sqlite.org/ SQLite> embedded database.                      See <https://haskell-beam.github.io/beam/user-guide/backends/beam-sqlite/ here>@@ -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,

@@ -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++--------------------------------------------------------------------------------

@@ -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

@@ -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

@@ -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       ]