PersistLiteral pattern synonym

persistent-mysql/Database/Persist/MySQL.hs

@@ -247,9 +247,9 @@ instance MySQL.Param P where
     render (P (PersistRational r))    =
       MySQL.Plain $ BBB.fromString $ show (fromRational r :: Pico)
       -- FIXME: Too Ambiguous, can not select precision without information about field
-    render (P (PersistDbSpecific s))    = MySQL.Plain $ BBS.fromByteString s
-    render (P (PersistLiteral l))     = MySQL.Plain $ BBS.fromByteString l
-    render (P (PersistLiteralEscaped e)) = MySQL.Escape e
+    render (P (PersistLiteral_ DbSpecific s))    = MySQL.Plain $ BBS.fromByteString s
+    render (P (PersistLiteral_ Unescaped l))     = MySQL.Plain $ BBS.fromByteString l
+    render (P (PersistLiteral_ Escaped e)) = MySQL.Escape e
     render (P (PersistArray a))       = MySQL.render (P (PersistList a))
     render (P (PersistObjectId _))    =
         error "Refusing to serialize a PersistObjectId to a MySQL value"

persistent-postgresql/Database/Persist/Postgresql.hs

@@ -531,9 +531,9 @@ instance PGTF.ToField P where
     toField (P PersistNull)            = PGTF.toField PG.Null
     toField (P (PersistList l))        = PGTF.toField $ listToJSON l
     toField (P (PersistMap m))         = PGTF.toField $ mapToJSON m
-    toField (P (PersistDbSpecific s))  = PGTF.toField (Unknown s)
-    toField (P (PersistLiteral l))     = PGTF.toField (UnknownLiteral l)
-    toField (P (PersistLiteralEscaped e)) = PGTF.toField (Unknown e)
+    toField (P (PersistLiteral_ DbSpecific s))  = PGTF.toField (Unknown s)
+    toField (P (PersistLiteral_ Unescaped l))     = PGTF.toField (UnknownLiteral l)
+    toField (P (PersistLiteral_ Escaped e)) = PGTF.toField (Unknown e)
     toField (P (PersistArray a))       = PGTF.toField $ PG.PGArray $ P <$> a
     toField (P (PersistObjectId _))    =
         error "Refusing to serialize a PersistObjectId to a PostgreSQL value"
@@ -626,8 +626,9 @@ fromPersistValueError haskellType databaseType received = T.concat
 
 instance PersistField PgInterval where
     toPersistValue = PersistLiteralEscaped . pgIntervalToBs
-    fromPersistValue (PersistDbSpecific bs) = fromPersistValue (PersistLiteralEscaped bs)
-    fromPersistValue x@(PersistLiteralEscaped bs) =
+    fromPersistValue (PersistLiteral_ DbSpecific bs) =
+        fromPersistValue (PersistLiteralEscaped bs)
+    fromPersistValue x@(PersistLiteral_ Escaped bs) =
       case P.parseOnly (P.signed P.rational <* P.char 's' <* P.endOfInput) bs of
         Left _  -> Left $ fromPersistValueError "PgInterval" "Interval" x
         Right i -> Right $ PgInterval i

persistent-sqlite/Database/Sqlite.hs

