yesodweb · parsonsmatt · Apr 1, 2021 · Apr 1, 2021 · Apr 1, 2021 · Apr 1, 2021
diff --git a/persistent-mysql/Database/Persist/MySQL.hs b/persistent-mysql/Database/Persist/MySQL.hs
@@ -320,7 +320,7 @@ getGetter field = go (MySQLBase.fieldType field)
     -- Controversial conversions
     go MySQLBase.Set        _ _  = convertPV PersistText
     go MySQLBase.Enum       _ _  = convertPV PersistText
-    -- Conversion using PersistDbSpecific
+    -- Conversion using PersistLiteral
     go MySQLBase.Geometry   _ _  = \_ m ->
       case m of
         Just g -> PersistLiteral g

diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs
@@ -6,7 +6,6 @@
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE ViewPatterns #-}
-{-# OPTIONS_GHC -fno-warn-deprecations #-} -- Pattern match 'PersistDbSpecific'
 
 -- | A postgresql backend for persistent.
 module Database.Persist.Postgresql

diff --git a/persistent-redis/ChangeLog.md b/persistent-redis/ChangeLog.md
@@ -1,3 +1,8 @@
+## 2.12.0.1 (unreleased)
+
+* [#1123](https://github.com/yesodweb/persistent/pull/1223):
+    * Changed the error message from trying to serialize a `PersistDbSpecific` value into `PersistLiteral_`.
+
 ## 2.12.0.0
 
 * Decomposed `HaskellName` into `ConstraintNameHS`, `EntityNameHS`, `FieldNameHS`. Decomposed `DBName` into `ConstraintNameDB`, `EntityNameDB`, `FieldNameDB` respectively. [#1174](https://github.com/yesodweb/persistent/pull/1174)

diff --git a/persistent-redis/Database/Persist/Redis/Parser.hs b/persistent-redis/Database/Persist/Redis/Parser.hs
@@ -1,4 +1,3 @@
-{-# OPTIONS_GHC -fno-warn-deprecations #-} -- Pattern match 'PersistDbSpecific'
 module Database.Persist.Redis.Parser
     ( redisToPerisistValues
     , toValue
@@ -128,9 +127,7 @@ instance Binary BinPersistValue where
         put x
 
     put (BinPersistValue (PersistArray _)) = throw $ NotSupportedValueType "PersistArray"
-    put (BinPersistValue (PersistDbSpecific _)) = throw $ NotSupportedValueType "PersistDbSpecific"
-    put (BinPersistValue (PersistLiteral _)) = throw $ NotSupportedValueType "PersistLiteral"
-    put (BinPersistValue (PersistLiteralEscaped _)) = throw $ NotSupportedValueType "PersistLiteralEscaped"
+    put (BinPersistValue (PersistLiteral_ _ _)) = throw $ NotSupportedValueType "PersistLiteral_"
     put (BinPersistValue (PersistObjectId _)) = throw $ NotSupportedValueType "PersistObjectId"
 
     get = do

diff --git a/persistent-redis/persistent-redis.cabal b/persistent-redis/persistent-redis.cabal
@@ -1,5 +1,5 @@
 name:            persistent-redis
-version:         2.12.0.0
+version:         2.12.0.1
 license:         BSD3
 license-file:    LICENSE
 author:          Pavel Ryzhov <paul@paulrz.cz>

diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md
@@ -1,5 +1,10 @@
 # Changelog for persistent
 
+## 2.12.0.2
+
+* [#1123](https://github.com/yesodweb/persistent/pull/1223)
+    * Fix JSON encoding for `PersistValue`
+
 ## 2.12.0.1
 
 * Refactoring token parsing in quasi module [#1206](https://github.com/yesodweb/persistent/pull/1206)

diff --git a/persistent/Database/Persist/Class/PersistField.hs b/persistent/Database/Persist/Class/PersistField.hs
@@ -3,7 +3,6 @@
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE PatternGuards, DataKinds, TypeOperators, UndecidableInstances #-}
-{-# OPTIONS_GHC -fno-warn-deprecations #-} -- Pattern match 'PersistDbSpecific'
 module Database.Persist.Class.PersistField
     ( PersistField (..)
     , SomePersistField (..)
@@ -113,9 +112,7 @@ instance {-# OVERLAPPING #-} PersistField [Char] where
     fromPersistValue (PersistBool b) = Right $ Prelude.show b
     fromPersistValue (PersistList _) = Left $ T.pack "Cannot convert PersistList to String"
     fromPersistValue (PersistMap _) = Left $ T.pack "Cannot convert PersistMap to String"
-    fromPersistValue (PersistDbSpecific _) = Left $ T.pack "Cannot convert PersistDbSpecific to String"
-    fromPersistValue (PersistLiteralEscaped _) = Left $ T.pack "Cannot convert PersistLiteralEscaped to String"
-    fromPersistValue (PersistLiteral _) = Left $ T.pack "Cannot convert PersistLiteral to String"
+    fromPersistValue (PersistLiteral_ _ _) = Left $ T.pack "Cannot convert PersistLiteral_ to String"
     fromPersistValue (PersistArray _) = Left $ T.pack "Cannot convert PersistArray to String"
     fromPersistValue (PersistObjectId _) = Left $ T.pack "Cannot convert PersistObjectId to String"
 #endif

diff --git a/persistent/Database/Persist/Sql/Class.hs b/persistent/Database/Persist/Sql/Class.hs
@@ -1135,12 +1135,12 @@ extractMaybe = fromMaybe (error "Database.Persist.GenericSql.extractMaybe")
 -- @
 -- import qualified Data.UUID as UUID
 -- instance 'PersistField' UUID where
---   'toPersistValue' = 'PersistDbSpecific' . toASCIIBytes
---   'fromPersistValue' ('PersistDbSpecific' uuid) =
+--   'toPersistValue' = 'PersistLiteralEncoded' . toASCIIBytes
+--   'fromPersistValue' ('PersistLiteralEncoded' uuid) =
 --     case fromASCIIBytes uuid of
 --       'Nothing' -> 'Left' $ "Model/CustomTypes.hs: Failed to deserialize a UUID; received: " <> T.pack (show uuid)
 --       'Just' uuid' -> 'Right' uuid'
---   'fromPersistValue' x = Left $ "File.hs: When trying to deserialize a UUID: expected PersistDbSpecific, received: "-- >  <> T.pack (show x)
+--   'fromPersistValue' x = Left $ "File.hs: When trying to deserialize a UUID: expected PersistLiteralEncoded, received: "-- >  <> T.pack (show x)
 --
 -- instance 'PersistFieldSql' UUID where
 --   'sqlType' _ = 'SqlOther' "uuid"

diff --git a/persistent/Database/Persist/Types/Base.hs b/persistent/Database/Persist/Types/Base.hs
@@ -637,9 +637,7 @@ fromPersistValueText (PersistList _) = Left "Cannot convert PersistList to Text"
 fromPersistValueText (PersistMap _) = Left "Cannot convert PersistMap to Text"
 fromPersistValueText (PersistObjectId _) = Left "Cannot convert PersistObjectId to Text"
 fromPersistValueText (PersistArray _) = Left "Cannot convert PersistArray to Text"
-fromPersistValueText (PersistDbSpecific _) = Left "Cannot convert PersistDbSpecific to Text"
-fromPersistValueText (PersistLiteral _) = Left "Cannot convert PersistLiteral to Text"
-fromPersistValueText (PersistLiteralEscaped _) = Left "Cannot convert PersistLiteralEscaped to Text"
+fromPersistValueText (PersistLiteral_ _ _) = Left "Cannot convert PersistLiteral to Text"
 
 instance A.ToJSON PersistValue where
     toJSON (PersistText t) = A.String $ T.cons 's' t
@@ -654,9 +652,15 @@ instance A.ToJSON PersistValue where
     toJSON PersistNull = A.Null
     toJSON (PersistList l) = A.Array $ V.fromList $ map A.toJSON l
     toJSON (PersistMap m) = A.object $ map (second A.toJSON) m
-    toJSON (PersistDbSpecific b) = A.String $ T.cons 'p' $ TE.decodeUtf8 $ B64.encode b
-    toJSON (PersistLiteral b) = A.String $ T.cons 'l' $ TE.decodeUtf8 $ B64.encode b
-    toJSON (PersistLiteralEscaped b) = A.String $ T.cons 'e' $ TE.decodeUtf8 $ B64.encode b
+    toJSON (PersistLiteral_ litTy b) =
+        let encoded = TE.decodeUtf8 $ B64.encode b
+            prefix =
+                case litTy of
+                    DbSpecific -> 'p'
+                    Unescaped -> 'l'
+                    Escaped -> 'e'
+         in
+            A.String $ T.cons prefix encoded
     toJSON (PersistArray a) = A.Array $ V.fromList $ map A.toJSON a
     toJSON (PersistObjectId o) =
       A.toJSON $ showChar 'o' $ showHexLen 8 (bs2i four) $ showHexLen 16 (bs2i eight) ""

diff --git a/persistent/persistent.cabal b/persistent/persistent.cabal
@@ -1,5 +1,5 @@
 name:            persistent
-version:         2.12.0.1
+version:         2.12.0.2
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>

diff --git a/persistent/test/main.hs b/persistent/test/main.hs
@@ -18,6 +18,8 @@ import Data.Semigroup ((<>))
 #endif
 import Data.Time
 import Text.Shakespeare.Text
+import Data.Aeson
+import qualified Data.ByteString.Char8 as BS8
 
 import Database.Persist.Class.PersistField
 import Database.Persist.Quasi
@@ -870,6 +872,34 @@ Baz
                 fromPersistValue (PersistText "2018-02-27 10:49:42.123")
                     `shouldBe` Right (UTCTime (fromGregorian 2018 02 27) (timeOfDayToTime (TimeOfDay 10 49 42.123)))
 
+    describe "PersistValue" $ do
+        describe "Aeson" $ do
+            let
+                testPrefix constr prefixChar bytes =
+                    takePrefix (toJSON (constr (BS8.pack bytes)))
+                    ===
+                    String (T.singleton prefixChar)
+                roundTrip constr bytes =
+                    fromJSON (toJSON (constr (BS8.pack bytes)))
+                    ===
+                    Data.Aeson.Success (constr (BS8.pack bytes))
+                subject constr prefixChar = do
+                    prop ("encodes with a " ++ [prefixChar] ++ " prefix") $
+                        testPrefix constr prefixChar
+                    prop "Round Trips" $
+                        roundTrip constr
+
+            describe "PersistDbSpecific" $ do
+                subject PersistDbSpecific 'p'
+            describe "PersistLiteral" $ do
+                subject PersistLiteral 'l'
+            describe "PersistLiteralEscaped" $ do
+                subject PersistLiteralEscaped 'e'
+
+takePrefix :: Value -> Value
+takePrefix (String a) = String (T.take 1 a)
+takePrefix a = a
+
 asTokens :: [T.Text] -> [Token]
 asTokens = fmap Token