diff --git a/persistent-postgresql/Database/Persist/Postgresql/Internal.hs b/persistent-postgresql/Database/Persist/Postgresql/Internal.hs index 4d4f57fdc..89a3b4dee 100644 --- a/persistent-postgresql/Database/Persist/Postgresql/Internal.hs +++ b/persistent-postgresql/Database/Persist/Postgresql/Internal.hs @@ -372,7 +372,7 @@ data AlterColumn -- -- @since 2.17.1.0 data AlterTable - = AddUniqueConstraint ConstraintNameDB [FieldNameDB] + = AddUniqueConstraint ConstraintNameDB [FieldNameDB] [Attr] | DropConstraint ConstraintNameDB deriving (Show, Eq) @@ -430,8 +430,8 @@ migrateStructured allDefs getter entity = do createText newcols fdefs_ udspair = (addTable newcols entity) : uniques ++ references ++ foreignsAlt where - 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} -> @@ -464,8 +464,8 @@ mockMigrateStructured allDefs entity = migrationText createText newcols fdefs udspair = (addTable newcols entity) : uniques ++ references ++ foreignsAlt where - 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} -> @@ -508,7 +508,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) = @@ -523,15 +523,15 @@ 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 @@ -540,7 +540,7 @@ getAlters defs def (c1, u1) (c2, u2) = 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. @@ -632,8 +632,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 @@ -739,13 +739,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 , ")" ] diff --git a/persistent-postgresql/persistent-postgresql.cabal b/persistent-postgresql/persistent-postgresql.cabal index 992d7b7e6..5f55932ea 100644 --- a/persistent-postgresql/persistent-postgresql.cabal +++ b/persistent-postgresql/persistent-postgresql.cabal @@ -60,6 +60,7 @@ test-suite test ImplicitUuidSpec JSONTest MigrationReferenceSpec + NullsNotDistinctTest PgInit PgIntervalTest UpsertWhere diff --git a/persistent-postgresql/test/NullsNotDistinctTest.hs b/persistent-postgresql/test/NullsNotDistinctTest.hs new file mode 100644 index 000000000..db1522874 --- /dev/null +++ b/persistent-postgresql/test/NullsNotDistinctTest.hs @@ -0,0 +1,274 @@ +{-# 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.Exception (SomeException, try) +import Control.Monad (unless, void, when) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Reader (ReaderT) +import Data.Text (Text) +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 qualified Test.Hspec.Expectations.Lifted as Lifted + +import PgInit + +-- Test entities with and without NULLS NOT DISTINCT +share + [mkPersist sqlSettings, mkMigrate "nullsNotDistinctMigrate"] + [persistLowerCase| + -- Standard unique constraint (allows multiple NULLs) + StandardUnique + name Text + email Text Maybe + UniqueStandardEmail name email !force + deriving Eq Show + + -- 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 + +cleanDB + :: (BaseBackend backend ~ SqlBackend, PersistQueryWrite backend, MonadIO m) + => ReaderT backend m () +cleanDB = do + deleteWhere ([] :: [Filter StandardUnique]) + 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 + cleanDB + + -- These should both succeed with standard unique + k1 <- insert $ StandardUnique "user1" Nothing + k2 <- insert $ StandardUnique "user2" Nothing + + -- Verify both were inserted + count1 <- count [StandardUniqueName ==. "user1"] + count2 <- count [StandardUniqueName ==. "user2"] + + liftIO $ do + count1 `Lifted.shouldBe` 1 + count2 `Lifted.shouldBe` 1 + + it "standard unique prevents duplicate non-NULLs" $ do + ( runDb $ do + cleanDB + _ <- 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 + cleanDB + + -- 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 `Lifted.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 `Lifted.shouldBe` k2 + Nothing -> Hspec.expectationFailure "getBy should find non-NULL values" + + describe "PostgreSQL 15+ features" $ do + it "NULLS NOT DISTINCT prevents multiple NULLs (PostgreSQL 15+)" $ do + runDb $ do + supported <- isPostgres15OrHigher + when supported $ do + -- Run the migration to ensure constraint is created + void $ runMigrationSilent nullsNotDistinctMigrate + unless supported $ + liftIO $ + Hspec.pendingWith "Requires PostgreSQL 15 or higher" + + -- Now test the constraint enforcement separately + ( runDb $ do + cleanDB + void $ runMigrationSilent nullsNotDistinctMigrate + _ <- insert $ NullsNotDistinctUnique "user1" Nothing + -- Same name and email - this should violate the unique constraint + _ <- insert $ NullsNotDistinctUnique "user1" Nothing + return () + ) + `Hspec.shouldThrow` Hspec.anyException + + it "NULLS NOT DISTINCT with multiple nullable fields (PostgreSQL 15+)" $ do + -- First test that different NULL patterns work + runDb $ do + supported <- isPostgres15OrHigher + if supported + then do + cleanDB + + -- First record with NULLs + _ <- insert $ MultiFieldNND "test1" Nothing Nothing + + -- Different NULL pattern should succeed + _ <- insert $ MultiFieldNND "test1" (Just "value") Nothing + _ <- insert $ MultiFieldNND "test1" Nothing (Just 42) + + count' <- count ([] :: [Filter MultiFieldNND]) + liftIO $ count' `Hspec.shouldBe` 3 + else + liftIO $ Hspec.pendingWith "Requires PostgreSQL 15 or higher" + + -- Test duplicate prevention with same NULL pattern + ( runDb $ do + supported <- isPostgres15OrHigher + when supported $ do + cleanDB + _ <- insert $ MultiFieldNND "test1" Nothing Nothing + _ <- insert $ MultiFieldNND "test1" Nothing Nothing + return () + ) + `Hspec.shouldThrow` Hspec.anyException + + it "getBy finds NULL values with NULLS NOT DISTINCT (PostgreSQL 15+)" $ do + runDb $ do + supported <- isPostgres15OrHigher + if supported + then do + cleanDB + void $ runMigrationSilent nullsNotDistinctMigrate + + -- 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 + + -- We expect getBy TO find the entity with NULLS NOT DISTINCT + liftIO $ case result of + Just (Entity key _) -> key `Hspec.shouldBe` k1 + Nothing -> + Hspec.expectationFailure + "getBy should find NULL values when !nullsNotDistinct is set" + else + liftIO $ Hspec.pendingWith "Requires PostgreSQL 15 or higher" + + it "migration generates correct constraints" $ do + runDb $ do + -- Run migration to create tables + void $ runMigrationSilent nullsNotDistinctMigrate + + -- Check that constraints were created + -- This query checks PostgreSQL's information schema + 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'" + [] + + supported <- isPostgres15OrHigher + liftIO $ case constraints of + [] -> return () -- Tables might not exist yet + results -> do + -- Check if any constraint has NULLS NOT DISTINCT + let + hasNND = + any + ( \(Single _, Single def) -> + "NULLS NOT DISTINCT" `T.isInfixOf` def + ) + results + + when supported $ + hasNND `Hspec.shouldBe` True diff --git a/persistent-postgresql/test/main.hs b/persistent-postgresql/test/main.hs index 25d83a428..8ab638f28 100644 --- a/persistent-postgresql/test/main.hs +++ b/persistent-postgresql/test/main.hs @@ -48,6 +48,7 @@ import qualified MigrationReferenceSpec import qualified MigrationTest import qualified MpsCustomPrefixTest import qualified MpsNoPrefixTest +import qualified NullsNotDistinctTest import qualified PersistUniqueTest import qualified PersistentTest import qualified PgIntervalTest @@ -125,6 +126,7 @@ main = do , EmbedOrderTest.embedOrderMigrate , LargeNumberTest.numberMigrate , UniqueTest.uniqueMigrate + , NullsNotDistinctTest.nullsNotDistinctMigrate , MaxLenTest.maxlenMigrate , MaybeFieldDefsTest.maybeFieldDefMigrate , TypeLitFieldDefsTest.typeLitFieldDefsMigrate @@ -223,4 +225,5 @@ main = do UpsertWhere.specs PgIntervalTest.specs ArrayAggTest.specs + NullsNotDistinctTest.specs GeneratedColumnTestSQL.specsWith runConnAssert diff --git a/persistent/Database/Persist/Sql/Class.hs b/persistent/Database/Persist/Sql/Class.hs index 968d55b3a..dc0e4b8a4 100644 --- a/persistent/Database/Persist/Sql/Class.hs +++ b/persistent/Database/Persist/Sql/Class.hs @@ -847,7 +847,8 @@ to21 , u ) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u) -to21 ( (a, b) +to21 + ( (a, b) , (c, d) , (e, f) , (g, h) @@ -935,7 +936,8 @@ to22 , (u, v) ) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v) -to22 ( (a, b) +to22 + ( (a, b) , (c, d) , (e, f) , (g, h) @@ -1027,7 +1029,8 @@ to23 , w ) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w) -to23 ( (a, b) +to23 + ( (a, b) , (c, d) , (e, f) , (g, h) @@ -1121,7 +1124,8 @@ to24 , (w, x) ) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x) -to24 ( (a, b) +to24 + ( (a, b) , (c, d) , (e, f) , (g, h) @@ -1220,7 +1224,8 @@ to25 , y ) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y) -to25 ( (a, b) +to25 + ( (a, b) , (c, d) , (e, f) , (g, h) @@ -1321,7 +1326,8 @@ to26 , (y, z) ) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z) -to26 ( (a, b) +to26 + ( (a, b) , (c, d) , (e, f) , (g, h) @@ -1335,7 +1341,7 @@ to26 ( (a, b) , (w, x) , (y, z) ) = - (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z) + (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z) -- | @since 2.11.0 instance @@ -1446,7 +1452,8 @@ from27 , (y, z) , a2 ) -from27 ( a +from27 + ( a , b , c , d @@ -1474,21 +1481,21 @@ from27 ( a , z , a2 ) = - ( (a, b) - , (c, d) - , (e, f) - , (g, h) - , (i, j) - , (k, l) - , (m, n) - , (o, p) - , (q, r) - , (s, t) - , (u, v) - , (w, x) - , (y, z) - , a2 - ) + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , a2 + ) -- | @since 2.11.0 to27 @@ -1692,7 +1699,8 @@ from28 , (y, z) , (a2, b2) ) -from28 ( a +from28 + ( a , b , c , d @@ -1721,21 +1729,21 @@ from28 ( a , a2 , b2 ) = - ( (a, b) - , (c, d) - , (e, f) - , (g, h) - , (i, j) - , (k, l) - , (m, n) - , (o, p) - , (q, r) - , (s, t) - , (u, v) - , (w, x) - , (y, z) - , (a2, b2) - ) + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + ) -- | @since 2.11.0 to28 @@ -1945,7 +1953,8 @@ from29 , (a2, b2) , c2 ) -from29 ( a +from29 + ( a , b , c , d @@ -1975,22 +1984,22 @@ from29 ( a , b2 , c2 ) = - ( (a, b) - , (c, d) - , (e, f) - , (g, h) - , (i, j) - , (k, l) - , (m, n) - , (o, p) - , (q, r) - , (s, t) - , (u, v) - , (w, x) - , (y, z) - , (a2, b2) - , c2 - ) + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , c2 + ) -- | @since 2.11.0 to29 @@ -2207,7 +2216,8 @@ from30 , (a2, b2) , (c2, d2) ) -from30 ( a +from30 + ( a , b , c , d @@ -2238,22 +2248,22 @@ from30 ( a , c2 , d2 ) = - ( (a, b) - , (c, d) - , (e, f) - , (g, h) - , (i, j) - , (k, l) - , (m, n) - , (o, p) - , (q, r) - , (s, t) - , (u, v) - , (w, x) - , (y, z) - , (a2, b2) - , (c2, d2) - ) + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + ) -- | @since 2.11.0 to30 @@ -2476,7 +2486,8 @@ from31 , (c2, d2) , e2 ) -from31 ( a +from31 + ( a , b , c , d @@ -2508,23 +2519,23 @@ from31 ( a , d2 , e2 ) = - ( (a, b) - , (c, d) - , (e, f) - , (g, h) - , (i, j) - , (k, l) - , (m, n) - , (o, p) - , (q, r) - , (s, t) - , (u, v) - , (w, x) - , (y, z) - , (a2, b2) - , (c2, d2) - , e2 - ) + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , e2 + ) -- | @since 2.11.0 to31 @@ -2754,7 +2765,8 @@ from32 , (c2, d2) , (e2, f2) ) -from32 ( a +from32 + ( a , b , c , d @@ -2787,23 +2799,23 @@ from32 ( a , e2 , f2 ) = - ( (a, b) - , (c, d) - , (e, f) - , (g, h) - , (i, j) - , (k, l) - , (m, n) - , (o, p) - , (q, r) - , (s, t) - , (u, v) - , (w, x) - , (y, z) - , (a2, b2) - , (c2, d2) - , (e2, f2) - ) + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + ) -- | @since 2.11.0 to32 @@ -3039,7 +3051,8 @@ from33 , (e2, f2) , g2 ) -from33 ( a +from33 + ( a , b , c , d @@ -3073,24 +3086,24 @@ from33 ( a , f2 , g2 ) = - ( (a, b) - , (c, d) - , (e, f) - , (g, h) - , (i, j) - , (k, l) - , (m, n) - , (o, p) - , (q, r) - , (s, t) - , (u, v) - , (w, x) - , (y, z) - , (a2, b2) - , (c2, d2) - , (e2, f2) - , g2 - ) + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , g2 + ) -- | @since 2.11.0 to33 @@ -3333,7 +3346,8 @@ from34 , (e2, f2) , (g2, h2) ) -from34 ( a +from34 + ( a , b , c , d @@ -3368,24 +3382,24 @@ from34 ( a , g2 , h2 ) = - ( (a, b) - , (c, d) - , (e, f) - , (g, h) - , (i, j) - , (k, l) - , (m, n) - , (o, p) - , (q, r) - , (s, t) - , (u, v) - , (w, x) - , (y, z) - , (a2, b2) - , (c2, d2) - , (e2, f2) - , (g2, h2) - ) + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + ) -- | @since 2.11.0 to34 @@ -3634,7 +3648,8 @@ from35 , (g2, h2) , i2 ) -from35 ( a +from35 + ( a , b , c , d @@ -3670,25 +3685,25 @@ from35 ( a , h2 , i2 ) = - ( (a, b) - , (c, d) - , (e, f) - , (g, h) - , (i, j) - , (k, l) - , (m, n) - , (o, p) - , (q, r) - , (s, t) - , (u, v) - , (w, x) - , (y, z) - , (a2, b2) - , (c2, d2) - , (e2, f2) - , (g2, h2) - , i2 - ) + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , i2 + ) -- | @since 2.11.0 to35 diff --git a/persistent/Database/Persist/Sql/Orphan/PersistUnique.hs b/persistent/Database/Persist/Sql/Orphan/PersistUnique.hs index 4fa9ac4e5..3f2fc7f35 100644 --- a/persistent/Database/Persist/Sql/Orphan/PersistUnique.hs +++ b/persistent/Database/Persist/Sql/Orphan/PersistUnique.hs @@ -10,7 +10,7 @@ import Control.Monad.Trans.Reader (ask) import qualified Data.Conduit.List as CL import Data.Foldable (toList) import Data.Function (on) -import Data.List (nubBy) +import Data.List (find, nubBy) import qualified Data.Text as T import Database.Persist @@ -31,6 +31,37 @@ import Database.Persist.Sql.Util , updatePersistValue ) +checkHasNullsNotDistinct + :: (PersistEntity record) => Unique record -> EntityDef -> Bool +checkHasNullsNotDistinct uniq t = + let + uniqueFieldNames = toList $ persistUniqueToFieldNames uniq + matchingUnique = find (matchesUnique uniqueFieldNames) (getEntityUniques t) + in + case matchingUnique of + Just uniqueDef -> "!nullsNotDistinct" `elem` uniqueAttrs uniqueDef + Nothing -> False + where + matchesUnique uniqueFieldNames uniqueDef = + toList (uniqueFields uniqueDef) == uniqueFieldNames + +mkUniqueClause :: SqlBackend -> Bool -> FieldNameDB -> PersistValue -> T.Text +mkUniqueClause conn hasNullsNotDistinct fieldName val + | connRDBMS conn == "postgresql" && val == PersistNull && hasNullsNotDistinct = + connEscapeFieldName conn fieldName `mappend` " IS NOT DISTINCT FROM ?" + | otherwise = + connEscapeFieldName conn fieldName `mappend` "=?" + +buildUniqueWhereClause + :: (PersistEntity record) => SqlBackend -> Unique record -> EntityDef -> T.Text +buildUniqueWhereClause conn uniq t = + T.intercalate " AND " $ + zipWith (mkUniqueClause conn hasNullsNotDistinct) fieldNames uvals + where + fieldNames = toList $ fmap snd $ persistUniqueToFieldNames uniq + uvals = persistUniqueToValues uniq + hasNullsNotDistinct = checkHasNullsNotDistinct uniq t + instance PersistUniqueWrite SqlBackend where upsertBy uniqueKey record updates = do conn <- ask @@ -65,14 +96,12 @@ instance PersistUniqueWrite SqlBackend where rawExecute sql' vals where t = entityDef $ dummyFromUnique uniq - go = toList . fmap snd . persistUniqueToFieldNames - go' conn x = connEscapeFieldName conn x `mappend` "=?" sql conn = T.concat [ "DELETE FROM " , connEscapeTableName conn t , " WHERE " - , T.intercalate " AND " $ map (go' conn) $ go uniq + , buildUniqueWhereClause conn uniq t ] putMany [] = return () @@ -113,7 +142,7 @@ instance PersistUniqueRead SqlBackend where , " FROM " , connEscapeTableName conn t , " WHERE " - , sqlClause conn + , buildUniqueWhereClause conn uniq t ] uvals = persistUniqueToValues uniq withRawQuery sql uvals $ @@ -128,11 +157,7 @@ instance PersistUniqueRead SqlBackend where liftIO $ throwIO $ PersistMarshalError err Right r -> return $ Just r where - sqlClause conn = - T.intercalate " AND " $ map (go conn) $ toFieldNames' uniq - go conn x = connEscapeFieldName conn x `mappend` "=?" t = entityDef $ dummyFromUnique uniq - toFieldNames' = toList . fmap snd . persistUniqueToFieldNames existsBy uniq = do conn <- ask @@ -142,7 +167,7 @@ instance PersistUniqueRead SqlBackend where [ "SELECT EXISTS(SELECT 1 FROM " , connEscapeTableName conn t , " WHERE " - , sqlClause conn + , buildUniqueWhereClause conn uniq t , ")" ] uvals = persistUniqueToValues uniq @@ -150,11 +175,7 @@ instance PersistUniqueRead SqlBackend where mm <- CL.head return $ parseExistsResult mm sql "PersistUnique.existsBy" where - sqlClause conn = - T.intercalate " AND " $ map (go conn) $ toFieldNames' uniq - go conn x = connEscapeFieldName conn x `mappend` "=?" t = entityDef $ dummyFromUnique uniq - toFieldNames' = toList . fmap snd . persistUniqueToFieldNames instance PersistUniqueRead SqlReadBackend where getBy uniq = withBaseBackend $ getBy uniq diff --git a/persistent/Database/Persist/TH/Internal.hs b/persistent/Database/Persist/TH/Internal.hs index f2226b429..40f936464 100644 --- a/persistent/Database/Persist/TH/Internal.hs +++ b/persistent/Database/Persist/TH/Internal.hs @@ -1498,9 +1498,12 @@ mkUnique mps entityMap entDef (UniqueDef constr _ fields attrs) = fields force = "!force" `elem` attrs + nullsNotDistinct = "!nullsNotDistinct" `elem` attrs + -- If !nullsNotDistinct is specified, it implies !force since it explicitly handles NULL semantics + allowNullable = force || nullsNotDistinct go :: (UnboundFieldDef, IsNullable) -> (Strict, Type) - go (_, Nullable _) | not force = error nullErrMsg + go (_, Nullable _) | not allowNullable = error nullErrMsg go (fd, y) = (notStrict, maybeIdType mps entityMap fd Nothing (Just y)) lookup3 :: Text -> [UnboundFieldDef] -> (UnboundFieldDef, IsNullable) @@ -1522,9 +1525,9 @@ mkUnique mps entityMap entDef (UniqueDef constr _ fields attrs) = , "values to be equal for the purposes of an uniqueness constraint, " , "allowing insertion of more than one row with a NULL value for the " , "column in question. If you understand this feature of SQL and still " - , "intend to add a uniqueness constraint here, *** Use a \"!force\" " - , "attribute on the end of the line that defines your uniqueness " - , "constraint in order to disable this check. ***" + , "intend to add a uniqueness constraint here, you can either: " + , " *** Use \"!force\" to allow NULLs with standard SQL NULL semantics, OR" + , " *** Use \"!nullsNotDistinct\" (PostgreSQL 15+) to treat NULLs as equal. ***" ] -- | This function renders a Template Haskell 'Type' for an 'UnboundFieldDef'. diff --git a/persistent/Database/Persist/Types/Base.hs b/persistent/Database/Persist/Types/Base.hs index 408d407cc..422c2e1d1 100644 --- a/persistent/Database/Persist/Types/Base.hs +++ b/persistent/Database/Persist/Types/Base.hs @@ -700,7 +700,7 @@ data PersistUpdate | BackendSpecificUpdate T.Text deriving (Read, Show, Lift) --- | A 'FieldDef' represents the inormation that @persistent@ knows about +-- | A 'FieldDef' represents the information that @persistent@ knows about -- a field of a datatype. This includes information used to parse the field -- out of the database and what the field corresponds to. data FieldDef = FieldDef