@@ -96,7 +96,7 @@ import Database.Sqlite.Internal (Connection(..), Connection'(..), Statement(..))
 import Foreign
 import Foreign.C
 
-import Database.Persist (PersistValue (..), listToJSON, mapToJSON)
+import Database.Persist (PersistValue (..), listToJSON, mapToJSON, LiteralType(..))
 
 -- | A custom exception type to make it easier to catch exceptions.
 --
@@ -468,13 +468,13 @@ bind statement sqlData = do
             PersistUTCTime d -> bindText statement parameterIndex $ pack $ format8601 d
             PersistList l -> bindText statement parameterIndex $ listToJSON l
             PersistMap m -> bindText statement parameterIndex $ mapToJSON m
-            PersistDbSpecific s -> bindText statement parameterIndex $ decodeUtf8With lenientDecode s
             PersistArray a -> bindText statement parameterIndex $ listToJSON a -- copy of PersistList's definition
             PersistObjectId _ -> P.error "Refusing to serialize a PersistObjectId to a SQLite value"
 
             -- I know one of these is broken, but the docs for `sqlite3_bind_text` aren't very illuminating.
-            PersistLiteral l -> bindText statement parameterIndex $ decodeUtf8With lenientDecode l
-            PersistLiteralEscaped e -> bindText statement parameterIndex $ decodeUtf8With lenientDecode e
+            PersistLiteral_ DbSpecific s -> bindText statement parameterIndex $ decodeUtf8With lenientDecode s
+            PersistLiteral_ Unescaped l -> bindText statement parameterIndex $ decodeUtf8With lenientDecode l
+            PersistLiteral_ Escaped e -> bindText statement parameterIndex $ decodeUtf8With lenientDecode e
             )
        $ zip [1..] sqlData
   return ()

persistent/ChangeLog.md

