diff --git a/src/Database/PostgreSQL/PQTypes/Checks.hs b/src/Database/PostgreSQL/PQTypes/Checks.hs index bc91a17..d549dae 100644 --- a/src/Database/PostgreSQL/PQTypes/Checks.hs +++ b/src/Database/PostgreSQL/PQTypes/Checks.hs @@ -42,6 +42,7 @@ import Database.PostgreSQL.PQTypes.Migrate import Database.PostgreSQL.PQTypes.Model import Database.PostgreSQL.PQTypes.SQL.Builder import Database.PostgreSQL.PQTypes.Versions +import Database.PostgreSQL.PQTypes.Utils.NubList headExc :: String -> [a] -> a headExc s [] = error s @@ -433,7 +434,7 @@ checkDBStructure options tables = fmap mconcat . forM tables $ \(table, version) , checkChecks tblChecks checks , checkIndexes tblIndexes indexes , checkForeignKeys tblForeignKeys fkeys - , checkForeignKeyIndexes tblForeignKeys tblIndexes + , checkForeignKeyIndexes tblPrimaryKey tblForeignKeys tblIndexes , checkTriggers tblTriggers triggers , checkedOverlaps ] @@ -558,24 +559,29 @@ checkDBStructure options tables = fmap mconcat . forM tables $ \(table, version) , checkNames (fkName tblName) fkeys ] - checkForeignKeyIndexes :: [ForeignKey] -> [TableIndex] -> ValidationResult - checkForeignKeyIndexes foreignKeys indexes = + checkForeignKeyIndexes :: Maybe PrimaryKey -> [ForeignKey] -> [TableIndex] -> ValidationResult + checkForeignKeyIndexes pkey foreignKeys indexes = if eoCheckForeignKeysIndexes options then foldMap' go foreignKeys else mempty - -- The idea behind the following conversions to sets of columns is that the - -- order of index columns doesn't matter. where - cname :: [IndexColumn] -> S.Set Text - cname = S.fromList . map (\(IndexColumn col _) -> unRawSQL col) - idxColumnsSets :: [S.Set Text] - idxColumnsSets = cname . idxColumns <$> indexes + -- Map index on the given table name to a list of list of names + -- so that index on a and index on (b, c) becomes [[a], [b, c,]]. + allIndexes :: [[RawSQL ()]] + allIndexes = fmap (fmap indexColumnName . idxColumns) . filter (isNothing . idxWhere) $ indexes + + allCoverage :: [[RawSQL ()]] + allCoverage = maybe [] pkColumns pkey:allIndexes + + -- A foreign key is covered if it is a prefix of a list of indices. + -- So a FK on a is covered by an index on (a, b) but not an index on (b, a). + coveredFK :: ForeignKey -> [[RawSQL ()]] -> Bool + coveredFK fk = any (\idx -> fkColumns fk `L.isPrefixOf` idx) go :: ForeignKey -> ValidationResult go fk = let columns = map unRawSQL (fkColumns fk) - fkColumnsSet = S.fromList columns - in if fkColumnsSet `elem` idxColumnsSets + in if coveredFK fk allCoverage then mempty else validationError $ mconcat ["\n ● Foreign key '(", T.intercalate "," columns, ")' is missing an index"] diff --git a/src/Database/PostgreSQL/PQTypes/Model/Index.hs b/src/Database/PostgreSQL/PQTypes/Model/Index.hs index 9bcd861..e1f9b1a 100644 --- a/src/Database/PostgreSQL/PQTypes/Model/Index.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/Index.hs @@ -9,6 +9,7 @@ module Database.PostgreSQL.PQTypes.Model.Index ( , indexOnColumns , indexOnColumnWithMethod , indexOnColumnsWithMethod + , indexColumnName , uniqueIndexOnColumn , uniqueIndexOnColumnWithCondition , uniqueIndexOnColumns diff --git a/src/Database/PostgreSQL/PQTypes/Model/PrimaryKey.hs b/src/Database/PostgreSQL/PQTypes/Model/PrimaryKey.hs index 04c49bf..7b07887 100644 --- a/src/Database/PostgreSQL/PQTypes/Model/PrimaryKey.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/PrimaryKey.hs @@ -3,6 +3,7 @@ module Database.PostgreSQL.PQTypes.Model.PrimaryKey ( , pkOnColumn , pkOnColumns , pkName + , pkColumns , sqlAddPK , sqlAddPKUsing , sqlDropPK @@ -26,6 +27,9 @@ pkOnColumns columns = Just . PrimaryKey . toNubList $ columns pkName :: RawSQL () -> RawSQL () pkName tname = mconcat ["pk__", tname] +pkColumns :: PrimaryKey -> [RawSQL ()] +pkColumns (PrimaryKey columns) = fromNubList columns + sqlAddPK :: RawSQL () -> PrimaryKey -> RawSQL () sqlAddPK tname (PrimaryKey columns) = smconcat [ "ADD CONSTRAINT" diff --git a/test/Main.hs b/test/Main.hs index b6e32a7..1282ef7 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1701,7 +1701,24 @@ foreignKeyIndexesTests connSource = let options = defaultExtrasOptions { eoCheckForeignKeysIndexes = True } assertException "Foreign keys are missing" $ migrateDatabase options ["pgcrypto"] [] [] [table1, table2, table3] [createTableMigration table1, createTableMigration table2, createTableMigration table3] - + + step "Multi column indexes covering a FK pass the checks" + do + let options = defaultExtrasOptions { eoCheckForeignKeysIndexes = True } + migrateDatabase options ["pgcrypto"] [] [] [table4] + [ dropTableMigration table1 + , dropTableMigration table2 + , dropTableMigration table3 + , createTableMigration table4 + ] + checkDatabase options [] [] [table4] + step "Multi column indexes not covering a FK fail the checks" + do + let options = defaultExtrasOptions { eoCheckForeignKeysIndexes = True } + assertException "Foreign keys are missing" $ migrateDatabase options ["pgcrypto"] [] [] [table5] + [ dropTableMigration table4 + , createTableMigration table5 + ] where table1 :: Table table1 = tblTable @@ -1744,6 +1761,40 @@ foreignKeyIndexesTests connSource = , fkOnColumn "fk2id" "fktest2" "id" ] } + table4 :: Table + table4 = tblTable + { tblName = "fktest4" + , tblVersion = 1 + , tblColumns = + [ tblColumn { colName = "id", colType = UuidT, colNullable = False } + , tblColumn { colName = "fk4id", colType = UuidT } + , tblColumn { colName = "fk4name", colType = TextT } + ] + , tblPrimaryKey = pkOnColumn "id" + , tblForeignKeys = + [ fkOnColumn "fk4id" "fktest4" "id" + ] + , tblIndexes = + [ indexOnColumns [ indexColumn "fk4id", indexColumn "fk4name" ] + ] + } + table5 :: Table + table5 = tblTable + { tblName = "fktest5" + , tblVersion = 1 + , tblColumns = + [ tblColumn { colName = "id", colType = UuidT, colNullable = False } + , tblColumn { colName = "fk5id", colType = UuidT } + , tblColumn { colName = "fk5name", colType = TextT } + ] + , tblPrimaryKey = pkOnColumn "id" + , tblForeignKeys = + [ fkOnColumn "fk5id" "fktest5" "id" + ] + , tblIndexes = + [ indexOnColumns [ indexColumn "fk5thing", indexColumn "fk5id" ] + ] + } overlapingIndexesTests :: ConnectionSourceM (LogT IO) -> TestTree overlapingIndexesTests connSource = do @@ -1773,9 +1824,6 @@ overlapingIndexesTests connSource = do ] } - - - assertNoException :: String -> TestM () -> TestM () assertNoException t = eitherExc (const $ liftIO $ assertFailure ("Exception thrown for: " ++ t))