Fix the logic that checks indices on foreign keys

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

src/Database/PostgreSQL/PQTypes/Model/Index.hs

@@ -9,6 +9,7 @@ module Database.PostgreSQL.PQTypes.Model.Index (
   , indexOnColumns
   , indexOnColumnWithMethod
   , indexOnColumnsWithMethod
+  , indexColumnName
   , uniqueIndexOnColumn
   , uniqueIndexOnColumnWithCondition
   , uniqueIndexOnColumns

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"

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