@@ -23,6 +23,9 @@
 * [#1214](https://github.com/yesodweb/persistent/pull/1214):
     * Absorbed the `persistent-template` package. `persistent-template` will receive a 2.12 release with a warning and a deprecation notice.
     * Remove the `nooverlap` flag. It wasn't being used anymore.
+* [#1205](https://github.com/yesodweb/persistent/pull/1205)
+    * Introduce the `PersistLiteral_` constructor, replacing the `PersistLiteral`, `PersistLiteralEscaped`, and `PersistDbSpecific`.
+    * The old constructors are now pattern synonyms. They don't actually differentiate between the various escaping strategies when consuming them! If you pattern match on multiple of `PersistDbSpecific`, `PersistLiteral`, or `PersistLiteralEscaped` , then you should use the `PersistLiteral_` constructor to differentiate between them.
 
 ## 2.11.0.2
 * Fix a bug where an empty entity definition would break parsing of `EntityDef`s. [#1176](https://github.com/yesodweb/persistent/issues/1176)

persistent/Database/Persist/Types/Base.hs

@@ -1,8 +1,12 @@
 {-# LANGUAGE CPP #-}
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE LambdaCase, PatternSynonyms #-}
 {-# LANGUAGE DeriveLift #-}
 {-# OPTIONS_GHC -fno-warn-deprecations #-} -- usage of Error typeclass
-module Database.Persist.Types.Base where
+module Database.Persist.Types.Base
+    ( module Database.Persist.Types.Base
+    , PersistValue(.., PersistLiteral, PersistLiteralEscaped, PersistDbSpecific)
+    , LiteralType(..)
+    ) where
 
 import Control.Arrow (second)
 import Control.Exception (Exception)
@@ -529,37 +533,73 @@ data PersistValue
     | PersistMap [(Text, PersistValue)]
     | PersistObjectId ByteString -- ^ Intended especially for MongoDB backend
     | PersistArray [PersistValue] -- ^ Intended especially for PostgreSQL backend for text arrays
-    | PersistLiteral ByteString -- ^ Using 'PersistLiteral' allows you to use types or keywords specific to a particular backend.
-    | PersistLiteralEscaped ByteString -- ^ Similar to 'PersistLiteral', but escapes the @ByteString@.
-    | PersistDbSpecific ByteString -- ^ Using 'PersistDbSpecific' allows you to use types specific to a particular backend.
--- For example, below is a simple example of the PostGIS geography type:
---
--- @
--- data Geo = Geo ByteString
---
--- instance PersistField Geo where
---   toPersistValue (Geo t) = PersistDbSpecific t
---
---   fromPersistValue (PersistDbSpecific t) = Right $ Geo $ Data.ByteString.concat ["'", t, "'"]
---   fromPersistValue _ = Left "Geo values must be converted from PersistDbSpecific"
+    | PersistLiteral_ LiteralType ByteString
+    -- ^ This constructor is used to specify some raw literal value for the
+    -- backend. The 'LiteralType' value specifies how the value should be
+    -- escaped. This can be used to make special, custom types avaialable
+    -- in the back end.
+    --
+    -- @since 2.12.0.0
+    deriving (Show, Read, Eq, Ord)
+
+-- | A type that determines how a backend should handle the literal.
 --
--- instance PersistFieldSql Geo where
---   sqlType _ = SqlOther "GEOGRAPHY(POINT,4326)"
+-- @since 2.12.0.0
+data LiteralType
+    = Escaped
+    -- ^ The accompanying value will be escaped before inserting into the
+    -- database. This is the correct default choice to use.
+    --
+    -- @since 2.12.0.0
+    | Unescaped
+    -- ^ The accompanying value will not be escaped when inserting into the
+    -- database. This is potentially dangerous - use this with care.
+    --
+    -- @since 2.12.0.0
+    | DbSpecific
+    -- ^ The 'DbSpecific' constructor corresponds to the legacy
+    -- 'PersistDbSpecific' constructor. We need to keep this around because
+    -- old databases may have serialized JSON representations that
+    -- reference this. We don't want to break the ability of a database to
+    -- load rows.
+    --
+    -- @since 2.12.0.0
+    deriving (Show, Read, Eq, Ord)
+
+-- | This pattern synonym used to be a data constructor for the
+-- 'PersistValue' type. It was changed to be a pattern so that JSON-encoded
+-- database values could be parsed into their corresponding values. You
+-- should not use this, and instead prefer to pattern match on
+-- `PersistLiteral_` directly.
 --
--- toPoint :: Double -> Double -> Geo
--- toPoint lat lon = Geo $ Data.ByteString.concat ["'POINT(", ps $ lon, " ", ps $ lat, ")'"]
---   where ps = Data.Text.pack . show
--- @
+-- If you use this, it will overlap a patern match on the 'PersistLiteral_,
+-- 'PersistLiteral', and 'PersistLiteralEscaped' patterns. If you need to
+-- disambiguate between these constructors, pattern match on
+-- 'PersistLiteral_' directly.
 --
--- If Foo has a geography field, we can then perform insertions like the following:
+-- @since 2.12.0.0
+pattern PersistDbSpecific bs <- PersistLiteral_ _ bs where
+    PersistDbSpecific bs = PersistLiteral_ DbSpecific bs
+
+-- | This pattern synonym used to be a data constructor on 'PersistValue',
+-- but was changed into a catch-all pattern synonym to allow backwards
+-- compatiblity with database types. See the documentation on
+-- 'PersistDbSpecific' for more details.
 --
--- @
--- insert $ Foo (toPoint 44 44)
--- @
+-- @since 2.12.0.0
+pattern PersistLiteralEscaped bs <- PersistLiteral_ _ bs where
+    PersistLiteralEscaped bs = PersistLiteral_ Escaped bs
+
+-- | This pattern synonym used to be a data constructor on 'PersistValue',
+-- but was changed into a catch-all pattern synonym to allow backwards
+-- compatiblity with database types. See the documentation on
+-- 'PersistDbSpecific' for more details.
 --
-    deriving (Show, Read, Eq, Ord)
+-- @since 2.12.0.0
+pattern PersistLiteral bs <- PersistLiteral_ _ bs where
+    PersistLiteral bs = PersistLiteral_ Unescaped bs
 
-{-# DEPRECATED PersistDbSpecific "Deprecated since 2.11 because of inconsistent escaping behavior across backends. The Postgres backend escapes these values, while the MySQL backend does not. If you are using this, please switch to 'PersistLiteral' or 'PersistLiteralEscaped' based on your needs." #-}
+{-# DEPRECATED PersistDbSpecific "Deprecated since 2.11 because of inconsistent escaping behavior across backends. The Postgres backend escapes these values, while the MySQL backend does not. If you are using this, please switch to 'PersistLiteral_' and provide a relevant 'LiteralType' for your conversion." #-}
 
 instance ToHttpApiData PersistValue where
     toUrlPiece val =