Add QoL API for using BaseBackend/BackendCompatible

persistent/ChangeLog.md

@@ -1,5 +1,10 @@
 # Changelog for persistent
 
+## 2.11.1
+
+* [#1178](https://github.com/yesodweb/persistent/pull/1178)
+  * Added 'withBaseBackend', 'withCompatible' to ease use of base/compatible backend queries in external code.
+
 ## 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/Class.hs

@@ -126,9 +126,11 @@ module Database.Persist.Class
 
     -- * Lifting
     , HasPersistBackend (..)
+    , withBaseBackend
     , IsPersistBackend ()
     , liftPersist
     , BackendCompatible (..)
+    , withCompatibleBackend
 
     -- * JSON utilities
     , keyValueEntityToJSON, keyValueEntityFromJSON

persistent/Database/Persist/Class/PersistStore.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE ExplicitForAll #-}
 module Database.Persist.Class.PersistStore
     ( HasPersistBackend (..)
+    , withBaseBackend
     , IsPersistBackend (..)
     , PersistRecordBackend
     , liftPersist
@@ -17,12 +18,13 @@ module Database.Persist.Class.PersistStore
     , insertRecord
     , ToBackendKey(..)
     , BackendCompatible(..)
+    , withCompatibleBackend
     ) where
 
 import Control.Exception (throwIO)
 import Control.Monad.IO.Class (MonadIO, liftIO)
 import Control.Monad.Reader (MonadReader (ask), runReaderT)
-import Control.Monad.Trans.Reader (ReaderT)
+import Control.Monad.Trans.Reader (ReaderT, withReaderT)
 import qualified Data.Aeson as A
 import Data.Map (Map)
 import qualified Data.Map as Map
@@ -43,6 +45,16 @@ import Database.Persist.Types
 class HasPersistBackend backend where
     type BaseBackend backend
     persistBackend :: backend -> BaseBackend backend
+
+-- | Run a query against a larger backend by plucking out @BaseBackend backend@
+--
+-- This is a helper for reusing existing queries when expanding the backend type.
+--
+-- @since 2.11.1
+withBaseBackend :: (HasPersistBackend backend)
+                => ReaderT (BaseBackend backend) m a -> ReaderT backend m a
+withBaseBackend = withReaderT persistBackend
+
 -- | Class which witnesses that @backend@ is essentially the same as @BaseBackend backend@.
 -- That is, they're isomorphic and @backend@ is just some wrapper over @BaseBackend backend@.
 class (HasPersistBackend backend) => IsPersistBackend backend where
@@ -51,6 +63,10 @@ class (HasPersistBackend backend) => IsPersistBackend backend where
     -- to accidentally run a write query against a read-only database.
     mkPersistBackend :: BaseBackend backend -> backend
 
+-- NB: there is a deliberate *lack* of an equivalent to 'withBaseBackend' for
+-- 'IsPersistentBackend'. We don't want it to be easy for the user to construct
+-- a backend when they're not meant to.
+
 -- | 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
@@ -88,13 +104,23 @@ class (HasPersistBackend backend) => IsPersistBackend backend where
 --
 -- -- after:
 -- asdf' :: 'BackendCompatible' SqlBackend backend => ReaderT backend m ()
--- asdf' = withReaderT 'projectBackend' asdf
+-- asdf' = 'withCompatibleBackend' asdf
 -- @
 --
 -- @since 2.7.1
 class BackendCompatible sup sub where
     projectBackend :: sub -> sup
 
+-- | Run a query against a compatible backend, by projecting the backend
+--
+-- This is a helper for using queries which run against a specific backend type
+-- that your backend is compatible with.
+--
+-- @since 2.11.1
+withCompatibleBackend :: (BackendCompatible sup sub)
+                      => ReaderT sup m a -> ReaderT sub m a
+withCompatibleBackend = withReaderT projectBackend
+
 -- | A convenient alias for common type signatures
 type PersistRecordBackend record backend = (PersistEntity record, PersistEntityBackend record ~ BaseBackend backend)
 

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

@@ -11,7 +11,7 @@ module Database.Persist.Sql.Orphan.PersistQuery
 
 import Control.Exception (throwIO)
 import Control.Monad.IO.Class
-import Control.Monad.Trans.Reader (ReaderT, ask, withReaderT)
+import Control.Monad.Trans.Reader (ReaderT, ask)
 import Data.ByteString.Char8 (readInteger)
 import Data.Conduit
 import qualified Data.Conduit.List as CL
@@ -151,15 +151,15 @@ instance PersistQueryRead SqlBackend where
                 Right k -> return k
                 Left err -> error $ "selectKeysImpl: keyFromValues failed" <> show err
 instance PersistQueryRead SqlReadBackend where
-    count filts = withReaderT persistBackend $ count filts
-    exists filts = withReaderT persistBackend $ exists filts
-    selectSourceRes filts opts = withReaderT persistBackend $ selectSourceRes filts opts
-    selectKeysRes filts opts = withReaderT persistBackend $ selectKeysRes filts opts
+    count filts = withBaseBackend $ count filts
+    exists filts = withBaseBackend $ exists filts
+    selectSourceRes filts opts = withBaseBackend $ selectSourceRes filts opts
+    selectKeysRes filts opts = withBaseBackend $ selectKeysRes filts opts
 instance PersistQueryRead SqlWriteBackend where
-    count filts = withReaderT persistBackend $ count filts
-    exists filts = withReaderT persistBackend $ exists filts
-    selectSourceRes filts opts = withReaderT persistBackend $ selectSourceRes filts opts
-    selectKeysRes filts opts = withReaderT persistBackend $ selectKeysRes filts opts
+    count filts = withBaseBackend $ count filts
+    exists filts = withBaseBackend $ exists filts
+    selectSourceRes filts opts = withBaseBackend $ selectSourceRes filts opts
+    selectKeysRes filts opts = withBaseBackend $ selectKeysRes filts opts
 
 instance PersistQueryWrite SqlBackend where
     deleteWhere filts = do
@@ -169,16 +169,16 @@ instance PersistQueryWrite SqlBackend where
         _ <- updateWhereCount filts upds
         return ()
 instance PersistQueryWrite SqlWriteBackend where
-    deleteWhere filts = withReaderT persistBackend $ deleteWhere filts
-    updateWhere filts upds = withReaderT persistBackend $ updateWhere filts upds
+    deleteWhere filts = withBaseBackend $ deleteWhere filts
+    updateWhere filts upds = withBaseBackend $ updateWhere filts upds
 
 -- | Same as 'deleteWhere', but returns the number of rows affected.
 --
 -- @since 1.1.5
 deleteWhereCount :: (PersistEntity val, MonadIO m, PersistEntityBackend val ~ SqlBackend, BackendCompatible SqlBackend backend)
                  => [Filter val]
                  -> ReaderT backend m Int64
-deleteWhereCount filts = withReaderT projectBackend $ do
+deleteWhereCount filts = withCompatibleBackend $ do
     conn <- ask
     let t = entityDef $ dummyFromFilts filts
     let wher = if null filts
@@ -199,7 +199,7 @@ updateWhereCount :: (PersistEntity val, MonadIO m, SqlBackend ~ PersistEntityBac
                  -> [Update val]
                  -> ReaderT backend m Int64
 updateWhereCount _ [] = return 0
-updateWhereCount filts upds = withReaderT projectBackend $ do
+updateWhereCount filts upds = withCompatibleBackend $ do
     conn <- ask
     let wher = if null filts
                 then ""

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

@@ -83,7 +83,7 @@ getTableName :: forall record m backend.
              , BackendCompatible SqlBackend backend
              , Monad m
              ) => record -> ReaderT backend m Text
-getTableName rec = withReaderT projectBackend $ do
+getTableName rec = withCompatibleBackend $ do
     conn <- ask
     return $ connEscapeName conn $ tableDBName rec
 
@@ -103,7 +103,7 @@ getFieldName :: forall record typ m backend.
              , Monad m
              )
              => EntityField record typ -> ReaderT backend m Text
