Fix postgres add reference (#1290)

* Fix add reference * Changelog/cabal * no
yesodweb · Jun 18, 2021 · 2aa65e2 · 2aa65e2
1 parent 6de3ffe
commit 2aa65e2
Show file tree

Hide file tree

Showing 5 changed files with 66 additions and 2 deletions.
diff --git a/persistent-postgresql/ChangeLog.md b/persistent-postgresql/ChangeLog.md
@@ -1,5 +1,10 @@
 # Changelog for persistent-postgresql
 
+## 2.13.0.3
+
+* [#1290](https://github.com/yesodweb/persistent/pull/1290)
+    * Fix the code path for adding references to previously defined columns.
+
 ## 2.13.0.2
 
 * Actually release the SafeTORemove fix

diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs
@@ -1268,7 +1268,7 @@ findAlters defs edef col@(Column name isNull sqltype def _gen _defConstraintName
                             | Just _oldName /= fmap fieldDB (getEntityIdField edef)
                             ->
                             [AddReference
-                                (getEntityDBName edef)
+                                (crTableName colRef)
                                 (crConstraintName colRef)
                                 [name]
                                 (NEL.toList $ Util.dbIdColumnsEsc escapeF refdef)

diff --git a/persistent-postgresql/persistent-postgresql.cabal b/persistent-postgresql/persistent-postgresql.cabal
@@ -1,5 +1,5 @@
 name:            persistent-postgresql
-version:         2.13.0.2
+version:         2.13.0.3
 license:         MIT
 license-file:    LICENSE
 author:          Felipe Lessa, Michael Snoyman <michael@snoyman.com>
@@ -55,6 +55,7 @@ test-suite test
                      PgIntervalTest
                      UpsertWhere
                      ImplicitUuidSpec
+                     MigrationReferenceSpec
     ghc-options:     -Wall
 
     build-depends:   base                 >= 4.9 && < 5

diff --git a/persistent-postgresql/test/MigrationReferenceSpec.hs b/persistent-postgresql/test/MigrationReferenceSpec.hs
@@ -0,0 +1,56 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE OverloadedStrings, DataKinds, FlexibleInstances #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# OPTIONS_GHC -Wno-unused-top-binds #-}
+
+module MigrationReferenceSpec where
+
+import PgInit
+
+import Control.Monad.Trans.Writer (censor, mapWriterT)
+import Data.Text (Text, isInfixOf)
+
+share [mkPersist sqlSettings, mkMigrate "referenceMigrate"] [persistLowerCase|
+
+LocationCapabilities
+    Id Text
+    bio Text
+
+LocationCapabilitiesPrintingProcess
+    locationCapabilitiesId LocationCapabilitiesId
+
+LocationCapabilitiesPrintingFinish
+    locationCapabilitiesId LocationCapabilitiesId
+
+LocationCapabilitiesSubstrate
+    locationCapabilitiesId LocationCapabilitiesId
+
+|]
+
+spec :: Spec
+spec = describe "MigrationReferenceSpec" $ do
+    it "works" $ runConnAssert $ do
+        let
+            noForeignKeys :: CautiousMigration -> CautiousMigration
+            noForeignKeys = filter ((not . isReference) . snd)
+
+            onlyForeignKeys :: CautiousMigration -> CautiousMigration
+            onlyForeignKeys = filter (isReference . snd)
+
+            isReference :: Text -> Bool
+            isReference migration = "REFERENCES" `isInfixOf` migration
+
+        runMigration
+            $ mapWriterT (censor noForeignKeys)
+            $ referenceMigrate
+
+        runMigration
+            $ mapWriterT (censor onlyForeignKeys)
+            $ referenceMigrate
diff --git a/persistent-postgresql/test/main.hs b/persistent-postgresql/test/main.hs
@@ -57,6 +57,7 @@ import qualified CustomConstraintTest
 import qualified LongIdentifierTest
 import qualified PgIntervalTest
 import qualified GeneratedColumnTestSQL
+import qualified MigrationReferenceSpec
 
 type Tuple = (,)
 
@@ -138,6 +139,7 @@ main = do
 
   hspec $ do
       ImplicitUuidSpec.spec
+      MigrationReferenceSpec.spec
       RenameTest.specsWith runConnAssert
       DataTypeTest.specsWith runConnAssert
           (Just (runMigrationSilent dataTypeMigrate))