Introduce BackendCompatible class

persistent-mysql/Database/Persist/MySQL.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -28,7 +29,7 @@ import Control.Monad.Logger (MonadLogger, runNoLoggingT)
 import Control.Monad.IO.Class (MonadIO (..))
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.Except (runExceptT)
-import Control.Monad.Trans.Reader (runReaderT)
+import Control.Monad.Trans.Reader (runReaderT, ReaderT, withReaderT)
 import Control.Monad.Trans.Writer (runWriterT)
 import Data.Either (partitionEithers)
 import Data.Monoid ((<>))
@@ -1032,10 +1033,15 @@ mockMigration mig = do
 -- | MySQL specific 'upsert'. This will prevent multiple queries, when one will
 -- do.
 insertOnDuplicateKeyUpdate
-  :: (PersistEntity record, MonadIO m)
+  :: ( backend ~ PersistEntityBackend record
+     , PersistEntity record
+     , MonadIO m
+     , PersistStore backend
+     , BackendCompatible SqlBackend backend
+     )
   => record
   -> [Update record]
-  -> SqlPersistT m ()
+  -> ReaderT backend m ()
 insertOnDuplicateKeyUpdate record =
   insertManyOnDuplicateKeyUpdate [record] []
 
@@ -1167,20 +1173,26 @@ copyUnlessEq = CopyUnlessEq
 -- > | yes  | wow         |       |          |
 -- > +------+-------------+-------+----------+
 insertManyOnDuplicateKeyUpdate
-  :: ( PersistEntity record
-     , MonadIO m
-     )
-  => [record] -- ^ A list of the records you want to insert, or update
-  -> [SomeField record] -- ^ A list of updates to perform based on the record being inserted.
-  -> [Update record] -- ^ A list of the updates to apply that aren't dependent on the record being inserted.
-  -> SqlPersistT m ()
+    :: forall record backend m.
+    ( backend ~ PersistEntityBackend record
+    , BackendCompatible SqlBackend backend
+    , PersistEntity record
+    , MonadIO m
+    )
+    => [record] -- ^ A list of the records you want to insert, or update
+    -> [SomeField record] -- ^ A list of the fields you want to copy over.
+    -> [Update record] -- ^ A list of the updates to apply that aren't dependent on the record being inserted.
+    -> ReaderT backend m ()
 insertManyOnDuplicateKeyUpdate [] _ _ = return ()
 insertManyOnDuplicateKeyUpdate records fieldValues updates =
-  uncurry rawExecute $ mkBulkInsertQuery records fieldValues updates
-
--- | This creates the query for 'bulkInsertOnDuplicateKeyUpdate'. It will give
--- garbage results if you don't provide a list of either fields to copy or
--- fields to update.
+    withReaderT projectBackend
+    . uncurry rawExecute
+    $ mkBulkInsertQuery records fieldValues updates
+
+-- | This creates the query for 'bulkInsertOnDuplicateKeyUpdate'. If you
+-- provide an empty list of updates to perform, then it will generate
+-- a dummy/no-op update using the first field of the record. This avoids
+-- duplicate key exceptions.
 mkBulkInsertQuery
     :: PersistEntity record
     => [record] -- ^ A list of the records you want to insert, or update

persistent/Database/Persist/Class.hs

@@ -52,6 +52,7 @@ module Database.Persist.Class
     , HasPersistBackend (..)
     , IsPersistBackend ()
     , liftPersist
+    , BackendCompatible (..)
 
     -- * JSON utilities
     , keyValueEntityToJSON, keyValueEntityFromJSON

persistent/Database/Persist/Class/PersistStore.hs

@@ -18,6 +18,7 @@ module Database.Persist.Class.PersistStore
     , insertEntity
     , insertRecord
     , ToBackendKey(..)
+    , BackendCompatible(..)
     ) where
 
 import qualified Data.Text as T
@@ -48,6 +49,14 @@ class (HasPersistBackend backend) => IsPersistBackend backend where
     -- to accidentally run a write query against a read-only database.
     mkPersistBackend :: BaseBackend backend -> backend
 
+-- | This class witnesses that two backend are compatible, and that you can
+-- convert from the @sub@ backend into the @sup@ backend. This is similar
+-- to the 'HasPersistBackend' and 'IsPersistBackend' classes, but where you
+-- don't want to fix the type associated with the 'PersistEntityBackend' of
+-- a record.
+class BackendCompatible sup sub where
+    projectBackend :: sub -> sup
+
 -- | A convenient alias for common type signatures
 type PersistRecordBackend record backend = (PersistEntity record, PersistEntityBackend record ~ BaseBackend backend)
 

persistent/Database/Persist/Sql/Orphan/PersistStore.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -39,6 +40,7 @@ import Web.HttpApiData (ToHttpApiData, FromHttpApiData)
 import Database.Persist.Sql.Class (PersistFieldSql)
 import qualified Data.Aeson as A
 import Control.Exception.Lifted (throwIO)
+import Database.Persist.Class (BackendCompatible(..))
 
 withRawQuery :: MonadIO m
              => Text
@@ -114,6 +116,15 @@ instance PersistCore SqlWriteBackend where
     newtype BackendKey SqlWriteBackend = SqlWriteBackendKey { unSqlWriteBackendKey :: Int64 }
         deriving (Show, Read, Eq, Ord, Num, Integral, PersistField, PersistFieldSql, PathPiece, ToHttpApiData, FromHttpApiData, Real, Enum, Bounded, A.ToJSON, A.FromJSON)
 
+instance BackendCompatible SqlBackend SqlBackend where
+    projectBackend = id
+
+instance BackendCompatible SqlBackend SqlReadBackend where
+    projectBackend = unSqlReadBackend
+
+instance BackendCompatible SqlBackend SqlWriteBackend where
+    projectBackend = unSqlWriteBackend
+
 instance PersistStoreWrite SqlBackend where
     update _ [] = return ()
     update k upds = do