From f81f111bd5b6f4407912b5edfacf5c84972c6dfa Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Fri, 30 Oct 2020 21:00:25 -0600 Subject: [PATCH 1/5] Add test for shared primary keys --- persistent-template/persistent-template.cabal | 5 +- .../test/SharedPrimaryKeyTest.hs | 58 +++++++++++++++++++ persistent-template/test/main.hs | 2 + 3 files changed, 64 insertions(+), 1 deletion(-) create mode 100644 persistent-template/test/SharedPrimaryKeyTest.hs diff --git a/persistent-template/persistent-template.cabal b/persistent-template/persistent-template.cabal index 99f0ee216..ad89c52c1 100644 --- a/persistent-template/persistent-template.cabal +++ b/persistent-template/persistent-template.cabal @@ -37,7 +37,10 @@ test-suite test type: exitcode-stdio-1.0 main-is: main.hs hs-source-dirs: test - other-modules: TemplateTestImports + other-modules: + TemplateTestImports + , SharedPrimaryKeyTest + ghc-options: -Wall build-depends: base >= 4.10 && < 5 diff --git a/persistent-template/test/SharedPrimaryKeyTest.hs b/persistent-template/test/SharedPrimaryKeyTest.hs new file mode 100644 index 000000000..37cf72e41 --- /dev/null +++ b/persistent-template/test/SharedPrimaryKeyTest.hs @@ -0,0 +1,58 @@ +{-# 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 userIdDef = + fieldSqlType $ entityId $ entityDef $ Proxy @User + profileIdDef = + fieldSqlType $ entityId $ entityDef $ Proxy @Profile + profileIdDef + `shouldBe` + userIdDef diff --git a/persistent-template/test/main.hs b/persistent-template/test/main.hs index 25e602bbb..3614fa1ae 100644 --- a/persistent-template/test/main.hs +++ b/persistent-template/test/main.hs @@ -41,6 +41,7 @@ import Database.Persist.Sql.Util import Database.Persist.TH import TemplateTestImports +import qualified SharedPrimaryKeyTest share [mkPersist sqlSettings { mpsGeneric = False, mpsDeriveInstances = [''Generic] }, mkDeleteCascade sqlSettings { mpsGeneric = False }] [persistUpperCase| Person json @@ -106,6 +107,7 @@ instance Arbitrary Address where main :: IO () main = hspec $ do + SharedPrimaryKeyTest.spec describe "hasNaturalKey" $ do let subject :: PersistEntity a => Proxy a -> Bool subject p = hasNaturalKey (entityDef p) From d9030cb3f57508ffbf0f2bcbea42adeaefe6384d Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Fri, 30 Oct 2020 21:15:28 -0600 Subject: [PATCH 2/5] More tests, fix the issue --- persistent-template/ChangeLog.md | 7 +++ persistent-template/Database/Persist/TH.hs | 2 +- persistent-template/persistent-template.cabal | 3 +- .../test/SharedPrimaryKeyTest.hs | 11 ++-- .../test/SharedPrimaryKeyTestImported.hs | 54 +++++++++++++++++++ persistent-template/test/main.hs | 2 + 6 files changed, 71 insertions(+), 8 deletions(-) create mode 100644 persistent-template/test/SharedPrimaryKeyTestImported.hs diff --git a/persistent-template/ChangeLog.md b/persistent-template/ChangeLog.md index 09198c7b9..3a0885831 100644 --- a/persistent-template/ChangeLog.md +++ b/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) diff --git a/persistent-template/Database/Persist/TH.hs b/persistent-template/Database/Persist/TH.hs index b4c74b4ac..f112c9bed 100644 --- a/persistent-template/Database/Persist/TH.hs +++ b/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 diff --git a/persistent-template/persistent-template.cabal b/persistent-template/persistent-template.cabal index ad89c52c1..63688967f 100644 --- a/persistent-template/persistent-template.cabal +++ b/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 @@ -40,6 +40,7 @@ test-suite test other-modules: TemplateTestImports , SharedPrimaryKeyTest + , SharedPrimaryKeyTestImported ghc-options: -Wall diff --git a/persistent-template/test/SharedPrimaryKeyTest.hs b/persistent-template/test/SharedPrimaryKeyTest.hs index 37cf72e41..928db0999 100644 --- a/persistent-template/test/SharedPrimaryKeyTest.hs +++ b/persistent-template/test/SharedPrimaryKeyTest.hs @@ -49,10 +49,9 @@ spec = describe "Shared Primary Keys" $ do describe "entityId FieldDef" $ do it "should match underlying primary key" $ do - let userIdDef = - fieldSqlType $ entityId $ entityDef $ Proxy @User - profileIdDef = - fieldSqlType $ entityId $ entityDef $ Proxy @Profile - profileIdDef + let getSqlType :: PersistEntity a => Proxy a -> SqlType + getSqlType = + fieldSqlType . entityId . entityDef + getSqlType (Proxy @User) `shouldBe` - userIdDef + getSqlType (Proxy @Profile) diff --git a/persistent-template/test/SharedPrimaryKeyTestImported.hs b/persistent-template/test/SharedPrimaryKeyTestImported.hs new file mode 100644 index 000000000..9c2580aab --- /dev/null +++ b/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) diff --git a/persistent-template/test/main.hs b/persistent-template/test/main.hs index 3614fa1ae..84a5aae1c 100644 --- a/persistent-template/test/main.hs +++ b/persistent-template/test/main.hs @@ -42,6 +42,7 @@ 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 @@ -108,6 +109,7 @@ 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) From 90971f14012faf5ce70acf873564e5a6f0b4aba9 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Fri, 30 Oct 2020 21:18:47 -0600 Subject: [PATCH 3/5] link to issue --- persistent-template/test/SharedPrimaryKeyTest.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/persistent-template/test/SharedPrimaryKeyTest.hs b/persistent-template/test/SharedPrimaryKeyTest.hs index 928db0999..7ab88d41e 100644 --- a/persistent-template/test/SharedPrimaryKeyTest.hs +++ b/persistent-template/test/SharedPrimaryKeyTest.hs @@ -27,7 +27,7 @@ share [ mkPersist sqlSettings ] [persistLowerCase| User name String --- TODO: uncomment this out. +-- TODO: uncomment this out https://github.com/yesodweb/persistent/issues/1149 -- Profile -- Id UserId -- email String From f4772f7ac3f544912812e3f51fc9243035b297b8 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Fri, 30 Oct 2020 21:26:03 -0600 Subject: [PATCH 4/5] sigh --- .github/workflows/haskell.yml | 1 - 1 file changed, 1 deletion(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index b13989444..421b71bc6 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -61,7 +61,6 @@ jobs: with: path: | ${{ steps.setup-haskell-cabal.outputs.cabal-store }} - dist-newstyle key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} restore-keys: | ${{ runner.os }}-${{ matrix.ghc }}- From 06aae3187176c32337b51468b0b424fb773c315b Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Fri, 30 Oct 2020 22:48:10 -0600 Subject: [PATCH 5/5] ok --- .github/workflows/haskell.yml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 421b71bc6..c616d778b 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -63,7 +63,8 @@ jobs: ${{ steps.setup-haskell-cabal.outputs.cabal-store }} key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} restore-keys: | - ${{ runner.os }}-${{ matrix.ghc }}- + ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} + # ${{ runner.os }}-${{ matrix.ghc }}- - run: cabal v2-build all --disable-optimization --only-dependencies $CONFIG - run: cabal v2-build all --disable-optimization $CONFIG - run: cabal v2-test all --disable-optimization $CONFIG