packages feed

persistent 2.10.4 → 2.10.5

raw patch · 5 files changed

+207/−23 lines, 5 files

Files

ChangeLog.md view
@@ -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)
Database/Persist/Sql.hs view
@@ -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
Database/Persist/Sql/Class.hs view
@@ -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
Database/Persist/Sql/Run.hs view
@@ -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)
persistent.cabal view
@@ -1,5 +1,5 @@ name:            persistent-version:         2.10.4+version:         2.10.5 license:         MIT license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>