-getFieldName rec = withReaderT projectBackend $ do
+getFieldName rec = withCompatibleBackend $ do
     conn <- ask
     return $ connEscapeName conn $ fieldDBName rec
 
@@ -301,16 +301,16 @@ instance PersistStoreWrite SqlBackend where
             , wher conn
             ]
 instance PersistStoreWrite SqlWriteBackend where
-    insert v = withReaderT persistBackend $ insert v
-    insertMany vs = withReaderT persistBackend $ insertMany vs
-    insertMany_ vs = withReaderT persistBackend $ insertMany_ vs
-    insertEntityMany vs = withReaderT persistBackend $ insertEntityMany vs
-    insertKey k v = withReaderT persistBackend $ insertKey k v
-    repsert k v = withReaderT persistBackend $ repsert k v
-    replace k v = withReaderT persistBackend $ replace k v
-    delete k = withReaderT persistBackend $ delete k
-    update k upds = withReaderT persistBackend $ update k upds
-    repsertMany krs = withReaderT persistBackend $ repsertMany krs
+    insert v = withBaseBackend $ insert v
+    insertMany vs = withBaseBackend $ insertMany vs
+    insertMany_ vs = withBaseBackend $ insertMany_ vs
+    insertEntityMany vs = withBaseBackend $ insertEntityMany vs
+    insertKey k v = withBaseBackend $ insertKey k v
+    repsert k v = withBaseBackend $ repsert k v
+    replace k v = withBaseBackend $ replace k v
+    delete k = withBaseBackend $ delete k
+    update k upds = withBaseBackend $ update k upds
+    repsertMany krs = withBaseBackend $ repsertMany krs
 
 instance PersistStoreRead SqlBackend where
     get k = do
