Normalize index identifiers on construction

Index column identifiers are stripped of outer quotes at construction.
Indexes created by older versions still validate via a reconstructed
legacy name candidate.

Author: crtschin

CHANGELOG.md

@@ -8,6 +8,7 @@
 * Add support for the `NUMERIC` column type.
 * Fix getting the row estimate for `ModifyColumnMigration` if a table with the
   same name is present in multiple schemas.
+* Fix validation against historic table indices created with non-reserved keywords.
 
 # hpqtypes-extras-1.19.0.0 (2025-11-27)
 * Compatibility with `hpqtypes` >= 0.13.0.0.

src/Database/PostgreSQL/PQTypes/Checks.hs

@@ -748,9 +748,13 @@ checkDBStructure options tables = fmap mconcat . forM tables $ \(table, version)
         checkIndexes defs allIndexes =
           mconcat $
             checkEquality "INDEXes" defs (map fst indexes)
-              : checkNames (indexName tblName) indexes
+              : checkNames expectedName indexes
               : map localIndexInfo localIndexes
           where
+            -- Recover the user-declared form because introspection always quotes.
+            expectedName dbIdx =
+              indexName tblName (fromMaybe dbIdx (L.find (== dbIdx) defs))
+
             localIndexInfo (index, name) =
               validationInfo $
                 T.concat
