Merge pull request yesodweb#466 from yesodweb/mysqlForeignKeyReference

Fix adding a foreign key reference to a custom primary key for MySQL

persistent-mysql/Database/Persist/MySQL.hs

@@ -378,23 +378,28 @@ findMaxLenOfColumn allDefs name col =
            maxLenAttr <- find ((T.isPrefixOf "maxlen=") . T.toLower) (fieldAttrs fieldDef)
            readMaybe . T.unpack . T.drop 7 $ maxLenAttr
 
--- | Helper for 'AddRefence' that finds out the 'entityId'.
+-- | Helper for 'AddReference' that finds out the which primary key columns to reference.
 addReference :: [EntityDef] -> DBName -> DBName -> DBName -> AlterColumn
-addReference allDefs fkeyname reftable cname = AddReference reftable fkeyname [cname] [id_] 
+addReference allDefs fkeyname reftable cname = AddReference reftable fkeyname [cname] referencedColumns
     where
-      id_ = maybe (error $ "Could not find ID of entity " ++ show reftable
-                         ++ " (allDefs = " ++ show allDefs ++ ")")
-                  id $ do
-                    entDef <- find ((== reftable) . entityDB) allDefs
-                    return (fieldDB $ entityId entDef)
+      referencedColumns = maybe (error $ "Could not find ID of entity " ++ show reftable
+                                  ++ " (allDefs = " ++ show allDefs ++ ")")
+                                id $ do
+                                  entDef <- find ((== reftable) . entityDB) allDefs
+                                  return $ map fieldDB $ entityKeyFields entDef
 
 data AlterColumn = Change Column
                  | Add' Column
                  | Drop
                  | Default String
                  | NoDefault
                  | Update' String
-                 | AddReference DBName DBName [DBName] [DBName]
+                 -- | See the definition of the 'showAlter' function to see how these fields are used.
+                 | AddReference
+                    DBName -- ^ Referenced table
+                    DBName -- ^ Foreign key name
+                    [DBName] -- ^ Referencing columns
+                    [DBName] -- ^ Referenced columns
                  | DropReference DBName
 
 type AlterColumn' = (DBName, AlterColumn)

persistent-test/CustomPrimaryKeyReferenceTest.hs

@@ -0,0 +1,54 @@
+{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}
+
+-- This test is based on this issue: https://github.com/yesodweb/persistent/issues/421
+-- The primary thing this is testing is the migration, thus the test code itself being mostly negligible.
+module CustomPrimaryKeyReferenceTest where
+
+import Init
+
+-- mpsGeneric = False is due to a bug or at least lack of a feature in mkKeyTypeDec TH.hs
+#if WITH_NOSQL
+mkPersist persistSettings { mpsGeneric = False } [persistUpperCase|
+#else
+share [mkPersist persistSettings { mpsGeneric = False }, mkMigrate "migration"] [persistLowerCase|
+#endif
+  Tweet
+    tweetId Int
+    statusText Text sqltype=varchar(170)
+    Primary tweetId
+    UniqueTweetId tweetId
+    deriving Show
+  TweetUrl
+    tweetId TweetId
+    tweetUrl Text sqltype=varchar(255)
+    finalUrl Text Maybe sqltype=varchar(255)
+    UniqueTweetIdTweetUrl tweetId tweetUrl
+    deriving Show
+|]
+#ifdef WITH_NOSQL
+cleanDB :: (MonadIO m, PersistQuery backend, PersistEntityBackend Tweet ~ backend) => ReaderT backend m ()
+cleanDB = do
+  deleteWhere ([] :: [Filter Tweet])
+  deleteWhere ([] :: [Filter TweetUrl])
+
+db :: Action IO () -> Assertion
+db = db' cleanDB
+#endif
+
+specs :: Spec
+specs = describe "custom primary key reference" $ do
+#ifdef WITH_NOSQL
+  return ()
+#else
+
+  let tweet = Tweet {tweetTweetId = 1, tweetStatusText = "Hello!"}
+
+  it "can insert a Tweet" $ db $ do
+    tweetId <- insert tweet
+    let url = TweetUrl {tweetUrlTweetId = tweetId, tweetUrlTweetUrl = "http://google.com", tweetUrlFinalUrl = Just "http://example.com"}
+    u <- insert url
+    return ()
+
+  return ()
+
+#endif

persistent-test/persistent-test.cabal

@@ -86,6 +86,7 @@ library
                      PrimaryTest
                      CustomPersistField
                      CustomPersistFieldTest
+                     CustomPrimaryKeyReferenceTest
 
                      Database.Persist
                      Database.Persist.Quasi

persistent-test/test/main.hs

@@ -19,6 +19,7 @@ import qualified PersistUniqueTest
 import qualified CompositeTest
 import qualified PrimaryTest
 import qualified CustomPersistFieldTest
+import qualified CustomPrimaryKeyReferenceTest
 import Test.Hspec (hspec)
 import Test.Hspec.Runner
 import Init
@@ -67,6 +68,7 @@ main = do
 #  ifndef WITH_MYSQL
       , PrimaryTest.migration
 #  endif
+      , CustomPrimaryKeyReferenceTest.migration
       ]
     PersistentTest.cleanDB
 #endif
@@ -89,6 +91,7 @@ main = do
     PersistUniqueTest.specs
     PrimaryTest.specs
     CustomPersistFieldTest.specs
+    CustomPrimaryKeyReferenceTest.specs
 
 #ifndef WITH_NOSQL
     MigrationTest.specs