Nulls not distinct

.github/workflows/haskell.yml

@@ -11,7 +11,9 @@ jobs:
   build:
     services:
       postgres:
-        image: postgres:12-alpine
+        # Use a PostgreSQL version that supports UNIQUE NULLS NOT DISTINCT (15+),
+        # so the NullsNotDistinctTest suite actually exercises the feature.
+        image: postgres:16-alpine
         env:
           POSTGRES_USER: perstest
           POSTGRES_PASSWORD: perstest

persistent-postgresql/ChangeLog.md

@@ -1,5 +1,12 @@
 # Changelog for persistent-postgresql
 
+# Unreleased
+
+* [#1609](https://github.com/yesodweb/persistent/pull/1609)
+  * Add support for `!nullsNotDistinct` attribute on unique constraints.
+    This generates `UNIQUE NULLS NOT DISTINCT` constraints for PostgreSQL 15+,
+    which treats NULL values as equal for uniqueness checks.
+
 # 2.14.3.0
 
 * [#1616](https://github.com/yesodweb/persistent/pull/1616)

persistent-postgresql/Database/Persist/Postgresql/Internal/Migration.hs

@@ -586,8 +586,8 @@ migrateEntityFromSchemaState overrides schemaState allDefs entity =
     newcols = filter (not . safeToRemove entity . cName) newcols'
     udspair = map udToPair udefs
 
-    uniques = flip concatMap udspair $ \(uname, ucols) ->
-        [AlterTable name $ AddUniqueConstraint uname ucols]
+    uniques = flip concatMap udspair $ \(uname, ucols, uattrs) ->
+        [AlterTable name $ AddUniqueConstraint uname ucols uattrs]
     references =
         mapMaybe
             ( \Column{cName, cReference} ->
@@ -673,7 +673,7 @@ data AlterColumn
 --
 -- @since 2.17.1.0
 data AlterTable
-    = AddUniqueConstraint ConstraintNameDB [FieldNameDB]
+    = AddUniqueConstraint ConstraintNameDB [FieldNameDB] [Attr]
     | DropConstraint ConstraintNameDB
     deriving (Show, Eq)
 
@@ -718,7 +718,7 @@ mayDefault def = case def of
 getAlters
     :: [EntityDef]
     -> EntityDef
-    -> ([Column], [(ConstraintNameDB, [FieldNameDB])])
+    -> ([Column], [(ConstraintNameDB, [FieldNameDB], [Attr])])
     -> ([Column], [(ConstraintNameDB, [FieldNameDB])])
     -> ([AlterColumn], [AlterTable])
 getAlters defs def (c1, u1) (c2, u2) =
@@ -733,24 +733,33 @@ getAlters defs def (c1, u1) (c2, u2) =
             alters ++ getAltersC news old'
 
     getAltersU
-        :: [(ConstraintNameDB, [FieldNameDB])]
+        :: [(ConstraintNameDB, [FieldNameDB], [Attr])]
         -> [(ConstraintNameDB, [FieldNameDB])]
         -> [AlterTable]
     getAltersU [] old =
         map DropConstraint $ filter (not . isManual) $ map fst old
-    getAltersU ((name, cols) : news) old =
+    getAltersU ((name, cols, attrs) : news) old =
         case lookup name old of
             Nothing ->
-                AddUniqueConstraint name cols : getAltersU news old
+                AddUniqueConstraint name cols attrs : getAltersU news old
             Just ocols ->
                 let
                     old' = filter (\(x, _) -> x /= name) old
                  in
+                    -- NOTE: we only compare the columns, not the attributes
+                    -- (such as @!nullsNotDistinct@). The @old@ side is derived
+                    -- from introspecting the live database, which does not carry
+                    -- persistent's attribute information, so there is nothing to
+                    -- compare against here. As a consequence, toggling
+                    -- @!nullsNotDistinct@ on a constraint whose columns are
+                    -- otherwise unchanged will NOT be detected as a migration.
+                    -- Such a change must be applied manually (or by dropping and
+                    -- recreating the constraint).
                     if sort cols == sort ocols
                         then getAltersU news old'
                         else
                             DropConstraint name
-                                : AddUniqueConstraint name cols
+                                : AddUniqueConstraint name cols attrs
                                 : getAltersU news old'
 
     -- Don't drop constraints which were manually added.
@@ -850,8 +859,8 @@ safeToRemove def (FieldNameDB colName) =
             _ ->
                 []
 
-udToPair :: UniqueDef -> (ConstraintNameDB, [FieldNameDB])
-udToPair ud = (uniqueDBName ud, map snd $ NEL.toList $ uniqueFields ud)
+udToPair :: UniqueDef -> (ConstraintNameDB, [FieldNameDB], [Attr])
+udToPair ud = (uniqueDBName ud, map snd $ NEL.toList $ uniqueFields ud, uniqueAttrs ud)
 
 -- | Get the references to be added to a table for the given column.
 getAddReference
@@ -957,13 +966,15 @@ showAlterDb (AlterColumn t ac) =
 showAlterDb (AlterTable t at) = (False, showAlterTable t at)
 
 showAlterTable :: EntityNameDB -> AlterTable -> Text
-showAlterTable table (AddUniqueConstraint cname cols) =
+showAlterTable table (AddUniqueConstraint cname cols attrs) =
     T.concat
         [ "ALTER TABLE "
         , escapeE table
         , " ADD CONSTRAINT "
         , escapeC cname
-        , " UNIQUE("
+        , " UNIQUE"
+        , if "!nullsNotDistinct" `elem` attrs then " NULLS NOT DISTINCT" else ""
+        , "("
         , T.intercalate "," $ map escapeF cols
         , ")"
         ]

persistent-postgresql/persistent-postgresql.cabal

@@ -66,6 +66,7 @@ test-suite test
     JSONTest
     MigrationReferenceSpec
     MigrationSpec
+    NullsNotDistinctTest
     PgInit
     PgIntervalTest
     UpsertWhere

persistent-postgresql/test/NullsNotDistinctTest.hs

@@ -0,0 +1,255 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module NullsNotDistinctTest where
+
+import Control.Monad.Trans.Resource (runResourceT)
+import qualified Data.Text as T
+import Database.Persist
+import Database.Persist.Postgresql
+import Database.Persist.Postgresql.Internal
+import Database.Persist.TH
+import qualified Test.Hspec as Hspec
+
+import PgInit
+
+-- The standard unique constraint (allowing multiple NULLs) is migrated on every
+-- supported PostgreSQL version, so it lives in its own migration that is always
+-- safe to run.
+share
+    [mkPersist sqlSettings, mkMigrate "standardUniqueMigrate"]
+    [persistLowerCase|
+  -- Standard unique constraint (allows multiple NULLs)
+  StandardUnique
+    name Text
+    email Text Maybe
+    UniqueStandardEmail name email !force
+    deriving Eq Show
+|]
+
+-- These entities use NULLS NOT DISTINCT, which is only valid on PostgreSQL 15+.
+-- They are kept in a separate migration so that it is only ever run when the
+-- server supports the feature (see 'main.hs' and the version-gated tests below).
+-- Running this migration against PostgreSQL < 15 raises a syntax error.
+share
+    [mkPersist sqlSettings, mkMigrate "nullsNotDistinctMigrate"]
+    [persistLowerCase|
+  -- Unique constraint with NULLS NOT DISTINCT (PostgreSQL 15+)
+  -- This should prevent multiple NULLs
+  NullsNotDistinctUnique
+    name Text
+    email Text Maybe
+    UniqueNNDEmail name email !nullsNotDistinct
+    deriving Eq Show
+
+  -- Multiple nullable fields with NULLS NOT DISTINCT
+  MultiFieldNND
+    fieldA Text
+    fieldB Text Maybe
+    fieldC Int Maybe
+    UniqueMultiNND fieldA fieldB fieldC !nullsNotDistinct
+    deriving Eq Show
+|]
+
+-- Helper to check PostgreSQL version
+getPostgresVersion :: (MonadIO m) => ReaderT SqlBackend m (Maybe Int)
+getPostgresVersion = do
+    result <- rawSql "SELECT current_setting('server_version_num')::integer" []
+    case result of
+        [Single version] -> return $ Just version
+        _ -> return Nothing
+
+isPostgres15OrHigher :: (MonadIO m) => ReaderT SqlBackend m Bool
+isPostgres15OrHigher = do
+    mVersion <- getPostgresVersion
+    case mVersion of
+        Just version -> return $ version >= 150000 -- PostgreSQL 15.0
+        Nothing -> return False
+
+cleanStandard :: (MonadIO m) => ReaderT SqlBackend m ()
+cleanStandard = deleteWhere ([] :: [Filter StandardUnique])
+
+-- Only safe to call on PostgreSQL 15+, where the NND tables have been migrated.
+cleanNND :: (MonadIO m) => ReaderT SqlBackend m ()
+cleanNND = do
+    deleteWhere ([] :: [Filter NullsNotDistinctUnique])
+    deleteWhere ([] :: [Filter MultiFieldNND])
+
+specs :: Spec
+specs = describe "NULLS NOT DISTINCT support" $ do
+    let
+        runDb = runConnAssert
+
+    it "generates correct SQL for NULLS NOT DISTINCT constraint" $ do
+        let
+            alterWithNND =
+                AddUniqueConstraint
+                    (ConstraintNameDB "unique_nnd_email")
+                    [FieldNameDB "name", FieldNameDB "email"]
+                    ["!nullsNotDistinct"]
+
+        let
+            alterWithoutNND =
+                AddUniqueConstraint
+                    (ConstraintNameDB "unique_standard_email")
+                    [FieldNameDB "name", FieldNameDB "email"]
+                    ["!force"]
+
+        let
+            tableName = EntityNameDB "test_table"
+        let
+            sqlWithNND = showAlterTable tableName alterWithNND
+        let
+            sqlWithoutNND = showAlterTable tableName alterWithoutNND
+
+        sqlWithNND
+            `Hspec.shouldBe` "ALTER TABLE \"test_table\" ADD CONSTRAINT \"unique_nnd_email\" UNIQUE NULLS NOT DISTINCT(\"name\",\"email\")"
+
+        sqlWithoutNND
+            `Hspec.shouldBe` "ALTER TABLE \"test_table\" ADD CONSTRAINT \"unique_standard_email\" UNIQUE(\"name\",\"email\")"
+
+    describe "runtime behavior" $ do
+        it "standard unique allows multiple NULLs" $ do
+            runDb $ do
+                cleanStandard
+
+                -- These should both succeed with standard unique
+                _ <- insert $ StandardUnique "user1" Nothing
+                _ <- insert $ StandardUnique "user2" Nothing
+
+                -- Verify both were inserted
+                count1 <- count [StandardUniqueName ==. "user1"]
+                count2 <- count [StandardUniqueName ==. "user2"]
+
+                liftIO $ do
+                    count1 `Hspec.shouldBe` 1
+                    count2 `Hspec.shouldBe` 1
+
+        it "standard unique prevents duplicate non-NULLs" $
+            -- Both inserts run in the same transaction so the constraint
+            -- violation propagates out of runDb for shouldThrow to catch.
+            ( runDb $ do
+                cleanStandard
+                _ <- insert $ StandardUnique "user1" (Just "test@example.com")
+                _ <- insert $ StandardUnique "user1" (Just "test@example.com")
+                return ()
+            )
+                `Hspec.shouldThrow` Hspec.anyException
+
+        it
+            "standard unique getBy returns Nothing for NULL values (backwards compatibility)"
+            $ do
+                runDb $ do
+                    cleanStandard
+
+                    -- Insert a record with NULL email
+                    _ <- insert $ StandardUnique "user1" Nothing
+
+                    -- getBy with NULL should return Nothing (standard SQL behavior)
+                    -- This ensures backwards compatibility - without !nullsNotDistinct,
+                    -- getBy cannot find NULL values
+                    result <- getBy $ UniqueStandardEmail "user1" Nothing
+
+                    liftIO $ result `Hspec.shouldBe` Nothing
+
+                    -- Verify that getBy still works for non-NULL values
+                    k2 <- insert $ StandardUnique "user2" (Just "test@example.com")
+                    result2 <- getBy $ UniqueStandardEmail "user2" (Just "test@example.com")
+
+                    liftIO $ case result2 of
+                        Just (Entity key _) -> key `Hspec.shouldBe` k2
+                        Nothing -> Hspec.expectationFailure "getBy should find non-NULL values"
+
+        -- The NULLS NOT DISTINCT tables are only migrated on PostgreSQL 15+, so we
+        -- detect support once here and only build the feature tests when the table
+        -- actually exists. This means a failing/absent migration can never be
+        -- mistaken for a passing (shouldThrow) assertion.
+        supportsNND <- Hspec.runIO $ runResourceT $ runConn_ isPostgres15OrHigher
+        describe "PostgreSQL 15+ features" $
+            if not supportsNND
+                then
+                    it "are skipped (requires PostgreSQL 15 or higher)" $
+                        Hspec.pendingWith "Requires PostgreSQL 15 or higher"
+                else do
+                    it "NULLS NOT DISTINCT prevents multiple NULLs" $
+                        -- Same name and email twice; the second insert must violate
+                        -- the unique constraint. Both run in one transaction.
+                        ( runDb $ do
+                            cleanNND
+                            _ <- insert $ NullsNotDistinctUnique "user1" Nothing
+                            _ <- insert $ NullsNotDistinctUnique "user1" Nothing
+                            return ()
+                        )
+                            `Hspec.shouldThrow` Hspec.anyException
+
+                    it "NULLS NOT DISTINCT with multiple nullable fields" $ do
+                        -- Different NULL patterns are still distinct and should succeed
+                        runDb $ do
+                            cleanNND
+                            _ <- insert $ MultiFieldNND "test1" Nothing Nothing
+                            _ <- insert $ MultiFieldNND "test1" (Just "value") Nothing
+                            _ <- insert $ MultiFieldNND "test1" Nothing (Just 42)
+
+                            count' <- count ([] :: [Filter MultiFieldNND])
+                            liftIO $ count' `Hspec.shouldBe` 3
+
+                        -- The same NULL pattern twice should violate the constraint
+                        ( runDb $ do
+                                cleanNND
+                                _ <- insert $ MultiFieldNND "test1" Nothing Nothing
+                                _ <- insert $ MultiFieldNND "test1" Nothing Nothing
+                                return ()
+                            )
+                            `Hspec.shouldThrow` Hspec.anyException
+
+                    it "getBy finds NULL values with NULLS NOT DISTINCT" $
+                        runDb $ do
+                            cleanNND
+
+                            -- Insert with NULL
+                            k1 <- insert $ NullsNotDistinctUnique "user1" Nothing
+
+                            -- With our runtime detection, getBy now uses
+                            -- IS NOT DISTINCT FROM for entities with
+                            -- !nullsNotDistinct, allowing it to find NULL values
+                            result <- getBy $ UniqueNNDEmail "user1" Nothing
+
+                            liftIO $ case result of
+                                Just (Entity key _) -> key `Hspec.shouldBe` k1
+                                Nothing ->
+                                    Hspec.expectationFailure
+                                        "getBy should find NULL values when !nullsNotDistinct is set"
+
+                    it "migration generates a NULLS NOT DISTINCT constraint" $
+                        runDb $ do
+                            -- Read PostgreSQL's catalog for the generated constraint.
+                            constraints :: [(Single Text, Single Text)] <-
+                                rawSql
+                                    "SELECT conname, pg_get_constraintdef(oid) \
+                                    \FROM pg_constraint \
+                                    \WHERE conrelid = 'nulls_not_distinct_unique'::regclass \
+                                    \  AND contype = 'u'"
+                                    []
+
+                            let
+                                hasNND =
+                                    any
+                                        ( \(Single _, Single def) ->
+                                            "NULLS NOT DISTINCT" `T.isInfixOf` def
+                                        )
+                                        constraints
+
+                            liftIO $ hasNND `Hspec.shouldBe` True