From f16c119ec2afbaf5164f15301d4c2be12e402909 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Tue, 11 Feb 2020 17:34:47 -0700 Subject: [PATCH 1/4] add tests for bug --- persistent-test/src/PersistentTest.hs | 49 ++++++++++++++++++++- persistent-test/src/PersistentTestModels.hs | 14 ++++++ 2 files changed, 62 insertions(+), 1 deletion(-) diff --git a/persistent-test/src/PersistentTest.hs b/persistent-test/src/PersistentTest.hs index 3b2ea1f56..7e7a72c08 100644 --- a/persistent-test/src/PersistentTest.hs +++ b/persistent-test/src/PersistentTest.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE RecordWildCards, UndecidableInstances #-} + module PersistentTest ( module PersistentTest , cleanDB @@ -631,3 +632,49 @@ specsWith runDb = describe "persistent" $ do fieldComments nameField `shouldBe` Just "Fields should be documentable.\n" + + describe "JsonEncoding" $ do + let + subject = + JsonEncoding "Bob" 32 + subjectEntity = + Entity (JsonEncodingKey (jsonEncodingName subject)) subject + + it "encodes without an ID field" $ do + toJSON subjectEntity + `shouldBe` + Object (M.fromList + [ ("name", String "Bob") + , ("age", toJSON (32 :: Int)) + ]) + + it "decodes without an ID field" $ do + let + json = encode . Object . M.fromList $ + [ ("name", String "Bob") + , ("age", toJSON (32 :: Int)) + ] + decode json + `shouldBe` + Just subjectEntity + + prop "works with a Primary" $ \jsonEncoding -> do + let + ent = + Entity (JsonEncodingKey (jsonEncodingName jsonEncoding)) jsonEncoding + decode (encode ent) + `shouldBe` + Just ent + + prop "excuse me what" $ \j@JsonEncoding{..} -> do + let + ent = + Entity (JsonEncodingKey jsonEncodingName) j + toJSON ent + `shouldBe` + Object (M.fromList + [ ("name", toJSON jsonEncodingName) + , ("age", toJSON jsonEncodingAge) + ]) + + diff --git a/persistent-test/src/PersistentTestModels.hs b/persistent-test/src/PersistentTestModels.hs index 87836a272..07ebe7d42 100644 --- a/persistent-test/src/PersistentTestModels.hs +++ b/persistent-test/src/PersistentTestModels.hs @@ -5,6 +5,7 @@ module PersistentTestModels where import Data.Aeson +import Test.QuickCheck import Database.Persist.Sql import Database.Persist.TH import Init @@ -101,6 +102,7 @@ share [mkPersist persistSettings { mpsGeneric = True }, mkMigrate "testMigrate" -- | Fields should be documentable. name String parent RelationshipId Maybe + |] deriving instance Show (BackendKey backend) => Show (PetGeneric backend) @@ -118,8 +120,20 @@ NoPrefix2 unprefixedLeft Int unprefixedRight String deriving Show Eq + |] +share [mkPersist sqlSettings] [persistLowerCase| +JsonEncoding json + name Text + age Int + Primary name + deriving Show Eq +|] + +instance Arbitrary JsonEncoding where + arbitrary = JsonEncoding <$> arbitrary <*> arbitrary + deriving instance Show (BackendKey backend) => Show (NoPrefix1Generic backend) deriving instance Eq (BackendKey backend) => Eq (NoPrefix1Generic backend) From 915782f647f43137d3265a6cde53edd9ea970d18 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Mon, 30 Mar 2020 19:46:35 -0600 Subject: [PATCH 2/4] yes --- persistent/Database/Persist/Class/PersistEntity.hs | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/persistent/Database/Persist/Class/PersistEntity.hs b/persistent/Database/Persist/Class/PersistEntity.hs index b82652af7..96c9e2b42 100644 --- a/persistent/Database/Persist/Class/PersistEntity.hs +++ b/persistent/Database/Persist/Class/PersistEntity.hs @@ -22,7 +22,7 @@ module Database.Persist.Class.PersistEntity , toPersistValueEnum, fromPersistValueEnum ) where -import Data.Aeson (ToJSON (..), FromJSON (..), fromJSON, object, (.:), (.=), Value (Object)) +import Data.Aeson (ToJSON (..), withObject, FromJSON (..), fromJSON, object, (.:), (.=), Value (Object)) import qualified Data.Aeson.Parser as AP import Data.Aeson.Types (Parser,Result(Error,Success)) import Data.Aeson.Text (encodeToTextBuilder) @@ -38,6 +38,7 @@ import qualified Data.Text.Lazy.Builder as TB import Data.Typeable (Typeable) import GHC.Generics +import Database.Persist.Class.PersistEntity import Database.Persist.Class.PersistField import Database.Persist.Types.Base @@ -267,8 +268,14 @@ entityIdToJSON (Entity key value) = case toJSON value of -- parseJSON = entityIdFromJSON -- @ entityIdFromJSON :: (PersistEntity record, FromJSON record) => Value -> Parser (Entity record) -entityIdFromJSON value@(Object o) = Entity <$> o .: "id" <*> parseJSON value -entityIdFromJSON _ = fail "entityIdFromJSON: not an object" +entityIdFromJSON = withObject "entityIdFromJSON" $ \o -> do + val <- parseJSON (Object o) + k <- case keyFromRecordM val of + Nothing -> + o .: "id" + Just func -> + pure $ func val + pure $ Entity k val instance (PersistEntity record, PersistField record, PersistField (Key record)) => PersistField (Entity record) where From 059273b02b6e463b5441ae9a798fcfbc9483d439 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Mon, 30 Mar 2020 21:07:54 -0600 Subject: [PATCH 3/4] whatever --- .../Database/Persist/Class/PersistEntity.hs | 18 ++++-------------- 1 file changed, 4 insertions(+), 14 deletions(-) diff --git a/persistent/Database/Persist/Class/PersistEntity.hs b/persistent/Database/Persist/Class/PersistEntity.hs index e0d93ce6c..e06faffad 100644 --- a/persistent/Database/Persist/Class/PersistEntity.hs +++ b/persistent/Database/Persist/Class/PersistEntity.hs @@ -262,20 +262,10 @@ keyValueEntityFromJSON _ = fail "keyValueEntityFromJSON: not an object" -- toJSON = entityIdToJSON -- @ entityIdToJSON :: (PersistEntity record, ToJSON record) => Entity record -> Value -entityIdToJSON (Entity key value) = - case toJSON value of +entityIdToJSON (Entity key value) = case toJSON value of Object o -> Object $ HM.insert "id" (toJSON key) o x -> x --- | Like 'entityIdToJSON', but this does not copy the primary key into an --- @id@ field. --- --- @since 2.11.0.0 -entityIdToJSONCopyPrimary :: (PersistEntity record, ToJSON record) => Entity record -> Value -entityIdToJSONCopyPrimary (Entity key value) = case toJSON value of - Object o -> Object $ HM.insert "id" (toJSON key) o - x -> x - -- | Predefined @parseJSON@. The input JSON looks like -- @{"id": 1, "name": ...}@. -- @@ -288,11 +278,11 @@ entityIdToJSONCopyPrimary (Entity key value) = case toJSON value of entityIdFromJSON :: (PersistEntity record, FromJSON record) => Value -> Parser (Entity record) entityIdFromJSON = withObject "entityIdFromJSON" $ \o -> do val <- parseJSON (Object o) - k <- case ($ val) <$> keyFromRecordM of + k <- case keyFromRecordM of Nothing -> o .: "id" - Just key -> - pure key + Just func -> + pure $ func val pure $ Entity k val instance (PersistEntity record, PersistField record, PersistField (Key record)) From 795b11ee7962a27fa60ad025bc05e396f6cae2f2 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Mon, 30 Mar 2020 21:57:47 -0600 Subject: [PATCH 4/4] [ci skip] changelog --- persistent/ChangeLog.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index 2d0e51069..deb8e778b 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -13,6 +13,8 @@ * [#1063](https://github.com/yesodweb/persistent/pull/1063) * A new class member `keyFromRecordM` allows you to construct a `Key record` from a `record` if it was defined with `Primary`. +* [#1036](https://github.com/yesodweb/persistent/pull/1036): + * The method `entityIdFromJSON` that is used to parse entities now correctly works for entities that define a custom `Primary` key. ## 2.10.5.2