Shared Primary Keys

persistent-template/ChangeLog.md

@@ -1,5 +1,12 @@
 ## Unreleased changes
 
+## 2.9.1.0
+
+* [#1145](https://github.com/yesodweb/persistent/pull/1148)
+    * Fix a bug where the `SqlType` for a shared primary key was being
+      incorrectly set to `SqlString` instead of whatever the target primary key
+      sql type was.
+
 ## 2.9
 
 * Always use the "stock" strategy when deriving Show/Read for keys [#1106](https://github.com/yesodweb/persistent/pull/1106)

persistent-template/Database/Persist/TH.hs

@@ -1677,7 +1677,7 @@ liftAndFixKeys entityMap EntityDef{..} =
     [|EntityDef
         entityHaskell
         entityDB
-        entityId
+        $(liftAndFixKey entityMap entityId)
         entityAttrs
         $(ListE <$> mapM (liftAndFixKey entityMap) entityFields)
         entityUniques

persistent-template/persistent-template.cabal

@@ -1,5 +1,5 @@
 name:            persistent-template
-version:         2.9
+version:         2.9.1.0
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -37,7 +37,11 @@ test-suite test
     type:            exitcode-stdio-1.0
     main-is:         main.hs
     hs-source-dirs:  test
-    other-modules:   TemplateTestImports
+    other-modules:   
+        TemplateTestImports
+      , SharedPrimaryKeyTest
+      , SharedPrimaryKeyTestImported
+
     ghc-options:     -Wall
 
     build-depends:   base                     >= 4.10 && < 5

persistent-template/test/SharedPrimaryKeyTest.hs

@@ -0,0 +1,57 @@
+{-# LANGUAGE TypeApplications, DeriveGeneric #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE StandaloneDeriving #-}
+
+module SharedPrimaryKeyTest where
+
+import TemplateTestImports
+
+import Data.Proxy
+import Test.Hspec
+import Database.Persist
+import Database.Persist.Sql
+import Database.Persist.Sql.Util
+import Database.Persist.TH
+
+share [ mkPersist sqlSettings ] [persistLowerCase|
+
+User
+    name    String
+
+-- TODO: uncomment this out.
+-- Profile
+--     Id      UserId
+--     email   String
+
+Profile
+    Id      (Key User)
+    email   String
+
+|]
+
+spec :: Spec
+spec = describe "Shared Primary Keys" $ do
+
+    describe "PersistFieldSql" $ do
+        it "should match underlying key" $ do
+            sqlType (Proxy @UserId)
+                `shouldBe`
+                    sqlType (Proxy @ProfileId)
+
+    describe "entityId FieldDef" $ do
+        it "should match underlying primary key" $ do
+            let getSqlType :: PersistEntity a => Proxy a -> SqlType
+                getSqlType =
+                    fieldSqlType . entityId . entityDef
+            getSqlType (Proxy @User)
+                `shouldBe`
+                    getSqlType (Proxy @Profile)

persistent-template/test/SharedPrimaryKeyTestImported.hs

@@ -0,0 +1,54 @@
+{-# LANGUAGE TypeApplications, DeriveGeneric #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE StandaloneDeriving #-}
+
+module SharedPrimaryKeyTestImported where
+
+import TemplateTestImports
+
+import Data.Proxy
+import Test.Hspec
+import Database.Persist
+import Database.Persist.Sql
+import Database.Persist.Sql.Util
+import Database.Persist.TH
+
+import SharedPrimaryKeyTest (User, UserId)
+
+share [ mkPersist sqlSettings ] [persistLowerCase|
+
+Profile
+    Id      UserId
+    email   String
+
+|]
+
+-- This test is very similar to the one in SharedPrimaryKeyTest, but it is
+-- able to use 'UserId' directly, since the type is imported from another
+-- module.
+spec :: Spec
+spec = describe "Shared Primary Keys Imported" $ do
+
+    describe "PersistFieldSql" $ do
+        it "should match underlying key" $ do
+            sqlType (Proxy @UserId)
+                `shouldBe`
+                    sqlType (Proxy @ProfileId)
+
+    describe "entityId FieldDef" $ do
+        it "should match underlying primary key" $ do
+            let getSqlType :: PersistEntity a => Proxy a -> SqlType
+                getSqlType =
+                    fieldSqlType . entityId . entityDef
+            getSqlType (Proxy @User)
+                `shouldBe`
+                    getSqlType (Proxy @Profile)

persistent-template/test/main.hs

@@ -41,6 +41,8 @@ import Database.Persist.Sql.Util
 import Database.Persist.TH
 import TemplateTestImports
 
+import qualified SharedPrimaryKeyTest
+import qualified SharedPrimaryKeyTestImported
 
 share [mkPersist sqlSettings { mpsGeneric = False, mpsDeriveInstances = [''Generic] }, mkDeleteCascade sqlSettings { mpsGeneric = False }] [persistUpperCase|
 Person json
@@ -106,6 +108,8 @@ instance Arbitrary Address where
 
 main :: IO ()
 main = hspec $ do
+    SharedPrimaryKeyTest.spec
+    SharedPrimaryKeyTestImported.spec
     describe "hasNaturalKey" $ do
         let subject :: PersistEntity a => Proxy a -> Bool
             subject p = hasNaturalKey (entityDef p)