diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,11 @@ # Changelog for persistent +## 2.10.5 + +* Add the `EntityWithPrefix` type to allow users to specify a custom prefix for raw SQL queries. [#1018](https://github.com/yesodweb/persistent/pull/1018) +* Added Acquire based API to `Database.Persist.Sql` for working with + connections/pools in monads which aren't MonadUnliftIO. [#984](https://github.com/yesodweb/persistent/pull/984) + ## 2.10.4 * Log exceptions when closing a connection fails. See point 1 in [yesod #1635](https://github.com/yesodweb/yesod/issues/1635#issuecomment-547300856). [#978](https://github.com/yesodweb/persistent/pull/978) diff --git a/Database/Persist/Sql.hs b/Database/Persist/Sql.hs --- a/Database/Persist/Sql.hs +++ b/Database/Persist/Sql.hs @@ -30,7 +30,7 @@ import Database.Persist.Sql.Types import Database.Persist.Sql.Types.Internal (IsolationLevel (..)) import Database.Persist.Sql.Class -import Database.Persist.Sql.Run hiding (withResourceTimeout) +import Database.Persist.Sql.Run hiding (withResourceTimeout, rawAcquireSqlConn) import Database.Persist.Sql.Raw import Database.Persist.Sql.Migration import Database.Persist.Sql.Internal diff --git a/Database/Persist/Sql/Class.hs b/Database/Persist/Sql/Class.hs --- a/Database/Persist/Sql/Class.hs +++ b/Database/Persist/Sql/Class.hs @@ -4,11 +4,16 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} + module Database.Persist.Sql.Class ( RawSql (..) , PersistFieldSql (..) + , EntityWithPrefix(..) + , unPrefix ) where +import GHC.TypeLits (Symbol, KnownSymbol, symbolVal) import Data.Bits (bitSizeMaybe) import Data.ByteString (ByteString) import Data.Fixed @@ -17,7 +22,7 @@ import qualified Data.Map as M import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) -import Data.Proxy (Proxy) +import Data.Proxy (Proxy(..)) import qualified Data.Set as S import Data.Text (Text, intercalate, pack) import qualified Data.Text as T @@ -79,6 +84,88 @@ n -> show n ++ " columns for an 'Entity' data type" rawSqlProcessRow row = case splitAt nKeyFields row of (rowKey, rowVal) -> Entity <$> keyFromValues rowKey + <*> fromPersistValues rowVal + where + nKeyFields = length $ entityKeyFields entDef + entDef = entityDef (Nothing :: Maybe record) + +-- | This newtype wrapper is useful when selecting an entity out of the +-- database and you want to provide a prefix to the table being selected. +-- +-- Consider this raw SQL query: +-- +-- > SELECT ?? +-- > FROM my_long_table_name AS mltn +-- > INNER JOIN other_table AS ot +-- > ON mltn.some_col = ot.other_col +-- > WHERE ... +-- +-- We don't want to refer to @my_long_table_name@ every time, so we create +-- an alias. If we want to select it, we have to tell the raw SQL +-- quasi-quoter that we expect the entity to be prefixed with some other +-- name. +-- +-- We can give the above query a type with this, like: +-- +-- @ +-- getStuff :: 'SqlPersistM' ['EntityWithPrefix' \"mltn\" MyLongTableName] +-- getStuff = rawSql queryText [] +-- @ +-- +-- The 'EntityWithPrefix' bit is a boilerplate newtype wrapper, so you can +-- remove it with 'unPrefix', like this: +-- +-- @ +-- getStuff :: 'SqlPersistM' ['Entity' MyLongTableName] +-- getStuff = 'unPrefix' @\"mltn\" '<$>' 'rawSql' queryText [] +-- @ +-- +-- The @ symbol is a "type application" and requires the @TypeApplications@ +-- language extension. +-- +-- @since 2.10.5 +newtype EntityWithPrefix (prefix :: Symbol) record + = EntityWithPrefix { unEntityWithPrefix :: Entity record } + +-- | A helper function to tell GHC what the 'EntityWithPrefix' prefix +-- should be. This allows you to use a type application to specify the +-- prefix, instead of specifying the etype on the result. +-- +-- As an example, here's code that uses this: +-- +-- @ +-- myQuery :: 'SqlPersistM' ['Entity' Person] +-- myQuery = map (unPrefix @\"p\") <$> rawSql query [] +-- where +-- query = "SELECT ?? FROM person AS p" +-- @ +-- +-- @since 2.10.5 +unPrefix :: forall prefix record. EntityWithPrefix prefix record -> Entity record +unPrefix = unEntityWithPrefix + +instance + ( PersistEntity record + , KnownSymbol prefix + , PersistEntityBackend record ~ backend + , IsPersistBackend backend + ) + => RawSql (EntityWithPrefix prefix record) where + rawSqlCols escape _ent = (length sqlFields, [intercalate ", " sqlFields]) + where + sqlFields = map (((name <> ".") <>) . escape) + $ map fieldDB + -- Hacky for a composite key because + -- it selects the same field multiple times + $ entityKeyFields entDef ++ entityFields entDef + name = pack $ symbolVal (Proxy :: Proxy prefix) + entDef = entityDef (Nothing :: Maybe record) + rawSqlColCountReason a = + case fst (rawSqlCols (error "RawSql") a) of + 1 -> "one column for an 'Entity' data type without fields" + n -> show n ++ " columns for an 'Entity' data type" + rawSqlProcessRow row = case splitAt nKeyFields row of + (rowKey, rowVal) -> fmap EntityWithPrefix $ Entity <$> keyFromValues rowKey <*> fromPersistValues rowVal where nKeyFields = length $ entityKeyFields entDef diff --git a/Database/Persist/Sql/Run.hs b/Database/Persist/Sql/Run.hs --- a/Database/Persist/Sql/Run.hs +++ b/Database/Persist/Sql/Run.hs @@ -6,9 +6,13 @@ import Control.Monad.IO.Unlift import qualified UnliftIO.Exception as UE import Control.Monad.Logger.CallStack +import Control.Monad.Reader (MonadReader) +import qualified Control.Monad.Reader as MonadReader import Control.Monad.Trans.Reader hiding (local) import Control.Monad.Trans.Resource +import Data.Acquire (Acquire, ReleaseType(..), mkAcquireType, with) import Data.IORef (readIORef) +import Data.Pool (Pool, LocalPool) import Data.Pool as P import qualified Data.Map as Map import qualified Data.Text as T @@ -19,6 +23,60 @@ import Database.Persist.Sql.Types.Internal (IsolationLevel) import Database.Persist.Sql.Raw +-- | The returned 'Acquire' gets a connection from the pool, but does __NOT__ +-- start a new transaction. Used to implement 'acquireSqlConnFromPool' and +-- 'acquireSqlConnFromPoolWithIsolation', this is useful for performing actions +-- on a connection that cannot be done within a transaction, such as VACUUM in +-- Sqlite. +-- +-- @since 2.10.5 +unsafeAcquireSqlConnFromPool + :: forall backend m + . (MonadReader (Pool backend) m, BackendCompatible SqlBackend backend) + => m (Acquire backend) +unsafeAcquireSqlConnFromPool = do + pool <- MonadReader.ask + + let freeConn :: (backend, LocalPool backend) -> ReleaseType -> IO () + freeConn (res, localPool) relType = case relType of + ReleaseException -> P.destroyResource pool localPool res + _ -> P.putResource localPool res + + return $ fst <$> mkAcquireType (P.takeResource pool) freeConn + + +-- | The returned 'Acquire' gets a connection from the pool, starts a new +-- transaction and gives access to the prepared connection. +-- +-- When the acquired connection is released the transaction is committed and +-- the connection returned to the pool. +-- +-- Upon an exception the transaction is rolled back and the connection +-- destroyed. +-- +-- This is equivalent to 'runSqlPool' but does not incur the 'MonadUnliftIO' +-- constraint, meaning it can be used within, for example, a 'Conduit' +-- pipeline. +-- +-- @since 2.10.5 +acquireSqlConnFromPool + :: (MonadReader (Pool backend) m, BackendCompatible SqlBackend backend) + => m (Acquire backend) +acquireSqlConnFromPool = do + connFromPool <- unsafeAcquireSqlConnFromPool + return $ connFromPool >>= acquireSqlConn + +-- | Like 'acquireSqlConnFromPool', but lets you specify an explicit isolation +-- level. +-- +-- @since 2.10.5 +acquireSqlConnFromPoolWithIsolation + :: (MonadReader (Pool backend) m, BackendCompatible SqlBackend backend) + => IsolationLevel -> m (Acquire backend) +acquireSqlConnFromPoolWithIsolation isolation = do + connFromPool <- unsafeAcquireSqlConnFromPool + return $ connFromPool >>= acquireSqlConnWithIsolation isolation + -- | Get a connection from the pool, run the given action, and then return the -- connection to the pool. -- @@ -28,7 +86,7 @@ runSqlPool :: (MonadUnliftIO m, BackendCompatible SqlBackend backend) => ReaderT backend m a -> Pool backend -> m a -runSqlPool r pconn = withRunInIO $ \run -> withResource pconn $ run . runSqlConn r +runSqlPool r pconn = with (acquireSqlConnFromPool pconn) $ runReaderT r -- | Like 'runSqlPool', but supports specifying an isolation level. -- @@ -36,7 +94,8 @@ runSqlPoolWithIsolation :: (MonadUnliftIO m, BackendCompatible SqlBackend backend) => ReaderT backend m a -> Pool backend -> IsolationLevel -> m a -runSqlPoolWithIsolation r pconn i = withRunInIO $ \run -> withResource pconn $ run . (\conn -> runSqlConnWithIsolation r conn i) +runSqlPoolWithIsolation r pconn i = + with (acquireSqlConnFromPoolWithIsolation i pconn) $ runReaderT r -- | Like 'withResource', but times out the operation if resource -- allocation does not complete within the given timeout period. @@ -60,30 +119,62 @@ return ret {-# INLINABLE withResourceTimeout #-} +rawAcquireSqlConn + :: forall backend m + . (MonadReader backend m, BackendCompatible SqlBackend backend) + => Maybe IsolationLevel -> m (Acquire backend) +rawAcquireSqlConn isolation = do + conn <- MonadReader.ask + let rawConn :: SqlBackend + rawConn = projectBackend conn + + getter :: T.Text -> IO Statement + getter = getStmtConn rawConn + + beginTransaction :: IO backend + beginTransaction = conn <$ connBegin rawConn getter isolation + + finishTransaction :: backend -> ReleaseType -> IO () + finishTransaction _ relType = case relType of + ReleaseException -> connRollback rawConn getter + _ -> connCommit rawConn getter + + return $ mkAcquireType beginTransaction finishTransaction + +-- | Starts a new transaction on the connection. When the acquired connection +-- is released the transaction is committed and the connection returned to the +-- pool. +-- +-- Upon an exception the transaction is rolled back and the connection +-- destroyed. +-- +-- This is equivalent to 'runSqlConn but does not incur the 'MonadUnliftIO' +-- constraint, meaning it can be used within, for example, a 'Conduit' +-- pipeline. +-- +-- @since 2.10.5 +acquireSqlConn + :: (MonadReader backend m, BackendCompatible SqlBackend backend) + => m (Acquire backend) +acquireSqlConn = rawAcquireSqlConn Nothing + +-- | Like 'acquireSqlConn', but lets you specify an explicit isolation level. +-- +-- @since 2.10.5 +acquireSqlConnWithIsolation + :: (MonadReader backend m, BackendCompatible SqlBackend backend) + => IsolationLevel -> m (Acquire backend) +acquireSqlConnWithIsolation = rawAcquireSqlConn . Just + runSqlConn :: (MonadUnliftIO m, BackendCompatible SqlBackend backend) => ReaderT backend m a -> backend -> m a -runSqlConn r conn = withRunInIO $ \runInIO -> mask $ \restore -> do - let conn' = projectBackend conn - getter = getStmtConn conn' - restore $ connBegin conn' getter Nothing - x <- onException - (restore $ runInIO $ runReaderT r conn) - (restore $ connRollback conn' getter) - restore $ connCommit conn' getter - return x +runSqlConn r conn = with (acquireSqlConn conn) $ runReaderT r -- | Like 'runSqlConn', but supports specifying an isolation level. -- -- @since 2.9.0 runSqlConnWithIsolation :: (MonadUnliftIO m, BackendCompatible SqlBackend backend) => ReaderT backend m a -> backend -> IsolationLevel -> m a -runSqlConnWithIsolation r conn isolation = withRunInIO $ \runInIO -> mask $ \restore -> do - let conn' = projectBackend conn - getter = getStmtConn conn' - restore $ connBegin conn' getter $ Just isolation - x <- onException - (restore $ runInIO $ runReaderT r conn) - (restore $ connRollback conn' getter) - restore $ connCommit conn' getter - return x +runSqlConnWithIsolation r conn isolation = + with (acquireSqlConnWithIsolation isolation conn) $ runReaderT r runSqlPersistM :: (BackendCompatible SqlBackend backend) diff --git a/persistent.cabal b/persistent.cabal --- a/persistent.cabal +++ b/persistent.cabal @@ -1,5 +1,5 @@ name: persistent -version: 2.10.4 +version: 2.10.5 license: MIT license-file: LICENSE author: Michael Snoyman