diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,13 @@ +# 0.5.1.1 + +## Added features + + * GHC 9.2 and 9.0 support + +## Bug fixes + + * Support inserting default values for all columns (except with upsert) + # 0.5.1.0 ## Added features 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 @@ -94,6 +94,7 @@ -- value list is ignored. data SqliteSyntax = SqliteSyntax ((SQLData -> Builder) -> Builder) (DL.DList SQLData) newtype SqliteData = SqliteData SQLData -- newtype for Hashable + deriving Eq instance Show SqliteSyntax where show (SqliteSyntax s d) = @@ -311,10 +312,21 @@ formatSqliteInsertOnConflict tblNm fields values onConflict = mconcat [ emit "INSERT INTO " , fromSqliteTableName tblNm - , parens (commas (map quotedIdentifier fields)) + , if null fields + then mempty + else parens (commas (map quotedIdentifier fields)) , emit " " , case values of SqliteInsertFromSql (SqliteSelectSyntax select) -> select + -- Because SQLite doesn't support explicit DEFAULT values, if an insert + -- batch contains any defaults, we split it into a series of single-row + -- inserts specifying only the non-default columns (which could differ + -- between rows in the batch). To insert all default values, there is + -- special DEFAULT VALUES syntax, which only supports one row anyway. + -- Unfortunately, SQLite doesn't currently support DEFAULT VALUES with ON + -- CONFLICT. We don't specially catch that in hopes that SQLite will some + -- day support it, since there is really no reason it shouldn't. + SqliteInsertExpressions [[]] -> emit "DEFAULT VALUES" SqliteInsertExpressions es -> emit "VALUES " <> commas (map (\row -> parens (commas (map fromSqliteExpression row)) ) es) , maybe mempty ((emit " " <>) . fromSqliteOnConflict) onConflict 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.1.0 +version: 0.5.1.1 synopsis: Beam driver for SQLite description: Beam driver for the embedded database. See @@ -30,17 +30,17 @@ sqlite-simple >=0.4 && <0.5, text >=1.0 && <1.3, - bytestring >=0.10 && <0.11, - hashable >=1.2 && <1.4, - time >=1.6 && <1.10, - dlist >=0.8 && <0.9, + bytestring >=0.10 && <0.12, + hashable >=1.2 && <1.5, + time >=1.6 && <1.12, + dlist >=0.8 && <1.1, mtl >=2.1 && <2.3, free >=4.12 && <5.2, scientific >=0.3 && <0.4, monad-control >=1.0 && <1.1, network-uri >=2.6 && <2.7, aeson >=0.11 && <1.6, - attoparsec >=0.13 && <0.14, + attoparsec >=0.13 && <0.15, transformers-base >=0.4 && <0.5 default-language: Haskell2010 default-extensions: ScopedTypeVariables, OverloadedStrings, MultiParamTypeClasses, RankNTypes, FlexibleInstances, @@ -74,6 +74,7 @@ time other-modules: Database.Beam.Sqlite.Test + Database.Beam.Sqlite.Test.Insert Database.Beam.Sqlite.Test.Migrate Database.Beam.Sqlite.Test.Select default-language: Haskell2010 diff --git a/test/Database/Beam/Sqlite/Test/Insert.hs b/test/Database/Beam/Sqlite/Test/Insert.hs new file mode 100644 --- /dev/null +++ b/test/Database/Beam/Sqlite/Test/Insert.hs @@ -0,0 +1,118 @@ +module Database.Beam.Sqlite.Test.Insert (tests) where + +import Data.Int (Int32) +import Data.Text (Text) +import Data.Time (LocalTime) +import Database.Beam +import Database.Beam.Backend.SQL.BeamExtensions +import Database.Beam.Sqlite hiding (runInsertReturningList) +import Database.SQLite.Simple (execute_) +import Test.Tasty +import Test.Tasty.ExpectedFailure +import Test.Tasty.HUnit + +import Database.Beam.Sqlite.Test + +tests :: TestTree +tests = testGroup "Insertion tests" + [ testInsertReturningColumnOrder + , testInsertOnlyDefaults + , expectFail testUpsertOnlyDefaults + ] + +data TestTableT f + = TestTable + { ttId :: C f Int32 + , ttFirstName :: C f Text + , ttLastName :: C f Text + , ttAge :: C f Int32 + , ttDateJoined :: C f LocalTime + } deriving (Generic, Beamable) + +deriving instance Show (TestTableT Identity) +deriving instance Eq (TestTableT Identity) + +instance Table TestTableT where + data PrimaryKey TestTableT f = TestTableKey (C f Int32) + deriving (Generic, Beamable) + primaryKey = TestTableKey <$> ttId + +data TestTableDb entity + = TestTableDb + { dbTestTable :: entity (TableEntity TestTableT) + } deriving (Generic, Database Sqlite) + +testDatabase :: DatabaseSettings be TestTableDb +testDatabase = defaultDbSettings + +testInsertReturningColumnOrder :: TestTree +testInsertReturningColumnOrder = testCase "runInsertReturningList with mismatching column order" $ do + withTestDb $ \conn -> do + execute_ conn "CREATE TABLE test_table ( date_joined TIMESTAMP NOT NULL, first_name TEXT NOT NULL, id INT PRIMARY KEY, age INT NOT NULL, last_name TEXT NOT NULL )" + inserted <- + runBeamSqlite conn $ runInsertReturningList $ + insert (dbTestTable testDatabase) $ + insertExpressions [ TestTable 0 (concat_ [ "j", "im" ]) "smith" 19 currentTimestamp_ + , TestTable 1 "sally" "apple" ((val_ 56 + val_ 109) `div_` 5) currentTimestamp_ + , TestTable 4 "blah" "blah" (-1) currentTimestamp_ ] + + let dateJoined = ttDateJoined (head inserted) + + expected = [ TestTable 0 "jim" "smith" 19 dateJoined + , TestTable 1 "sally" "apple" 33 dateJoined + , TestTable 4 "blah" "blah" (-1) dateJoined ] + + assertEqual "insert values" inserted expected + +data WithDefaultsT f = WithDefaults + { _id :: C f (SqlSerial Int32) + , _value :: C f Text + } deriving (Generic, Beamable) + +deriving instance Show (WithDefaultsT Identity) +deriving instance Eq (WithDefaultsT Identity) + +instance Table WithDefaultsT where + data PrimaryKey WithDefaultsT f = WithDefaultsKey (C f (SqlSerial Int32)) + deriving (Generic, Beamable) + primaryKey = WithDefaultsKey <$> _id + +data WithDefaultsDb entity = WithDefaultsDb + { tblWithDefaults :: entity (TableEntity WithDefaultsT) + } deriving (Generic, Database Sqlite) + +withDefaultsDb :: DatabaseSettings be WithDefaultsDb +withDefaultsDb = defaultDbSettings + +-- | Regression test for +testInsertOnlyDefaults :: TestTree +testInsertOnlyDefaults = testCase "insert only default values" $ + withTestDb $ \conn -> do + execute_ conn "CREATE TABLE with_defaults (id INTEGER PRIMARY KEY, value TEXT NOT NULL DEFAULT \"unknown\")" + inserted <- runBeamSqlite conn $ runInsertReturningList $ + insert (tblWithDefaults withDefaultsDb) $ insertExpressions + [ WithDefaults default_ default_ + , WithDefaults default_ $ val_ "other" + ] + assertEqual "inserted values" inserted + [ WithDefaults 1 "unknown" + , WithDefaults 2 "other" + ] + +testUpsertOnlyDefaults :: TestTree +testUpsertOnlyDefaults = testCase "upsert only default values" $ + withTestDb $ \conn -> do + execute_ conn "CREATE TABLE with_defaults (id INTEGER PRIMARY KEY, value TEXT NOT NULL DEFAULT \"unknown\")" + inserted <- runBeamSqlite conn $ runInsertReturningList $ + insertOnConflict (tblWithDefaults withDefaultsDb) + ( insertExpressions + [ WithDefaults default_ default_ + , WithDefaults default_ $ val_ "other" + ] + ) + anyConflict + onConflictDoNothing + assertEqual "inserted values" inserted + [ WithDefaults 1 "unknown" + , WithDefaults 2 "other" + ] 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 @@ -1,28 +1,17 @@ -{-# LANGUAGE OverloadedStrings #-} - module Database.Beam.Sqlite.Test.Select (tests) where -import Control.Exception +import Database.Beam +import Database.Beam.Sqlite import Test.Tasty import Test.Tasty.ExpectedFailure import Test.Tasty.HUnit -import Data.Int (Int32) -import Data.Text (Text) -import Data.Time (LocalTime) - -import Database.Beam -import Database.Beam.Sqlite - import Database.Beam.Sqlite.Test -import Database.SQLite.Simple (execute_) - tests :: TestTree tests = testGroup "Selection tests" [ expectFail testExceptValues , testInRowValues - , testInsertReturningColumnOrder -- In select tests because the bug was with the selects ] data Pair f = Pair @@ -46,47 +35,3 @@ result <- runBeamSqlite conn $ runSelectReturningList $ select $ values_ [as_ @Bool $ val_ True, val_ False] `except_` values_ [val_ False] assertEqual "result" [True] result - -data TestTableT f - = TestTable - { ttId :: C f Int32 - , ttFirstName :: C f Text - , ttLastName :: C f Text - , ttAge :: C f Int32 - , ttDateJoined :: C f LocalTime - } deriving (Generic, Beamable) - -deriving instance Show (TestTableT Identity) -deriving instance Eq (TestTableT Identity) - -instance Table TestTableT where - data PrimaryKey TestTableT f = TestTableKey (C f Int32) - deriving (Generic, Beamable) - primaryKey = TestTableKey <$> ttId - -data TestTableDb entity - = TestTableDb - { dbTestTable :: entity (TableEntity TestTableT) - } deriving (Generic, Database Sqlite) - -testDatabase :: DatabaseSettings be TestTableDb -testDatabase = defaultDbSettings - -testInsertReturningColumnOrder :: TestTree -testInsertReturningColumnOrder = testCase "runInsertReturningList with mismatching column order" $ do - withTestDb $ \conn -> do - execute_ conn "CREATE TABLE test_table ( date_joined TIMESTAMP NOT NULL, first_name TEXT NOT NULL, id INT PRIMARY KEY, age INT NOT NULL, last_name TEXT NOT NULL )" - inserted <- - runBeamSqlite conn $ runInsertReturningList $ - insert (dbTestTable testDatabase) $ - insertExpressions [ TestTable 0 (concat_ [ "j", "im" ]) "smith" 19 currentTimestamp_ - , TestTable 1 "sally" "apple" ((val_ 56 + val_ 109) `div_` 5) currentTimestamp_ - , TestTable 4 "blah" "blah" (-1) currentTimestamp_ ] - - let dateJoined = ttDateJoined (head inserted) - - expected = [ TestTable 0 "jim" "smith" 19 dateJoined - , TestTable 1 "sally" "apple" 33 dateJoined - , TestTable 4 "blah" "blah" (-1) dateJoined ] - - assertEqual "insert values" inserted expected diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -3,10 +3,12 @@ import Test.Tasty import qualified Database.Beam.Sqlite.Test.Migrate as Migrate +import qualified Database.Beam.Sqlite.Test.Insert as Insert import qualified Database.Beam.Sqlite.Test.Select as Select main :: IO () main = defaultMain $ testGroup "beam-sqlite tests" [ Migrate.tests , Select.tests + , Insert.tests ]