Add Acquire based interfaces for connections.

persistent/ChangeLog.md

@@ -1,5 +1,10 @@
 # Changelog for persistent
 
+## 2.10.5
+
+* 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)

persistent/Database/Persist/Sql.hs

@@ -30,7 +30,7 @@ import Database.Persist
 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

persistent/Database/Persist/Sql/Run.hs

@@ -6,9 +6,13 @@ import Control.Monad (liftM)
 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
 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,15 +86,16 @@ import Database.Persist.Sql.Raw
 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.
 --
 -- @since 2.9.0
 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 @@ withResourceTimeout ms pool act = withRunInIO $ \runInIO -> mask $ \restore -> d
             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/persistent.cabal

@@ -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>