diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,11 @@ +# 0.5.7.0 + +## Added features + +* Add support for creating secondary indices (`CREATE INDEX` and + `CREATE UNIQUE INDEX`), including discovering user-created secondary indices + via `PRAGMA index_list` / `PRAGMA index_info`. + # 0.5.6.0 ## Performance optimizations @@ -13,7 +21,7 @@ ## Bux fixes -* Fixed an issue where values inserted with conflicts did not return then when using `runInsertReturningList` (#774) +* Fixed an issue where values inserted with conflicts did not return then when using `runInsertReturningList` (#774) ## Updated dependencies 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 @@ -41,6 +41,7 @@ import Data.Char (isSpace) import Data.Int (Int64) import Data.List (sortBy) +import qualified Data.List.NonEmpty as NE (nonEmpty) import Data.Maybe (mapMaybe, isJust) import Data.Monoid (Endo(..)) import Data.Ord (comparing) @@ -64,6 +65,8 @@ , Tool.backendFileExtension = "sqlite.sql" , Tool.backendConvertToHaskell = sqlitePredConverter , Tool.backendActionProvider = Db.defaultActionProvider + <> Db.createIndexActionProvider + <> Db.dropIndexActionProvider , Tool.backendRunSqlScript = runSqlScript , Tool.backendWithTransaction = \(SqliteM go) -> @@ -320,8 +323,33 @@ pkPred = case pkColumns of [] -> [] _ -> [ Db.SomeDatabasePredicate (Db.TableHasPrimaryKey tblName pkColumns) ] + + -- Collect user-created secondary indices (origin = 'c') for this table. + -- SQLite's PRAGMA index_list returns (seq, name, unique, origin, partial). + -- PRAGMA index_info returns (seqno, cid, name) ordered by seqno. + idxRows <- query_ conn (fromString ("PRAGMA index_list('" <> T.unpack tblNameStr <> "')") + ) :: IO [(Int, T.Text, Int, T.Text, Int)] + idxPreds <- fmap concat . forM idxRows $ + \(_, idxNm, isUniq, origin, _) -> + if origin /= T.pack "c" + then pure [] + else do + colRows <- query_ conn (fromString ("PRAGMA index_info('" <> T.unpack idxNm <> "')") + ) :: IO [(Int, Int, T.Text)] + let cols = map (\(_, _, nm) -> nm) $ + sortBy (comparing (\(seqno, _, _) -> seqno)) colRows + pure $ + case NE.nonEmpty cols of + Nothing -> [] + Just colsNE -> + let opts = Db.setUniqueIndexOptions @SqliteCommandSyntax (isUniq /= (0 :: Int)) + $ Db.defaultIndexOptions @SqliteCommandSyntax + in + [ Db.SomeDatabasePredicate + (Db.TableHasIndex @Sqlite tblName idxNm colsNE opts) ] + pure ( [ Db.SomeDatabasePredicate (Db.TableExistsPredicate tblName) ] - ++ pkPred ++ columnPreds ) + ++ pkPred ++ columnPreds ++ idxPreds ) pure tblPreds 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 @@ -26,6 +26,7 @@ , SqliteTableNameSyntax(..) , SqliteFieldNameSyntax(..) , SqliteAggregationSetQuantifierSyntax(..) + , SqliteIndexOptions(..) , fromSqliteExpression @@ -55,7 +56,7 @@ import qualified Database.Beam.Migrate.Serialization as Db import Database.Beam.Query hiding (ExtractField(..)) -import Data.Aeson (object, (.=)) +import Data.Aeson (object, withObject, (.=), (.:)) import Data.ByteString (ByteString) import qualified Data.ByteString as B import Data.ByteString.Builder @@ -64,6 +65,7 @@ import qualified Data.DList as DL import Data.Hashable import Data.Int +import qualified Data.List.NonEmpty as NE (toList) import Data.Maybe import Data.Scientific import Data.String @@ -981,3 +983,35 @@ instance HasDataTypeCreatedCheck SqliteDataTypeSyntax where dataTypeHasBeenCreated _ _ = True + +newtype SqliteIndexOptions = + SqliteIndexOptions { sqliteIndexUnique :: Bool } + deriving (Show, Eq, Hashable) + +instance IsSql92CreateDropIndexSyntax SqliteCommandSyntax where + type instance Sql92CreateIndexOptionsSyntax SqliteCommandSyntax = + SqliteIndexOptions + + defaultIndexOptions = SqliteIndexOptions { sqliteIndexUnique = False } + + createIndexCmd idxNm tblNm cols opts = + SqliteCommandSyntax $ + emit (if sqliteIndexUnique opts then "CREATE UNIQUE INDEX " else "CREATE INDEX ") <> + quotedIdentifier idxNm <> + emit " ON " <> fromSqliteTableName tblNm <> + parens (commas (NE.toList $ fmap quotedIdentifier cols)) + + dropIndexCmd idxNm = + SqliteCommandSyntax (emit "DROP INDEX " <> quotedIdentifier idxNm) + + serializeIndexOptions opts = + object ["unique" .= sqliteIndexUnique opts] + + deserializeIndexOptions = + withObject "SqliteIndexOptions" $ \v -> + SqliteIndexOptions <$> v .: "unique" + +instance IsSql92UniqueIndexSyntax SqliteCommandSyntax where + + setUniqueIndexOptions u opts = opts { sqliteIndexUnique = u } + indexIsUnique opts = sqliteIndexUnique opts 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.6.0 +version: 0.5.7.0 synopsis: Beam driver for SQLite description: Beam driver for the embedded database. See @@ -26,7 +26,7 @@ build-depends: base >=4.11 && <5, beam-core >=0.10 && <0.11, - beam-migrate >=0.5.3.2 && <0.6, + beam-migrate >=0.5.4.0 && <0.6, sqlite-simple >=0.4 && <0.5, containers >=0.6 && <0.9, 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 @@ -4,6 +4,8 @@ import Test.Tasty import Test.Tasty.HUnit +import qualified Data.List.NonEmpty as NE +import Data.Int (Int32) import Database.Beam import Database.Beam.Sqlite import Database.Beam.Sqlite.Migrate @@ -11,11 +13,14 @@ import Database.Beam.Migrate.Simple import Database.Beam.Sqlite.Test +import Database.Beam.Sqlite.Syntax (SqliteIndexOptions) tests :: TestTree tests = testGroup "Migration tests" [ verifiesPrimaryKey , verifiesNoPrimaryKey + , verifiesIndex + , verifiesUniqueIndex ] newtype WithPkT f = WithPkT @@ -72,3 +77,47 @@ VerificationSucceeded -> return () VerificationFailed failures -> fail $ "Verification failed: " ++ show failures + +-- Shared table type for index tests + +newtype IdxT f = IdxT + { _idx_value :: C f Int32 + } deriving (Generic, Beamable) + +instance Table IdxT where + newtype PrimaryKey IdxT f = IdxPk (C f Int32) + deriving (Generic, Beamable) + primaryKey = IdxPk . _idx_value + +data IdxDb entity = IdxDb + { _idx_tbl :: entity (TableEntity IdxT) + } deriving (Generic, Database Sqlite) + +verifiesIndex :: TestTree +verifiesIndex = testCase "verifySchema correctly detects a secondary index" $ + withTestDb $ \conn -> do + execute_ conn "create table idx_tbl (idx_value int not null primary key)" + execute_ conn "create index idx_tbl_value on idx_tbl (idx_value)" + let db :: CheckedDatabaseSettings Sqlite IdxDb + db = defaultMigratableDbSettings `withDbModification` + (dbModification @_ @Sqlite) + { _idx_tbl = + addTableIndex "idx_tbl_value" (defaultIndexOptions @SqliteCommandSyntax) + (\t -> selectorColumnName _idx_value t NE.:| []) } + testVerifySchema conn db + +verifiesUniqueIndex :: TestTree +verifiesUniqueIndex = testCase "verifySchema correctly detects a UNIQUE secondary index" $ + withTestDb $ \conn -> do + execute_ conn "create table idx_tbl (idx_value int not null primary key)" + execute_ conn "create unique index idx_tbl_value_uniq on idx_tbl (idx_value)" + let db :: CheckedDatabaseSettings Sqlite IdxDb + db = defaultMigratableDbSettings `withDbModification` + (dbModification @_ @Sqlite) + { _idx_tbl = + let idxOpts = setUniqueIndexOptions @SqliteCommandSyntax True + $ defaultIndexOptions @SqliteCommandSyntax + in + addTableIndex "idx_tbl_value_uniq" idxOpts + (\t -> selectorColumnName _idx_value t NE.:| []) } + testVerifySchema conn db