From 9d07728007227ac5f294f7f3ccbd429c1539421a Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Tue, 16 Mar 2021 10:38:15 -0600
Subject: [PATCH 01/13] testing it out

---
 persistent-postgresql/exe/Main.hs             | 96 +++++++++++++++++++
 .../persistent-postgresql.cabal               | 19 ++++
 persistent/Database/Persist/Sql/Run.hs        | 31 +++---
 stack.yaml                                    |  4 +
 test.hs                                       | 57 +++++++++++
 5 files changed, 196 insertions(+), 11 deletions(-)
 create mode 100644 persistent-postgresql/exe/Main.hs
 create mode 100644 test.hs

diff --git a/persistent-postgresql/exe/Main.hs b/persistent-postgresql/exe/Main.hs
new file mode 100644
index 000000000..da64ebd27
--- /dev/null
+++ b/persistent-postgresql/exe/Main.hs
@@ -0,0 +1,96 @@
+{-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, GeneralizedNewtypeDeriving, DerivingStrategies #-}
+{-# LANGUAGE OverloadedStrings, QuantifiedConstraints #-}
+{-# LANGUAGE TypeApplications #-}
+{-# language OverloadedStrings #-}
+module Main where
+
+import Prelude hiding (show)
+import qualified Prelude
+
+import qualified Data.Text as Text
+import  Control.Monad.IO.Class
+import  qualified Control.Monad as Monad
+import qualified UnliftIO.Concurrent as Concurrent
+import qualified UnliftIO.Exception as Exception
+import qualified Database.Persist as Persist
+import qualified Database.Persist.Sql as Persist
+import qualified Database.Persist.Postgresql as Persist
+import qualified Control.Monad.Logger as Logger
+import Control.Monad.Logger
+import qualified Data.ByteString as BS
+import qualified Data.Pool as Pool
+import Data.Time
+import UnliftIO
+import Data.Coerce
+import Control.Monad.Trans.Reader
+import Control.Monad.Trans
+
+newtype LogPrefixT m a = LogPrefixT { runLogPrefixT :: ReaderT LogStr m a }
+    deriving newtype
+        (Functor, Applicative, Monad, MonadIO, MonadTrans)
+
+instance MonadLogger m => MonadLogger (LogPrefixT m) where
+    monadLoggerLog loc src lvl msg = LogPrefixT $ ReaderT $ \prefix ->
+        monadLoggerLog loc src lvl (toLogStr prefix <> toLogStr msg)
+
+deriving newtype instance (forall a b. Coercible a b => Coercible (m a) (m b), MonadUnliftIO m) => MonadUnliftIO (LogPrefixT m)
+
+prefixLogs :: Text.Text -> LogPrefixT m a -> m a
+prefixLogs prefix =
+    flip runReaderT (toLogStr $! mconcat ["[", prefix, "] "]) . runLogPrefixT
+
+infixr 5 `prefixLogs`
+show :: Show a => a -> Text.Text
+show = Text.pack . Prelude.show
+
+main :: IO ()
+main = runStdoutLoggingT $ prefixLogs "main thread" $ do
+
+  -- I started a postgres server with:
+  -- docker run --rm --name some-postgres -p 5432:5432 -e POSTGRES_PASSWORD=secret postgres
+  pool <- Logger.runNoLoggingT $ Persist.createPostgresqlPool "postgresql://postgres:secret@localhost:5433/postgres" 1
+
+  logInfoN "creating table..."
+  Monad.void $ liftIO $ createTableFoo pool
+
+  liftIO getCurrentTime >>= \now ->
+    simulateFailedLongRunningPostgresCall pool
+
+  logInfoN "destroying resources"
+  liftIO $ Pool.destroyAllResources pool
+
+  logInfoN "pg_sleep"
+  result :: Either Exception.SomeException [Persist.Single (Maybe String)] <-
+    Exception.try . (liftIO . (flip Persist.runSqlPersistMPool) pool) $ do
+        Persist.rawSql @(Persist.Single (Maybe String)) "select pg_sleep(2)" []
+
+  -- when we try the above we get back:
+  -- 'result: Left libpq: failed (another command is already in progress'
+  -- this is because the connection went back into the pool before it was ready
+  -- or perhaps it should have been destroyed and a new connection created and put into the pool?
+  logInfoN $ "result: " <> show result
+
+createTableFoo :: Pool.Pool Persist.SqlBackend -> IO ()
+createTableFoo pool = (flip Persist.runSqlPersistMPool) pool $ do
+  Persist.rawExecute "CREATE table if not exists foo(id int);" []
+
+simulateFailedLongRunningPostgresCall
+    :: (MonadLogger m, MonadUnliftIO m, forall a b. Coercible a b => Coercible (m a) (m b)) => Pool.Pool Persist.SqlBackend -> m ()
+simulateFailedLongRunningPostgresCall pool = do
+  threadId <- Concurrent.forkIO
+    $ (do
+        me <- Concurrent.myThreadId
+        prefixLogs (show me) $ do
+            let numThings :: Int = 100000000
+            logInfoN $ "start inserting " <> show numThings <> " things"
+
+            (`Persist.runSqlPool` pool) $ do
+                logInfoN "inside of thing"
+                Monad.forM_ [1 .. numThings] $ \i -> do
+                    Monad.when (i `mod` 1000 == 0) $
+                        logInfoN $ "Thing #: " <> show i
+                    Persist.rawExecute "insert into foo values(1);" []
+      )
+  Concurrent.threadDelay 1000000
+  Monad.void $ Concurrent.killThread threadId
+  logInfoN "killed thread"
diff --git a/persistent-postgresql/persistent-postgresql.cabal b/persistent-postgresql/persistent-postgresql.cabal
index 9a9ec1556..eaa8f6789 100644
--- a/persistent-postgresql/persistent-postgresql.cabal
+++ b/persistent-postgresql/persistent-postgresql.cabal
@@ -80,3 +80,22 @@ test-suite test
                    , unordered-containers
                    , vector
     default-language: Haskell2010
+
+executable conn-kill
+    main-is: Main.hs
+    hs-source-dirs: exe
+    ghc-options:
+    build-depends:
+        base
+      , persistent-postgresql
+      , monad-logger
+      , monad-logger-prefix
+      , text
+      , unliftio
+      , time
+      , transformers
+      , persistent
+      , bytestring
+      , resource-pool
+      , mtl
+
diff --git a/persistent/Database/Persist/Sql/Run.hs b/persistent/Database/Persist/Sql/Run.hs
index 84b12fab1..70ff67d1d 100644
--- a/persistent/Database/Persist/Sql/Run.hs
+++ b/persistent/Database/Persist/Sql/Run.hs
@@ -1,7 +1,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 module Database.Persist.Sql.Run where
 
-import Control.Exception (bracket, mask, onException)
+import Control.Exception (bracket, mask, onException, catch)
 import Control.Monad (liftM)
 import Control.Monad.IO.Unlift
 import qualified UnliftIO.Exception as UE
@@ -129,7 +129,10 @@ rawAcquireSqlConn isolation = do
 
         finishTransaction :: backend -> ReleaseType -> IO ()
         finishTransaction _ relType = case relType of
-            ReleaseException -> connRollback rawConn getter
+            ReleaseExceptionWith e -> do
+                putStrLn $ "got a release exception: " <> show e
+                connRollback rawConn getter
+                putStrLn "rolled back transaction"
             _ -> connCommit rawConn getter
 
     return $ mkAcquireType beginTransaction finishTransaction
@@ -202,7 +205,7 @@ withSqlPoolWithConfig
     -> ConnectionPoolConfig
     -> (Pool backend -> m a)
     -> m a
-withSqlPoolWithConfig mkConn poolConfig f = withUnliftIO $ \u -> bracket
+withSqlPoolWithConfig mkConn poolConfig f = withUnliftIO $ \u -> UE.bracket
     (unliftIO u $ createSqlPoolWithConfig mkConn poolConfig)
     destroyAllResources
     (unliftIO u . f)
@@ -227,12 +230,15 @@ createSqlPoolWithConfig mkConn config = do
     -- Resource pool will swallow any exceptions from close. We want to log
     -- them instead.
     let loggedClose :: backend -> IO ()
-        loggedClose backend = close' backend `UE.catchAny` \e -> runLoggingT
-          (logError $ T.pack $ "Error closing database connection in pool: " ++ show e)
-          logFunc
-    liftIO $ createPool 
-        (mkConn logFunc) 
-        loggedClose 
+        loggedClose backend = close' backend `catch` \e -> do
+            runLoggingT
+              (logError $ T.pack $ "Error closing database connection in pool: " ++ show e)
+              logFunc
+            putStrLn "exception caught boss"
+            UE.throwIO (e :: UE.SomeException)
+    liftIO $ createPool
+        (putStrLn "creating conn" >> mkConn logFunc)
+        loggedClose
         (connectionPoolConfigStripes config)
         (connectionPoolConfigIdleTimeout config)
         (connectionPoolConfigSize config)
@@ -294,12 +300,15 @@ withSqlConn
     => (LogFunc -> IO backend) -> (backend -> m a) -> m a
 withSqlConn open f = do
     logFunc <- askLoggerIO
-    withRunInIO $ \run -> bracket
+    withRunInIO $ \run -> UE.bracket
       (open logFunc)
       close'
       (run . f)
 
 close' :: (BackendCompatible SqlBackend backend) => backend -> IO ()
-close' conn = do
+close' conn = UE.uninterruptibleMask_ $ do
+    putStrLn "close' called"
     readIORef (connStmtMap $ projectBackend conn) >>= mapM_ stmtFinalize . Map.elems
+    putStrLn "statements finalized boss"
     connClose $ projectBackend conn
+    putStrLn "connection closed, boss"
diff --git a/stack.yaml b/stack.yaml
index b72c3ff2a..10ca13bc5 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -12,3 +12,7 @@ packages:
 
 extra-deps:
   - resourcet-pool-0.1.0.0
+  - git: https://github.com/parsonsmatt/conduit
+    commit: eb66c6e9d9d92c460b2db151b0c4dff1f3ba2812
+    subdirs:
+    - resourcet
diff --git a/test.hs b/test.hs
new file mode 100644
index 000000000..239dab6d6
--- /dev/null
+++ b/test.hs
@@ -0,0 +1,57 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Main where
+
+import  qualified Control.Monad as Monad
+import qualified Control.Concurrent as Concurrent
+import qualified Control.Exception as Exception
+import qualified Database.Persist as Persist
+import qualified Database.Persist.Sql as Persist
+import qualified Database.Persist.Postgresql as Persist
+import qualified Control.Monad.Logger as Logger
+import qualified Data.ByteString as BS
+import qualified Data.Pool as Pool
+import Data.Time
+
+main :: IO ()
+main = do
+
+  -- I started a postgres server with:
+  -- docker run --rm --name some-postgres -p 5432:5432 -e POSTGRES_PASSWORD=secret postgres
+  pool <- Logger.runNoLoggingT $ Persist.createPostgresqlPool "postgresql://postgres:secret@localhost:5433/postgres" 1
+
+  Monad.void $ createTableFoo pool
+
+  getCurrentTime >>= \now ->
+    simulateFailedLongRunningPostgresCall pool
+
+  Pool.destroyAllResources pool
+
+  result :: Either Exception.SomeException [Persist.Single String] <-
+    Exception.try . ((flip Persist.runSqlPersistMPool) pool) $ do
+        Persist.rawSql @(Persist.Single String) "select pg_sleep(5)" []
+
+  -- when we try the above we get back:
+  -- 'result: Left libpq: failed (another command is already in progress'
+  -- this is because the connection went back into the pool before it was ready
+  -- or perhaps it should have been destroyed and a new connection created and put into the pool?
+  putStrLn $ "result: " <> show result
+
+createTableFoo :: Pool.Pool Persist.SqlBackend -> IO ()
+createTableFoo pool = (flip Persist.runSqlPersistMPool) pool $ do
+  Persist.rawExecute "CREATE table if not exists foo(id int);" []
+
+simulateFailedLongRunningPostgresCall :: Pool.Pool Persist.SqlBackend -> IO ()
+simulateFailedLongRunningPostgresCall pool = do
+  threadId <- Concurrent.forkIO
+    $ (do
+        let numThings :: Int = 100000000
+        putStrLn $ "start inserting " <> show numThings <> " things"
+        Monad.forM_ [1 .. numThings] $ \_ -> do
+          (flip Persist.runSqlPersistMPool) pool $
+            Persist.rawExecute "insert into foo values(1);" []
+      )
+  Concurrent.threadDelay 5000000
+  Monad.void $ Concurrent.killThread threadId
+  putStrLn "killed thread"

From e03e81693d555f3606c0f73ed61d2f87f087ccee Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Tue, 16 Mar 2021 10:56:38 -0600
Subject: [PATCH 02/13] remove destroy resources

---
 persistent-postgresql/exe/Main.hs                 | 4 ++--
 persistent-postgresql/persistent-postgresql.cabal | 2 +-
 persistent/Database/Persist/Sql/Run.hs            | 4 ++--
 3 files changed, 5 insertions(+), 5 deletions(-)

diff --git a/persistent-postgresql/exe/Main.hs b/persistent-postgresql/exe/Main.hs
index da64ebd27..31cc20bf1 100644
--- a/persistent-postgresql/exe/Main.hs
+++ b/persistent-postgresql/exe/Main.hs
@@ -56,8 +56,8 @@ main = runStdoutLoggingT $ prefixLogs "main thread" $ do
   liftIO getCurrentTime >>= \now ->
     simulateFailedLongRunningPostgresCall pool
 
-  logInfoN "destroying resources"
-  liftIO $ Pool.destroyAllResources pool
+  -- logInfoN "destroying resources"
+  -- liftIO $ Pool.destroyAllResources pool
 
   logInfoN "pg_sleep"
   result :: Either Exception.SomeException [Persist.Single (Maybe String)] <-
diff --git a/persistent-postgresql/persistent-postgresql.cabal b/persistent-postgresql/persistent-postgresql.cabal
index eaa8f6789..467c42ddc 100644
--- a/persistent-postgresql/persistent-postgresql.cabal
+++ b/persistent-postgresql/persistent-postgresql.cabal
@@ -84,7 +84,7 @@ test-suite test
 executable conn-kill
     main-is: Main.hs
     hs-source-dirs: exe
-    ghc-options:
+    ghc-options: -threaded
     build-depends:
         base
       , persistent-postgresql
diff --git a/persistent/Database/Persist/Sql/Run.hs b/persistent/Database/Persist/Sql/Run.hs
index 70ff67d1d..c45c46d13 100644
--- a/persistent/Database/Persist/Sql/Run.hs
+++ b/persistent/Database/Persist/Sql/Run.hs
@@ -188,7 +188,7 @@ liftSqlPersistMPool
 liftSqlPersistMPool x pool = liftIO (runSqlPersistMPool x pool)
 
 withSqlPool
-    :: forall backend m a. (MonadLoggerIO m, MonadUnliftIO m, BackendCompatible SqlBackend backend)
+    :: forall backend m a. (MonadLogger m, MonadLoggerIO m, MonadUnliftIO m, BackendCompatible SqlBackend backend)
     => (LogFunc -> IO backend) -- ^ create a new connection
     -> Int -- ^ connection count
     -> (Pool backend -> m a)
@@ -306,7 +306,7 @@ withSqlConn open f = do
       (run . f)
 
 close' :: (BackendCompatible SqlBackend backend) => backend -> IO ()
-close' conn = UE.uninterruptibleMask_ $ do
+close' conn = do
     putStrLn "close' called"
     readIORef (connStmtMap $ projectBackend conn) >>= mapM_ stmtFinalize . Map.elems
     putStrLn "statements finalized boss"

From 7d67dac1aaae8587bb58188abab9f0f83ff3ec06 Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Tue, 16 Mar 2021 12:39:08 -0600
Subject: [PATCH 03/13] add transactions

---
 persistent-postgresql/exe/Main.hs      |  2 +-
 persistent/Database/Persist/Sql/Run.hs | 55 +++++++++++++++++++++-----
 2 files changed, 47 insertions(+), 10 deletions(-)

diff --git a/persistent-postgresql/exe/Main.hs b/persistent-postgresql/exe/Main.hs
index 31cc20bf1..fdb0b08f3 100644
--- a/persistent-postgresql/exe/Main.hs
+++ b/persistent-postgresql/exe/Main.hs
@@ -44,7 +44,7 @@ show :: Show a => a -> Text.Text
 show = Text.pack . Prelude.show
 
 main :: IO ()
-main = runStdoutLoggingT $ prefixLogs "main thread" $ do
+main = runStdoutLoggingT $ Concurrent.myThreadId >>= \tid -> prefixLogs (show tid) $ do
 
   -- I started a postgres server with:
   -- docker run --rm --name some-postgres -p 5432:5432 -e POSTGRES_PASSWORD=secret postgres
diff --git a/persistent/Database/Persist/Sql/Run.hs b/persistent/Database/Persist/Sql/Run.hs
index c45c46d13..7a75e39a9 100644
--- a/persistent/Database/Persist/Sql/Run.hs
+++ b/persistent/Database/Persist/Sql/Run.hs
@@ -14,7 +14,7 @@ import Data.Acquire (Acquire, ReleaseType(..), mkAcquireType, with)
 import Data.IORef (readIORef)
 import Data.Pool (Pool, LocalPool)
 import Data.Pool as P
-import Data.Pool.Acquire (poolToAcquire)
+-- import Data.Pool.Acquire (poolToAcquire)
 import qualified Data.Map as Map
 import qualified Data.Text as T
 import System.Timeout (timeout)
@@ -24,6 +24,32 @@ import Database.Persist.Sql.Types
 import Database.Persist.Sql.Types.Internal (IsolationLevel)
 import Database.Persist.Sql.Raw
 
+import Control.Concurrent
+
+putStrLnWithThread :: String -> IO ()
+putStrLnWithThread msg = do
+    me <- myThreadId
+    putStrLn $ "[" ++ show me ++ "] " ++ msg
+
+-- | Convert a 'Pool' into an 'Acquire'.
+poolToAcquire :: Pool a -> Acquire a
+poolToAcquire pool = fst <$> mkAcquireType getResource freeResource
+  where
+    getResource = do
+        putStrLnWithThread "Taking resource from Acquire"
+        takeResource pool
+    freeResource (resource, localPool) x = do
+        putStrLnWithThread $ "in free resource, reason: " <> show x
+        case x of
+            ReleaseException -> do
+                putStrLnWithThread "in freeResource: destroying resource"
+                destroyResource pool localPool resource
+                putStrLnWithThread "boom destroyed"
+            _ -> do
+                putStrLnWithThread "putresource"
+                putResource localPool resource
+                putStrLnWithThread "putresource complete"
+
 -- | 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
@@ -79,7 +105,18 @@ acquireSqlConnFromPoolWithIsolation isolation = do
 runSqlPool
     :: forall backend m a. (MonadUnliftIO m, BackendCompatible SqlBackend backend)
     => ReaderT backend m a -> Pool backend -> m a
-runSqlPool r pconn = with (acquireSqlConnFromPool pconn) $ runReaderT r
+runSqlPool r pconn = do
+    -- with (acquireSqlConnFromPool pconn) $ runReaderT r
+    withRunInIO $ \runInIO ->
+        withResource pconn $ \conn -> do
+            let sqlBackend = projectBackend conn
+            let getter = getStmtConn sqlBackend
+            connBegin sqlBackend getter Nothing
+            a <- runInIO (runReaderT r conn)
+                `UE.onException` connRollback sqlBackend getter
+            connCommit sqlBackend getter
+            pure a
+
 
 -- | Like 'runSqlPool', but supports specifying an isolation level.
 --
@@ -130,9 +167,9 @@ rawAcquireSqlConn isolation = do
         finishTransaction :: backend -> ReleaseType -> IO ()
         finishTransaction _ relType = case relType of
             ReleaseExceptionWith e -> do
-                putStrLn $ "got a release exception: " <> show e
+                putStrLnWithThread $ "got a release exception: " <> show e
                 connRollback rawConn getter
-                putStrLn "rolled back transaction"
+                putStrLnWithThread "rolled back transaction"
             _ -> connCommit rawConn getter
 
     return $ mkAcquireType beginTransaction finishTransaction
@@ -234,10 +271,10 @@ createSqlPoolWithConfig mkConn config = do
             runLoggingT
               (logError $ T.pack $ "Error closing database connection in pool: " ++ show e)
               logFunc
-            putStrLn "exception caught boss"
+            putStrLnWithThread "exception caught boss"
             UE.throwIO (e :: UE.SomeException)
     liftIO $ createPool
-        (putStrLn "creating conn" >> mkConn logFunc)
+        (putStrLnWithThread "creating conn" >> mkConn logFunc)
         loggedClose
         (connectionPoolConfigStripes config)
         (connectionPoolConfigIdleTimeout config)
@@ -307,8 +344,8 @@ withSqlConn open f = do
 
 close' :: (BackendCompatible SqlBackend backend) => backend -> IO ()
 close' conn = do
-    putStrLn "close' called"
+    putStrLnWithThread "close' called"
     readIORef (connStmtMap $ projectBackend conn) >>= mapM_ stmtFinalize . Map.elems
-    putStrLn "statements finalized boss"
+    putStrLnWithThread "statements finalized boss"
     connClose $ projectBackend conn
-    putStrLn "connection closed, boss"
+    putStrLnWithThread "connection closed, boss"

From 4ab072c040de839ff7e6185f2a2f64651ecc2900 Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Tue, 16 Mar 2021 16:12:46 -0600
Subject: [PATCH 04/13] remove stuff

---
 .../{exe => conn-killed}/Main.hs              |  2 ++
 .../persistent-postgresql.cabal               | 19 -------------------
 persistent/Database/Persist/Sql/Run.hs        | 11 +++++++++--
 3 files changed, 11 insertions(+), 21 deletions(-)
 rename persistent-postgresql/{exe => conn-killed}/Main.hs (98%)

diff --git a/persistent-postgresql/exe/Main.hs b/persistent-postgresql/conn-killed/Main.hs
similarity index 98%
rename from persistent-postgresql/exe/Main.hs
rename to persistent-postgresql/conn-killed/Main.hs
index fdb0b08f3..6a259118c 100644
--- a/persistent-postgresql/exe/Main.hs
+++ b/persistent-postgresql/conn-killed/Main.hs
@@ -2,6 +2,8 @@
 {-# LANGUAGE OverloadedStrings, QuantifiedConstraints #-}
 {-# LANGUAGE TypeApplications #-}
 {-# language OverloadedStrings #-}
+
+-- | This executable is a test of the issue raised in #1199.
 module Main where
 
 import Prelude hiding (show)
diff --git a/persistent-postgresql/persistent-postgresql.cabal b/persistent-postgresql/persistent-postgresql.cabal
index 467c42ddc..9a9ec1556 100644
--- a/persistent-postgresql/persistent-postgresql.cabal
+++ b/persistent-postgresql/persistent-postgresql.cabal
@@ -80,22 +80,3 @@ test-suite test
                    , unordered-containers
                    , vector
     default-language: Haskell2010
-
-executable conn-kill
-    main-is: Main.hs
-    hs-source-dirs: exe
-    ghc-options: -threaded
-    build-depends:
-        base
-      , persistent-postgresql
-      , monad-logger
-      , monad-logger-prefix
-      , text
-      , unliftio
-      , time
-      , transformers
-      , persistent
-      , bytestring
-      , resource-pool
-      , mtl
-
diff --git a/persistent/Database/Persist/Sql/Run.hs b/persistent/Database/Persist/Sql/Run.hs
index 7a75e39a9..bbf7435da 100644
--- a/persistent/Database/Persist/Sql/Run.hs
+++ b/persistent/Database/Persist/Sql/Run.hs
@@ -117,7 +117,6 @@ runSqlPool r pconn = do
             connCommit sqlBackend getter
             pure a
 
-
 -- | Like 'runSqlPool', but supports specifying an isolation level.
 --
 -- @since 2.9.0
@@ -125,7 +124,15 @@ runSqlPoolWithIsolation
     :: forall backend m a. (MonadUnliftIO m, BackendCompatible SqlBackend backend)
     => ReaderT backend m a -> Pool backend -> IsolationLevel -> m a
 runSqlPoolWithIsolation r pconn i =
-    with (acquireSqlConnFromPoolWithIsolation i pconn) $ runReaderT r
+    withRunInIO $ \runInIO ->
+        withResource pconn $ \conn -> do
+            let sqlBackend = projectBackend conn
+            let getter = getStmtConn sqlBackend
+            connBegin sqlBackend getter (Just i)
+            a <- runInIO (runReaderT r conn)
+                `UE.onException` connRollback sqlBackend getter
+            connCommit sqlBackend getter
+            pure a
 
 -- | Like 'withResource', but times out the operation if resource
 -- allocation does not complete within the given timeout period.

From 15f4acc7cd48e49fb65e0acdd6e4459565b64509 Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Tue, 16 Mar 2021 16:20:00 -0600
Subject: [PATCH 05/13] trim the fat

---
 persistent/Database/Persist/Sql.hs     |   2 +-
 persistent/Database/Persist/Sql/Run.hs | 112 +------------------------
 persistent/persistent.cabal            |   1 -
 stack.yaml                             |   7 --
 4 files changed, 5 insertions(+), 117 deletions(-)

diff --git a/persistent/Database/Persist/Sql.hs b/persistent/Database/Persist/Sql.hs
index d25fd851e..50070938b 100644
--- a/persistent/Database/Persist/Sql.hs
+++ b/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, rawAcquireSqlConn)
+import Database.Persist.Sql.Run hiding (rawAcquireSqlConn)
 import Database.Persist.Sql.Raw
 import Database.Persist.Sql.Migration
 import Database.Persist.Sql.Internal
diff --git a/persistent/Database/Persist/Sql/Run.hs b/persistent/Database/Persist/Sql/Run.hs
index bbf7435da..7701ba2e2 100644
--- a/persistent/Database/Persist/Sql/Run.hs
+++ b/persistent/Database/Persist/Sql/Run.hs
@@ -1,8 +1,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 module Database.Persist.Sql.Run where
 
-import Control.Exception (bracket, mask, onException, catch)
-import Control.Monad (liftM)
+import Control.Exception (catch)
 import Control.Monad.IO.Unlift
 import qualified UnliftIO.Exception as UE
 import Control.Monad.Logger.CallStack
@@ -12,90 +11,16 @@ 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 (Pool)
 import Data.Pool as P
--- import Data.Pool.Acquire (poolToAcquire)
 import qualified Data.Map as Map
 import qualified Data.Text as T
-import System.Timeout (timeout)
 
 import Database.Persist.Class.PersistStore
 import Database.Persist.Sql.Types
 import Database.Persist.Sql.Types.Internal (IsolationLevel)
 import Database.Persist.Sql.Raw
 
-import Control.Concurrent
-
-putStrLnWithThread :: String -> IO ()
-putStrLnWithThread msg = do
-    me <- myThreadId
-    putStrLn $ "[" ++ show me ++ "] " ++ msg
-
--- | Convert a 'Pool' into an 'Acquire'.
-poolToAcquire :: Pool a -> Acquire a
-poolToAcquire pool = fst <$> mkAcquireType getResource freeResource
-  where
-    getResource = do
-        putStrLnWithThread "Taking resource from Acquire"
-        takeResource pool
-    freeResource (resource, localPool) x = do
-        putStrLnWithThread $ "in free resource, reason: " <> show x
-        case x of
-            ReleaseException -> do
-                putStrLnWithThread "in freeResource: destroying resource"
-                destroyResource pool localPool resource
-                putStrLnWithThread "boom destroyed"
-            _ -> do
-                putStrLnWithThread "putresource"
-                putResource localPool resource
-                putStrLnWithThread "putresource complete"
-
--- | 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 = MonadReader.asks poolToAcquire
-
-
--- | 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.
 --
@@ -106,7 +31,6 @@ runSqlPool
     :: forall backend m a. (MonadUnliftIO m, BackendCompatible SqlBackend backend)
     => ReaderT backend m a -> Pool backend -> m a
 runSqlPool r pconn = do
-    -- with (acquireSqlConnFromPool pconn) $ runReaderT r
     withRunInIO $ \runInIO ->
         withResource pconn $ \conn -> do
             let sqlBackend = projectBackend conn
@@ -134,28 +58,6 @@ runSqlPoolWithIsolation r pconn i =
             connCommit sqlBackend getter
             pure a
 
--- | Like 'withResource', but times out the operation if resource
--- allocation does not complete within the given timeout period.
---
--- @since 2.0.0
-withResourceTimeout
-  :: forall a m b.  (MonadUnliftIO m)
-  => Int -- ^ Timeout period in microseconds
-  -> Pool a
-  -> (a -> m b)
-  -> m (Maybe b)
-{-# SPECIALIZE withResourceTimeout :: Int -> Pool a -> (a -> IO b) -> IO (Maybe b) #-}
-withResourceTimeout ms pool act = withRunInIO $ \runInIO -> mask $ \restore -> do
-    mres <- timeout ms $ takeResource pool
-    case mres of
-        Nothing -> runInIO $ return (Nothing :: Maybe b)
-        Just (resource, local) -> do
-            ret <- restore (runInIO (liftM Just $ act resource)) `onException`
-                    destroyResource pool local resource
-            putResource local resource
-            return ret
-{-# INLINABLE withResourceTimeout #-}
-
 rawAcquireSqlConn
     :: forall backend m
      . (MonadReader backend m, BackendCompatible SqlBackend backend)
@@ -173,10 +75,8 @@ rawAcquireSqlConn isolation = do
 
         finishTransaction :: backend -> ReleaseType -> IO ()
         finishTransaction _ relType = case relType of
-            ReleaseExceptionWith e -> do
-                putStrLnWithThread $ "got a release exception: " <> show e
+            ReleaseException -> do
                 connRollback rawConn getter
-                putStrLnWithThread "rolled back transaction"
             _ -> connCommit rawConn getter
 
     return $ mkAcquireType beginTransaction finishTransaction
@@ -278,10 +178,9 @@ createSqlPoolWithConfig mkConn config = do
             runLoggingT
               (logError $ T.pack $ "Error closing database connection in pool: " ++ show e)
               logFunc
-            putStrLnWithThread "exception caught boss"
             UE.throwIO (e :: UE.SomeException)
     liftIO $ createPool
-        (putStrLnWithThread "creating conn" >> mkConn logFunc)
+        (mkConn logFunc)
         loggedClose
         (connectionPoolConfigStripes config)
         (connectionPoolConfigIdleTimeout config)
@@ -351,8 +250,5 @@ withSqlConn open f = do
 
 close' :: (BackendCompatible SqlBackend backend) => backend -> IO ()
 close' conn = do
-    putStrLnWithThread "close' called"
     readIORef (connStmtMap $ projectBackend conn) >>= mapM_ stmtFinalize . Map.elems
-    putStrLnWithThread "statements finalized boss"
     connClose $ projectBackend conn
-    putStrLnWithThread "connection closed, boss"
diff --git a/persistent/persistent.cabal b/persistent/persistent.cabal
index 5e259062e..08bbf6ba4 100644
--- a/persistent/persistent.cabal
+++ b/persistent/persistent.cabal
@@ -37,7 +37,6 @@ library
                    , path-pieces              >= 0.2
                    , resource-pool            >= 0.2.3
                    , resourcet                >= 1.1.10
-                   , resourcet-pool
                    , scientific
                    , silently
                    , template-haskell         >= 2.4
diff --git a/stack.yaml b/stack.yaml
index 10ca13bc5..4d454a921 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -9,10 +9,3 @@ packages:
   - ./persistent-postgresql
   - ./persistent-redis
   - ./persistent-qq
-
-extra-deps:
-  - resourcet-pool-0.1.0.0
-  - git: https://github.com/parsonsmatt/conduit
-    commit: eb66c6e9d9d92c460b2db151b0c4dff1f3ba2812
-    subdirs:
-    - resourcet

From 01d932e16f789f7d020f97eec2fe6ff20bd74e19 Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Tue, 16 Mar 2021 16:24:11 -0600
Subject: [PATCH 06/13] slot it in the right changelog spot

---
 persistent/ChangeLog.md | 7 ++++++-
 1 file changed, 6 insertions(+), 1 deletion(-)

diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md
index 35ccb1576..f79483da4 100644
--- a/persistent/ChangeLog.md
+++ b/persistent/ChangeLog.md
@@ -1,6 +1,6 @@
 # Changelog for persistent
 
-## 2.12
+## 2.12 (unreleased)
 
 * [#1162](https://github.com/yesodweb/persistent/pull/1162)
   * Replace `askLogFunc` with `askLoggerIO`
@@ -12,6 +12,11 @@
 * [#1179](https://github.com/yesodweb/persistent/pull/1179)
   * Added `Compatible`, a newtype for marking a backend as compatible with another. Use it with `DerivingVia` to derive simple instances based on backend compatibility.
   * Added `makeCompatibleInstances` and `makeCompatibleKeyInstances`, TemplateHaskell invocations for auto-generating standalone derivations using `Compatible` and `DerivingVia`.
+* [#1207](https://github.com/yesodweb/persistent/pull/1207)
+    * @codygman discovered a bug in [issue #1199](https://github.com/yesodweb/persistent/issues/1199) where postgres connections were being returned to the `Pool SqlBackend` in an inconsistent state.
+      @parsonsmatt debugged the issue and determined that it had something to do with asynchronous exceptions. 
+      Declaring it to be "out of his pay grade," he ripped the `poolToAcquire` function out and replaced it with `Data.Pool.withResource`, which doesn't exhibit the bug.
+      Fortunately, this doesn't affect the public API, and can be a mere bug release.
 
 ## 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)

From 8d849e44f04550f46797e3cf1cccfad2619b5778 Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Tue, 16 Mar 2021 16:26:03 -0600
Subject: [PATCH 07/13] remove test

---
 persistent/Database/Persist/Sql/Run.hs |  2 +-
 test.hs                                | 57 --------------------------
 2 files changed, 1 insertion(+), 58 deletions(-)
 delete mode 100644 test.hs

diff --git a/persistent/Database/Persist/Sql/Run.hs b/persistent/Database/Persist/Sql/Run.hs
index 7701ba2e2..7dcfb0972 100644
--- a/persistent/Database/Persist/Sql/Run.hs
+++ b/persistent/Database/Persist/Sql/Run.hs
@@ -132,7 +132,7 @@ liftSqlPersistMPool
 liftSqlPersistMPool x pool = liftIO (runSqlPersistMPool x pool)
 
 withSqlPool
-    :: forall backend m a. (MonadLogger m, MonadLoggerIO m, MonadUnliftIO m, BackendCompatible SqlBackend backend)
+    :: forall backend m a. (MonadLoggerIO m, MonadUnliftIO m, BackendCompatible SqlBackend backend)
     => (LogFunc -> IO backend) -- ^ create a new connection
     -> Int -- ^ connection count
     -> (Pool backend -> m a)
diff --git a/test.hs b/test.hs
deleted file mode 100644
index 239dab6d6..000000000
--- a/test.hs
+++ /dev/null
@@ -1,57 +0,0 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeApplications #-}
-module Main where
-
-import  qualified Control.Monad as Monad
-import qualified Control.Concurrent as Concurrent
-import qualified Control.Exception as Exception
-import qualified Database.Persist as Persist
-import qualified Database.Persist.Sql as Persist
-import qualified Database.Persist.Postgresql as Persist
-import qualified Control.Monad.Logger as Logger
-import qualified Data.ByteString as BS
-import qualified Data.Pool as Pool
-import Data.Time
-
-main :: IO ()
-main = do
-
-  -- I started a postgres server with:
-  -- docker run --rm --name some-postgres -p 5432:5432 -e POSTGRES_PASSWORD=secret postgres
-  pool <- Logger.runNoLoggingT $ Persist.createPostgresqlPool "postgresql://postgres:secret@localhost:5433/postgres" 1
-
-  Monad.void $ createTableFoo pool
-
-  getCurrentTime >>= \now ->
-    simulateFailedLongRunningPostgresCall pool
-
-  Pool.destroyAllResources pool
-
-  result :: Either Exception.SomeException [Persist.Single String] <-
-    Exception.try . ((flip Persist.runSqlPersistMPool) pool) $ do
-        Persist.rawSql @(Persist.Single String) "select pg_sleep(5)" []
-
-  -- when we try the above we get back:
-  -- 'result: Left libpq: failed (another command is already in progress'
-  -- this is because the connection went back into the pool before it was ready
-  -- or perhaps it should have been destroyed and a new connection created and put into the pool?
-  putStrLn $ "result: " <> show result
-
-createTableFoo :: Pool.Pool Persist.SqlBackend -> IO ()
-createTableFoo pool = (flip Persist.runSqlPersistMPool) pool $ do
-  Persist.rawExecute "CREATE table if not exists foo(id int);" []
-
-simulateFailedLongRunningPostgresCall :: Pool.Pool Persist.SqlBackend -> IO ()
-simulateFailedLongRunningPostgresCall pool = do
-  threadId <- Concurrent.forkIO
-    $ (do
-        let numThings :: Int = 100000000
-        putStrLn $ "start inserting " <> show numThings <> " things"
-        Monad.forM_ [1 .. numThings] $ \_ -> do
-          (flip Persist.runSqlPersistMPool) pool $
-            Persist.rawExecute "insert into foo values(1);" []
-      )
-  Concurrent.threadDelay 5000000
-  Monad.void $ Concurrent.killThread threadId
-  putStrLn "killed thread"

From 23c354ccc88fa1db47980cdc6412365feafde184 Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Tue, 16 Mar 2021 16:27:53 -0600
Subject: [PATCH 08/13] Add comment

---
 persistent/Database/Persist/Sql/Run.hs | 3 +++
 1 file changed, 3 insertions(+)

diff --git a/persistent/Database/Persist/Sql/Run.hs b/persistent/Database/Persist/Sql/Run.hs
index 7dcfb0972..b98dd36b8 100644
--- a/persistent/Database/Persist/Sql/Run.hs
+++ b/persistent/Database/Persist/Sql/Run.hs
@@ -24,6 +24,9 @@ import Database.Persist.Sql.Raw
 -- | Get a connection from the pool, run the given action, and then return the
 -- connection to the pool.
 --
+-- This function performs the given action in a transaction. If an
+-- exception occurs during the action, then the transaction is rolled back.
+--
 -- Note: This function previously timed out after 2 seconds, but this behavior
 -- was buggy and caused more problems than it solved. Since version 2.1.2, it
 -- performs no timeout checks.

From 656d724392dcfe8d66ddc8c95bd6592ad0140536 Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Tue, 16 Mar 2021 16:29:32 -0600
Subject: [PATCH 09/13] use UnliftIO.Exception entirely

---
 persistent/Database/Persist/Sql/Run.hs | 5 ++---
 1 file changed, 2 insertions(+), 3 deletions(-)

diff --git a/persistent/Database/Persist/Sql/Run.hs b/persistent/Database/Persist/Sql/Run.hs
index b98dd36b8..b9cdb3c9c 100644
--- a/persistent/Database/Persist/Sql/Run.hs
+++ b/persistent/Database/Persist/Sql/Run.hs
@@ -1,7 +1,6 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 module Database.Persist.Sql.Run where
 
-import Control.Exception (catch)
 import Control.Monad.IO.Unlift
 import qualified UnliftIO.Exception as UE
 import Control.Monad.Logger.CallStack
@@ -177,11 +176,11 @@ createSqlPoolWithConfig mkConn config = do
     -- Resource pool will swallow any exceptions from close. We want to log
     -- them instead.
     let loggedClose :: backend -> IO ()
-        loggedClose backend = close' backend `catch` \e -> do
+        loggedClose backend = close' backend `UE.catchAny` \e -> do
             runLoggingT
               (logError $ T.pack $ "Error closing database connection in pool: " ++ show e)
               logFunc
-            UE.throwIO (e :: UE.SomeException)
+            UE.throwIO e
     liftIO $ createPool
         (mkConn logFunc)
         loggedClose

From fcb51a0ab34cf673c0dead48e2db2d90f42c10af Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Tue, 16 Mar 2021 16:32:36 -0600
Subject: [PATCH 10/13] factor it out

---
 persistent/Database/Persist/Sql.hs     |  2 +-
 persistent/Database/Persist/Sql/Run.hs | 18 ++++++++----------
 2 files changed, 9 insertions(+), 11 deletions(-)

diff --git a/persistent/Database/Persist/Sql.hs b/persistent/Database/Persist/Sql.hs
index 50070938b..a0e802507 100644
--- a/persistent/Database/Persist/Sql.hs
+++ b/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 (rawAcquireSqlConn)
+import Database.Persist.Sql.Run hiding (rawAcquireSqlConn, rawRunSqlPool)
 import Database.Persist.Sql.Raw
 import Database.Persist.Sql.Migration
 import Database.Persist.Sql.Internal
diff --git a/persistent/Database/Persist/Sql/Run.hs b/persistent/Database/Persist/Sql/Run.hs
index b9cdb3c9c..67aa08380 100644
--- a/persistent/Database/Persist/Sql/Run.hs
+++ b/persistent/Database/Persist/Sql/Run.hs
@@ -33,15 +33,7 @@ runSqlPool
     :: forall backend m a. (MonadUnliftIO m, BackendCompatible SqlBackend backend)
     => ReaderT backend m a -> Pool backend -> m a
 runSqlPool r pconn = do
-    withRunInIO $ \runInIO ->
-        withResource pconn $ \conn -> do
-            let sqlBackend = projectBackend conn
-            let getter = getStmtConn sqlBackend
-            connBegin sqlBackend getter Nothing
-            a <- runInIO (runReaderT r conn)
-                `UE.onException` connRollback sqlBackend getter
-            connCommit sqlBackend getter
-            pure a
+    rawRunSqlPool r pconn Nothing
 
 -- | Like 'runSqlPool', but supports specifying an isolation level.
 --
@@ -50,11 +42,17 @@ runSqlPoolWithIsolation
     :: forall backend m a. (MonadUnliftIO m, BackendCompatible SqlBackend backend)
     => ReaderT backend m a -> Pool backend -> IsolationLevel -> m a
 runSqlPoolWithIsolation r pconn i =
+    rawRunSqlPool r pconn (Just i)
+
+rawRunSqlPool
+    :: forall backend m a. (MonadUnliftIO m, BackendCompatible SqlBackend backend)
+    => ReaderT backend m a -> Pool backend -> Maybe IsolationLevel -> m a
+runSqlPoolWithIsolation r pconn mi =
     withRunInIO $ \runInIO ->
         withResource pconn $ \conn -> do
             let sqlBackend = projectBackend conn
             let getter = getStmtConn sqlBackend
-            connBegin sqlBackend getter (Just i)
+            connBegin sqlBackend getter mi
             a <- runInIO (runReaderT r conn)
                 `UE.onException` connRollback sqlBackend getter
             connCommit sqlBackend getter

From 0b1284f3eceace13ecd00c24068f35807bb13bb4 Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Tue, 16 Mar 2021 16:56:27 -0600
Subject: [PATCH 11/13] more fixes

---
 persistent/ChangeLog.md                |  2 +
 persistent/Database/Persist/Sql/Run.hs | 58 +++++++++++++++++++++++---
 2 files changed, 54 insertions(+), 6 deletions(-)

diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md
index f79483da4..af5056e20 100644
--- a/persistent/ChangeLog.md
+++ b/persistent/ChangeLog.md
@@ -17,6 +17,8 @@
       @parsonsmatt debugged the issue and determined that it had something to do with asynchronous exceptions. 
       Declaring it to be "out of his pay grade," he ripped the `poolToAcquire` function out and replaced it with `Data.Pool.withResource`, which doesn't exhibit the bug.
       Fortunately, this doesn't affect the public API, and can be a mere bug release.
+    * Removed the functions `unsafeAcquireSqlConnFromPool`, `acquireASqlConnFromPool`, and `acquireSqlConnFromPoolWithIsolation`. 
+      For a replacement, see `runSqlPoolNoTransaction` and `runSqlPoolWithHooks`.
 
 ## 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)
diff --git a/persistent/Database/Persist/Sql/Run.hs b/persistent/Database/Persist/Sql/Run.hs
index 67aa08380..81e0a77a6 100644
--- a/persistent/Database/Persist/Sql/Run.hs
+++ b/persistent/Database/Persist/Sql/Run.hs
@@ -44,18 +44,64 @@ runSqlPoolWithIsolation
 runSqlPoolWithIsolation r pconn i =
     rawRunSqlPool r pconn (Just i)
 
+-- | Like 'runSqlPool', but does not surround the action in a transaction.
+-- This action might leave your database in a weird state.
+--
+-- @since 2.12.0.0
+runSqlPoolNoTransaction
+    :: forall backend m a. (MonadUnliftIO m, BackendCompatible SqlBackend backend)
+    => ReaderT backend m a -> Pool backend -> Maybe IsolationLevel -> m a
+runSqlPoolNoTransaction r pconn i =
+    runSqlPoolWithHooks r pconn i (\_ -> pure ()) (\_ -> pure ()) (\_ _ -> pure ())
+
 rawRunSqlPool
     :: forall backend m a. (MonadUnliftIO m, BackendCompatible SqlBackend backend)
     => ReaderT backend m a -> Pool backend -> Maybe IsolationLevel -> m a
-runSqlPoolWithIsolation r pconn mi =
+rawRunSqlPool r pconn mi =
+    runSqlPoolWithHooks r pconn mi before after onException
+  where
+    before conn = do
+        let sqlBackend = projectBackend conn
+        let getter = getStmtConn sqlBackend
+        liftIO $ connBegin sqlBackend getter mi
+    after conn = do
+        let sqlBackend = projectBackend conn
+        let getter = getStmtConn sqlBackend
+        liftIO $ connCommit sqlBackend getter
+    onException conn _ = do
+        let sqlBackend = projectBackend conn
+        let getter = getStmtConn sqlBackend
+        liftIO $ connRollback sqlBackend getter
+
+-- | This function is how 'runSqlPool' and 'runSqlPoolNoTransaction' are
+-- defined. In addition to the action to be performed and the 'Pool' of
+-- conections to use, we give you the opportunity to provide three actions
+-- - initialize, afterwards, and onException.
+--
+-- @since 2.12.0.0
+runSqlPoolWithHooks
+    :: forall backend m a before after onException. (MonadUnliftIO m, BackendCompatible SqlBackend backend)
+    => ReaderT backend m a
+    -> Pool backend
+    -> Maybe IsolationLevel
+    -> (backend -> m before)
+    -- ^ Run this action immediately before the action is performed.
+    -> (backend -> m after)
+    -- ^ Run this action immediately after the action is completed.
+    -> (backend -> UE.SomeException -> m onException)
+    -- ^ This action is performed when an exception is received. The
+    -- exception is provided as a convenience - it is rethrown once this
+    -- cleanup function is complete.
+    -> m a
+runSqlPoolWithHooks r pconn i before after onException =
     withRunInIO $ \runInIO ->
         withResource pconn $ \conn -> do
-            let sqlBackend = projectBackend conn
-            let getter = getStmtConn sqlBackend
-            connBegin sqlBackend getter mi
+            runInIO $ before conn
             a <- runInIO (runReaderT r conn)
-                `UE.onException` connRollback sqlBackend getter
-            connCommit sqlBackend getter
+                `UE.catchAny` \e -> do
+                    runInIO $ onException conn e
+                    UE.throwIO e
+            runInIO $ after conn
             pure a
 
 rawAcquireSqlConn

From 99de6ab979de278e85e8c8a0c6b99babe6715e10 Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Wed, 17 Mar 2021 14:54:57 -0600
Subject: [PATCH 12/13] use masking behavior from old code

---
 persistent/Database/Persist/Sql/Run.hs | 17 +++++++++--------
 1 file changed, 9 insertions(+), 8 deletions(-)

diff --git a/persistent/Database/Persist/Sql/Run.hs b/persistent/Database/Persist/Sql/Run.hs
index 81e0a77a6..2bc79b3ea 100644
--- a/persistent/Database/Persist/Sql/Run.hs
+++ b/persistent/Database/Persist/Sql/Run.hs
@@ -95,14 +95,15 @@ runSqlPoolWithHooks
     -> m a
 runSqlPoolWithHooks r pconn i before after onException =
     withRunInIO $ \runInIO ->
-        withResource pconn $ \conn -> do
-            runInIO $ before conn
-            a <- runInIO (runReaderT r conn)
-                `UE.catchAny` \e -> do
-                    runInIO $ onException conn e
-                    UE.throwIO e
-            runInIO $ after conn
-            pure a
+    withResource pconn $ \conn ->
+    UE.mask $ \restore -> do
+        _ <- restore $ runInIO $ before conn
+        a <- restore (runInIO (runReaderT r conn))
+            `UE.catchAny` \e -> do
+                _ <- restore $ runInIO $ onException conn e
+                UE.throwIO e
+        _ <- restore $ runInIO $ after conn
+        pure a
 
 rawAcquireSqlConn
     :: forall backend m

From ec6e51d252c2c18f070058b808c7220d58a407d5 Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Wed, 17 Mar 2021 15:13:21 -0600
Subject: [PATCH 13/13] re-add the cabal section, but don't build by default

---
 .../persistent-postgresql.cabal                | 18 ++++++++++++++++++
 1 file changed, 18 insertions(+)

diff --git a/persistent-postgresql/persistent-postgresql.cabal b/persistent-postgresql/persistent-postgresql.cabal
index 9a9ec1556..3afa27c75 100644
--- a/persistent-postgresql/persistent-postgresql.cabal
+++ b/persistent-postgresql/persistent-postgresql.cabal
@@ -80,3 +80,21 @@ test-suite test
                    , unordered-containers
                    , vector
     default-language: Haskell2010
+
+executable conn-kill
+    buildable: False
+    main-is: Main.hs
+    hs-source-dirs: conn-killed
+    ghc-options: -threaded
+    build-depends:
+        base
+      , persistent-postgresql
+      , monad-logger
+      , text
+      , unliftio
+      , time
+      , transformers
+      , persistent
+      , bytestring
+      , resource-pool
+      , mtl