@@ -1539,8 +1543,8 @@ fetchTableIndex
   -> (TableIndex, RawSQL ())
 fetchTableIndex (name, Array1 keyColumns, Array1 includeColumns, method, unique, nullsNotDistinct, mconstraint) =
   ( TableIndex
-      { idxColumns = map (indexColumn . (`rawSQL` ()) . stripIdentifierQuotes) keyColumns
-      , idxInclude = map ((`rawSQL` ()) . stripIdentifierQuotes) includeColumns
+      { idxColumns = map (indexColumn . (`rawSQL` ())) keyColumns
+      , idxInclude = map (includeColumn . (`rawSQL` ())) includeColumns
       , idxMethod = case method of
           "gin" -> GIN
           "btree" -> BTree
@@ -1551,10 +1555,6 @@ fetchTableIndex (name, Array1 keyColumns, Array1 includeColumns, method, unique,
       }
   , rawSQL name ()
   )
-  where
-    stripIdentifierQuotes str = case fmap T.unsnoc <$> T.uncons str of
-      Just ('"', Just (identifier, '"')) -> identifier
-      _ -> str
 
 -- *** FOREIGN KEYS ***
 

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

@@ -14,6 +14,8 @@ module Database.PostgreSQL.PQTypes.Model.Index
   , uniqueIndexOnColumnWithCondition
   , uniqueIndexOnColumns
   , indexName
+  , IncludeColumn (unIncludeColumn)
+  , includeColumn
   , sqlCreateIndexMaybeDowntime
   , sqlCreateIndexConcurrently
   , sqlDropIndexMaybeDowntime
@@ -33,7 +35,7 @@ import Database.PostgreSQL.PQTypes
 
 data TableIndex = TableIndex
   { idxColumns :: [IndexColumn]
-  , idxInclude :: [RawSQL ()]
+  , idxInclude :: [IncludeColumn]
   , idxMethod :: IndexMethod
   , idxUnique :: Bool
   , -- \^ If creation of index with CONCURRENTLY fails, index
@@ -48,31 +50,71 @@ data TableIndex = TableIndex
   -- \^ NB: will only be used if idxUnique is set to True
   deriving (Eq, Ord, Show)
 
+-- | A key column of an index, optionally with an operator class. The 'Bool'
+-- records whether the identifier was surrounded by double quotes in the source.
 data IndexColumn
-  = IndexColumn (RawSQL ()) (Maybe (RawSQL ()))
+  = IndexColumn (RawSQL ()) (Maybe (RawSQL ())) Bool
   deriving (Show)
 
 -- If one of the two columns doesn't specify the operator class, we just ignore
 -- it and still treat them as equivalent.
 instance Eq IndexColumn where
-  IndexColumn x Nothing == IndexColumn y _ = x == y
-  IndexColumn x _ == IndexColumn y Nothing = x == y
-  IndexColumn x (Just x') == IndexColumn y (Just y') = x == y && x' == y'
+  IndexColumn x Nothing _ == IndexColumn y _ _ = x == y
+  IndexColumn x _ _ == IndexColumn y Nothing _ = x == y
+  IndexColumn x (Just x') _ == IndexColumn y (Just y') _ = x == y && x' == y'
 
 instance Ord IndexColumn where
   compare = compare `on` indexColumnName
 
 instance IsString IndexColumn where
-  fromString s = IndexColumn (fromString s) Nothing
+  fromString = indexColumn . fromString
+
+-- | A column appearing in an @INCLUDE@ clause. The 'Bool' records whether the
+-- identifier was surrounded by double quotes in the source.
+data IncludeColumn = IncludeColumn {unIncludeColumn :: RawSQL (), _incWasQuoted :: Bool}
+  deriving (Show)
+
+instance Eq IncludeColumn where
+  IncludeColumn x _ == IncludeColumn y _ = x == y
+
+instance Ord IncludeColumn where
+  compare = compare `on` unIncludeColumn
+
+instance IsString IncludeColumn where
+  fromString = includeColumn . fromString
+
+-- | Strip a single surrounding pair of double quotes. The 'Bool' reports
+-- whether stripping happened.
+mkIdent :: RawSQL () -> (RawSQL (), Bool)
+mkIdent r = case fmap T.unsnoc <$> T.uncons (unRawSQL r) of
+  Just ('"', Just (body, '"')) -> (rawSQL body (), True)
+  _ -> (r, False)
+
+-- | Wrap an identifier in double quotes for DDL emission.
+quoteIdent :: RawSQL () -> RawSQL ()
+quoteIdent r = "\"" <> r <> "\""
+
+-- | Apply 'quoteIdent' iff the bit is set.
+quoteWhen :: Bool -> RawSQL () -> RawSQL ()
+quoteWhen True = quoteIdent
+quoteWhen False = id
+
+-- | Lift a 'Text' transformation onto the body of a 'RawSQL' ().
+asText :: (T.Text -> T.Text) -> RawSQL () -> RawSQL ()
+asText f = (`rawSQL` ()) . f . unRawSQL
 
 indexColumn :: RawSQL () -> IndexColumn
-indexColumn col = IndexColumn col Nothing
+indexColumn col = let (c, q) = mkIdent col in IndexColumn c Nothing q
 
 indexColumnWithOperatorClass :: RawSQL () -> RawSQL () -> IndexColumn
-indexColumnWithOperatorClass col opclass = IndexColumn col (Just opclass)
+indexColumnWithOperatorClass col opclass =
+  let (c, q) = mkIdent col in IndexColumn c (Just opclass) q
 
 indexColumnName :: IndexColumn -> RawSQL ()
-indexColumnName (IndexColumn col _) = col
+indexColumnName (IndexColumn col _ _) = col
+
+includeColumn :: RawSQL () -> IncludeColumn
+includeColumn col = let (c, q) = mkIdent col in IncludeColumn c q
 
 data IndexMethod
   = BTree
@@ -148,22 +190,22 @@ uniqueIndexOnColumnWithCondition column whereC =
     , idxNotDistinctNulls = False
     }
 
+-- | Canonical auto-generated name for an index.
 indexName :: RawSQL () -> TableIndex -> RawSQL ()
 indexName tname TableIndex {..} =
-  flip rawSQL () $
-    T.take 63 . unRawSQL $
-      mconcat
-        [ if idxUnique then "unique_idx__" else "idx__"
-        , tname
-        , "__"
-        , mintercalate "__" $ map (asText sanitize . indexColumnName) idxColumns
-        , if null idxInclude
-            then ""
-            else "$$" <> mintercalate "__" (map (asText sanitize) idxInclude)
-        , maybe "" (("__" <>) . hashWhere) idxWhere
-        ]
+  asText (T.take 63) $
+    mconcat
+      [ if idxUnique then "unique_idx__" else "idx__"
+      , tname
+      , "__"
+      , mintercalate "__" $ map (\(IndexColumn col _ q) -> renderIdent q col) idxColumns
+      , if null idxInclude
+          then ""
+          else "$$" <> mintercalate "__" (map (\(IncludeColumn col q) -> renderIdent q col) idxInclude)
+      , maybe "" (("__" <>) . hashWhere) idxWhere
+      ]
   where
-    asText f = flip rawSQL () . f . unRawSQL
+    renderIdent q = asText sanitize . quoteWhen q
     -- See http://www.postgresql.org/docs/9.4/static/sql-syntax-lexical.html#SQL-SYNTAX-IDENTIFIERS.
     -- Remove all unallowed characters and replace them by at most one adjacent dollar sign.
     sanitize = T.pack . foldr go [] . T.unpack
@@ -210,15 +252,18 @@ sqlCreateIndex_ concurrently tname idx@TableIndex {..} =
         ", "
         ( map
             ( \case
-                IndexColumn col Nothing -> col
-                IndexColumn col (Just opclass) -> col <+> opclass
+                IndexColumn col Nothing q -> quoteWhen q col
+                IndexColumn col (Just opclass) q -> quoteWhen q col <+> opclass
             )
             idxColumns
         )
     , ")"
     , if null idxInclude
         then ""
-        else " INCLUDE (" <> mintercalate ", " idxInclude <> ")"
+        else
+          " INCLUDE ("
+            <> mintercalate ", " (map (\(IncludeColumn c q) -> quoteWhen q c) idxInclude)
+            <> ")"
     , if idxUnique && idxNotDistinctNulls
         then " NULLS NOT DISTINCT"
         else ""

test/Main.hs

@@ -2363,6 +2363,69 @@ reservedWordColumnTests connSource =
 
     freshTestDB step
 
+    step "Definition using the legacy quoted form (\"\\\"timestamp\\\"\") still validates"
+    assertNoException "Quoted-keyword column in tblIndexes is accepted" $ do
+      let definitions = tableDefsWithPgCrypto [tableWithLegacyQuotedIndex]
+      migrateDatabase
+        defaultExtrasOptions
+        definitions
+        [createTableMigration tableWithLegacyQuotedIndex]
+      checkDatabase defaultExtrasOptions definitions
+
+    freshTestDB step
+
+    step "Index pre-existing under the quoted-source name validates"
+    assertNoException "Quoted-source index name is accepted by checkDatabase" $ do
+      -- Hand-roll the index under its canonical @$ident$@ name, then validate
+      -- against a definition that includes it.
+      migrateDatabase
+        defaultExtrasOptions
+        (tableDefsWithPgCrypto [tableWithLegacyQuotedIndexNoIndexes])
+        [createTableMigration tableWithLegacyQuotedIndexNoIndexes]
+      runSQL_
+        "CREATE INDEX \"idx__reserved_word_test5__$timestamp$\" \
+        \ON reserved_word_test5 (\"timestamp\")"
+      checkDatabase defaultExtrasOptions $
+        tableDefsWithPgCrypto [tableWithLegacyQuotedIndex]
+
+    freshTestDB step
+
+    step "Index with a reserved-word column in INCLUDE validates"
+    assertNoException "Reserved-word column in idxInclude is accepted" $ do
+      let definitions = tableDefsWithPgCrypto [tableWithReservedWordInclude]
+      migrateDatabase
+        defaultExtrasOptions
+        definitions
+        [createTableMigration tableWithReservedWordInclude]
+      checkDatabase defaultExtrasOptions definitions
+
+    freshTestDB step
+
+    step "Multi-column index mixing unquoted and quoted-keyword columns validates"
+    assertNoException "Mixed quoted/unquoted composite index is accepted" $ do
+      let definitions = tableDefsWithPgCrypto [tableWithMixedQuotedComposite]
+      migrateDatabase
+        defaultExtrasOptions
+        definitions
+        [createTableMigration tableWithMixedQuotedComposite]
+      checkDatabase defaultExtrasOptions definitions
+
+    freshTestDB step
+
+    step "Index on a JSONB expression is created without being quoted as an identifier"
+    assertNoException "Expression index is accepted" $ do
+      let definitions = tableDefsWithPgCrypto [tableWithExpressionIndex]
+      migrateDatabase
+        defaultExtrasOptions
+        definitions
+        [createTableMigration tableWithExpressionIndex]
+      checkDatabase defaultExtrasOptions definitions
+
+    freshTestDB step
+
+    -- NB: keep this step last. The CREATE INDEX failure on a reserved-word
+    -- column leaves the connection's transaction in aborted state, so a
+    -- subsequent `freshTestDB` (which runs DROP SCHEMA) fails.
     step "Attempt to create a table with an index on a 'select' column"
     assertException "Table with index on 'select' column can't be created" $ do
       let definitions = tableDefsWithPgCrypto [tableWithSelectIndex]
@@ -2421,6 +2484,84 @@ reservedWordColumnTests connSource =
         , tblIndexes = [indexOnColumn "select"]
         }
 
+    tableWithLegacyQuotedIndex =
+      tblTable
+        { tblName = "reserved_word_test5"
+        , tblVersion = 1
+        , tblColumns =
+            [ tblColumn {colName = "id", colType = UuidT, colNullable = False, colDefault = Just "gen_random_uuid()"}
+            , tblColumn {colName = "timestamp", colType = TimestampWithZoneT, colNullable = False}
+            ]
+        , tblPrimaryKey = pkOnColumn "id"
+        , tblIndexes = [indexOnColumn "\"timestamp\""]
+        }
+
+    tableWithLegacyQuotedIndexNoIndexes = tableWithLegacyQuotedIndex {tblIndexes = []}
+
+    tableWithReservedWordInclude =
+      tblTable
+        { tblName = "reserved_word_test6"
+        , tblVersion = 1
+        , tblColumns =
+            [ tblColumn {colName = "id", colType = UuidT, colNullable = False, colDefault = Just "gen_random_uuid()"}
+            , tblColumn {colName = "name", colType = TextT, colNullable = False}
+            , tblColumn {colName = "timestamp", colType = TimestampWithZoneT, colNullable = False}
+            ]
+        , tblPrimaryKey = pkOnColumn "id"
+        , tblIndexes = [(uniqueIndexOnColumn "name") {idxInclude = ["timestamp"]}]
+        }
+
+    tableWithMixedQuotedComposite =
+      tblTable
+        { tblName = "reserved_word_test7"
+        , tblVersion = 1
+        , tblColumns =
+            [ tblColumn {colName = "id", colType = UuidT, colNullable = False, colDefault = Just "gen_random_uuid()"}
+            , tblColumn {colName = "other_id", colType = UuidT, colNullable = False}
+            , tblColumn {colName = "name", colType = TextT, colNullable = False}
+            , tblColumn {colName = "time", colType = TimestampWithZoneT, colNullable = False}
+            ]
+        , tblPrimaryKey = pkOnColumn "id"
+        , tblIndexes = [indexOnColumns ["other_id", "name", "\"time\""]]
+        }
+
+    tableWithExpressionIndex =
+      tblTable
+        { tblName = "reserved_word_test8"
+        , tblVersion = 1
+        , tblColumns =
+            [ tblColumn {colName = "id", colType = UuidT, colNullable = False, colDefault = Just "gen_random_uuid()"}
+            , tblColumn {colName = "data", colType = JsonbT, colNullable = False}
+            ]
+        , tblPrimaryKey = pkOnColumn "id"
+        , tblIndexes = [uniqueIndexOnColumn (indexColumn "(data ->> 'key'::text)")]
+        }
+
+sqlCreateIndexEmissionTests :: TestTree
+sqlCreateIndexEmissionTests =
+  testGroup
+    "sqlCreateIndex emission"
+    [ testCase "expression column is emitted without identifier quoting" $
+        assertCreateIndex
+          "CREATE UNIQUE INDEX unique_idx__t__$data$key$text$\
+          \ ON t USING BTree ((data ->> 'key'::text))"
+          (uniqueIndexOnColumn (indexColumn "(data ->> 'key'::text)"))
+    , testCase "quoted reserved-word column round-trips as a quoted identifier" $
+        assertCreateIndex
+          "CREATE INDEX idx__t__$timestamp$ ON t USING BTree (\"timestamp\")"
+          (indexOnColumn "\"timestamp\"")
+    , testCase "unquoted column is emitted bare" $
+        assertCreateIndex
+          "CREATE INDEX idx__t__name ON t USING BTree (name)"
+          (indexOnColumn "name")
+    ]
+  where
+    assertCreateIndex expected idx =
+      assertEqual
+        "sqlCreateIndexMaybeDowntime output"
+        expected
+        (unRawSQL (sqlCreateIndexMaybeDowntime "t" idx))
+
 sqlAnyAllTests :: TestTree
 sqlAnyAllTests =
   testGroup
@@ -2721,6 +2862,7 @@ main = do
            , overlapingIndexesTests connSource
            , nullsNotDistinctTests connSource
            , reservedWordColumnTests connSource
+           , sqlCreateIndexEmissionTests
            , sqlAnyAllTests
            , enumTest connSource
            , numericColumnTypeTest connSource