diff --git a/persistent-template/Database/Persist/TH.hs b/persistent-template/Database/Persist/TH.hs index 75ad5147f..562ea9a22 100644 --- a/persistent-template/Database/Persist/TH.hs +++ b/persistent-template/Database/Persist/TH.hs @@ -443,8 +443,8 @@ data MkPersistSettings = MkPersistSettings -- -- @ -- Just EntityJSON - -- { entityToJSON = 'keyValueEntityToJSON - -- , entityFromJSON = 'keyValueEntityFromJSON + -- { entityToJSON = 'entityIdToJSON + -- , entityFromJSON = 'entityIdFromJSON -- } -- @ , mpsGenerateLenses :: !Bool diff --git a/persistent-test/src/PersistentTest.hs b/persistent-test/src/PersistentTest.hs index cc4d9b9f5..3c79129b5 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 @@ -632,3 +633,74 @@ 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)) + , ("id", String "Bob") + ]) + + 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) + , ("id", toJSON jsonEncodingName) + ]) + + prop "round trip works with composite key" $ \j@JsonEncoding2{..} -> do + let + key = JsonEncoding2Key jsonEncoding2Name jsonEncoding2Blood + ent = + Entity key j + decode (encode ent) + `shouldBe` + Just ent + + prop "works with a composite key" $ \j@JsonEncoding2{..} -> do + let + key = JsonEncoding2Key jsonEncoding2Name jsonEncoding2Blood + ent = + Entity key j + toJSON ent + `shouldBe` + Object (M.fromList + [ ("name", toJSON jsonEncoding2Name) + , ("age", toJSON jsonEncoding2Age) + , ("blood", toJSON jsonEncoding2Blood) + , ("id", toJSON key) + ]) + + diff --git a/persistent-test/src/PersistentTestModels.hs b/persistent-test/src/PersistentTestModels.hs index d073baf1e..46a30c15c 100644 --- a/persistent-test/src/PersistentTestModels.hs +++ b/persistent-test/src/PersistentTestModels.hs @@ -1,10 +1,12 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE UndecidableInstances #-} -- FIXME module PersistentTestModels where import Data.Aeson +import Test.QuickCheck import Database.Persist.Sql import Database.Persist.TH import Init @@ -107,7 +109,6 @@ share [mkPersist persistSettings { mpsGeneric = True }, mkMigrate "testMigrate" MutB mutA MutAId - |] deriving instance Show (BackendKey backend) => Show (PetGeneric backend) @@ -125,8 +126,30 @@ NoPrefix2 unprefixedLeft Int unprefixedRight String deriving Show Eq + +|] + +share [mkPersist sqlSettings] [persistLowerCase| +JsonEncoding json + name Text + age Int + Primary name + deriving Show Eq + +JsonEncoding2 json + name Text + age Int + blood Text + Primary name blood + deriving Show Eq |] +instance Arbitrary JsonEncoding where + arbitrary = JsonEncoding <$> arbitrary <*> arbitrary + +instance Arbitrary JsonEncoding2 where + arbitrary = JsonEncoding2 <$> arbitrary <*> arbitrary <*> arbitrary + deriving instance Show (BackendKey backend) => Show (NoPrefix1Generic backend) deriving instance Eq (BackendKey backend) => Eq (NoPrefix1Generic backend) 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 diff --git a/persistent/Database/Persist/Class/PersistEntity.hs b/persistent/Database/Persist/Class/PersistEntity.hs index 4ee0fadcd..e06faffad 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) @@ -263,8 +263,8 @@ keyValueEntityFromJSON _ = fail "keyValueEntityFromJSON: not an object" -- @ entityIdToJSON :: (PersistEntity record, ToJSON record) => Entity record -> Value entityIdToJSON (Entity key value) = case toJSON value of - Object o -> Object $ HM.insert "id" (toJSON key) o - x -> x + Object o -> Object $ HM.insert "id" (toJSON key) o + x -> x -- | Predefined @parseJSON@. The input JSON looks like -- @{"id": 1, "name": ...}@. @@ -276,8 +276,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 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