@@ -341,11 +341,11 @@ instance PersistStoreRead SqlBackend where
             return $ Map.fromList $ fmap (\e -> (entityKey e, entityVal e)) es
 
 instance PersistStoreRead SqlReadBackend where
-    get k = withReaderT persistBackend $ get k
-    getMany ks = withReaderT persistBackend $ getMany ks
+    get k = withBaseBackend $ get k
+    getMany ks = withBaseBackend $ getMany ks
 instance PersistStoreRead SqlWriteBackend where
-    get k = withReaderT persistBackend $ get k
-    getMany ks = withReaderT persistBackend $ getMany ks
+    get k = withBaseBackend $ get k
+    getMany ks = withBaseBackend $ getMany ks
 
 dummyFromKey :: Key record -> Maybe record
 dummyFromKey = Just . recordTypeFromKey

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

@@ -6,7 +6,7 @@ module Database.Persist.Sql.Orphan.PersistUnique
 
 import Control.Exception (throwIO)
 import Control.Monad.IO.Class (liftIO)
-import Control.Monad.Trans.Reader (ask, withReaderT)
+import Control.Monad.Trans.Reader (ask)
 import qualified Data.Conduit.List as CL
 import Data.Function (on)
 import Data.List (nubBy)
@@ -79,9 +79,9 @@ instance PersistUniqueWrite SqlBackend where
                 Nothing -> defaultPutMany rs
 
 instance PersistUniqueWrite SqlWriteBackend where
-    deleteBy uniq = withReaderT persistBackend $ deleteBy uniq
-    upsert rs us = withReaderT persistBackend $ upsert rs us
-    putMany rs = withReaderT persistBackend $ putMany rs
+    deleteBy uniq = withBaseBackend $ deleteBy uniq
+    upsert rs us = withBaseBackend $ upsert rs us
+    putMany rs = withBaseBackend $ putMany rs
 
 instance PersistUniqueRead SqlBackend where
     getBy uniq = do
@@ -113,10 +113,10 @@ instance PersistUniqueRead SqlBackend where
         toFieldNames' = map snd . persistUniqueToFieldNames
 
 instance PersistUniqueRead SqlReadBackend where
-    getBy uniq = withReaderT persistBackend $ getBy uniq
+    getBy uniq = withBaseBackend $ getBy uniq
 
 instance PersistUniqueRead SqlWriteBackend where
-    getBy uniq = withReaderT persistBackend $ getBy uniq
+    getBy uniq = withBaseBackend $ getBy uniq
 
 dummyFromUnique :: Unique v -> Maybe v
 dummyFromUnique _ = Nothing