JSON instances require an extraneous id field for entities with a Primary

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

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)
+            ])
+
+

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)
 

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
 

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