Backport #1207 to persistent-2.10.5

.github/workflows/haskell.yml

@@ -10,6 +10,19 @@ on:
 jobs:
   build:
     services:
+      postgres:
+        image: postgres:12-alpine
+        env:
+          POSTGRES_USER: perstest
+          POSTGRES_PASSWORD: perstest
+          POSTGRES_DB: persistent
+        ports:
+          - 5432:5432
+        options: >-
+          --health-cmd pg_isready
+          --health-interval 10s
+          --health-timeout 5s
+          --health-retries 5
       # mysql-service Label used to access the service container
       mysql-service:
         # Docker Hub image (also with version)
@@ -33,24 +46,24 @@ jobs:
     strategy:
       matrix:
         cabal: ["3.2"]
-        ghc: ["8.6.5", "8.8.3", "8.10.1"]
+        ghc:
+          - "8.2.2"
+          - "8.4.4"
+          - "8.6.5"
+          - "8.8.4"
+          - "8.10.1"
+
     env:
       CONFIG: "--enable-tests"
     steps:
       - uses: actions/checkout@v2
-      - uses: actions/[email protected].2
+      - uses: actions/[email protected].4
         id: setup-haskell-cabal
         with:
           ghc-version: ${{ matrix.ghc }}
           cabal-version: ${{ matrix.cabal }}
       - name: Check MySQL connection
         run: mysql -utest -ptest -h127.0.0.1 --port=33306 test -e "SELECT 1;"
-      - uses: harmon758/postgresql-action@v1
-        with:
-           postgresql version: '12'  # See https://hub.docker.com/_/postgres for available versions  
-           postgresql user: perstest
-           postgresql password: perstest
-           postgresql db: persistent
       - name: Start MongoDB
         uses: supercharge/[email protected]
       - name: Start Redis

persistent-postgresql/persistent-postgresql.cabal

@@ -72,6 +72,7 @@ test-suite test
                    , time
                    , transformers
                    , unliftio-core
+                   , unliftio
                    , unordered-containers
                    , vector
     default-language: Haskell2010

persistent-postgresql/test/PgInit.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module PgInit (
@@ -38,7 +38,6 @@ import Init
     )
 
 -- re-exports
-import Control.Exception (SomeException)
 import Control.Monad (void, replicateM, liftM, when, forM_)
 import Control.Monad.Trans.Reader
 import Data.Aeson (Value(..))
@@ -55,6 +54,7 @@ import Test.QuickCheck
 import Control.Monad (unless, (>=>))
 import Control.Monad.IO.Class
 import Control.Monad.IO.Unlift (MonadUnliftIO)
+import UnliftIO.Exception
 import Control.Monad.Logger
 import Control.Monad.Trans.Resource (ResourceT, runResourceT)
 import qualified Data.ByteString as BS
@@ -86,16 +86,33 @@ persistSettings = sqlSettings { mpsGeneric = True }
 
 runConn :: MonadUnliftIO m => SqlPersistT (LoggingT m) t -> m ()
 runConn f = do
-  travis <- liftIO isTravis
-  let debugPrint = not travis && _debugOn
-  let printDebug = if debugPrint then print . fromLogStr else void . return
-  flip runLoggingT (\_ _ _ s -> printDebug s) $ do
-    _ <- if travis
-      then withPostgresqlPool "host=localhost port=5432 user=postgres dbname=persistent" 1 $ runSqlPool f
-      else do
-        host <- fromMaybe "localhost" <$> liftIO dockerPg
-        withPostgresqlPool ("host=" <> host <> " port=5432 user=postgres dbname=test") 1 $ runSqlPool f
-    return ()
+    travis <- liftIO isTravis
+    let debugPrint = not travis && _debugOn
+    let printDebug = if debugPrint then print . fromLogStr else void . return
+        runLog a = runLoggingT a (\_ _ _ s -> printDebug s)
+    let go =
+            if travis
+            then
+                withPostgresqlPool "host=localhost port=5432 user=postgres dbname=persistent" 1 $ runSqlPool f
+            else do
+                host <- fromMaybe "localhost" <$> liftIO dockerPg
+                withPostgresqlPool ("host=" <> host <> " port=5432 user=postgres dbname=test") 1 $ runSqlPool f
+    -- horrifying hack :( postgresql is having weird connection failures in
+    -- CI, for no reason that i can determine. see this PR for notes:
+                    -- https://github.com/yesodweb/persistent/pull/1197
+    eres <- try $ runLog go
+    void $ case eres of
+        Left (err :: SomeException) -> do
+            eres' <- try $ runLog go
+            case eres' of
+                Left (err' :: SomeException) ->
+                    if show err == show err'
+                    then throwIO err
+                    else throwIO err'
+                Right a ->
+                    pure a
+        Right a ->
+            pure a
 
 db :: SqlPersistT (LoggingT (ResourceT IO)) () -> Assertion
 db actions = do

persistent/ChangeLog.md

@@ -1,5 +1,10 @@
 # Changelog for persistent
 
+## 2.10.5.4
+
+* Backported the fix from [#1207](https://github.com/yesodweb/persistent/pull/1207) for asynchronous exceptions.
+    * Deprecated the `Acquire` family of functions.
+
 ## 2.10.5.3
 
 * Backported the fix from [#1135](https://github.com/yesodweb/persistent/pull/1135) to the 2.10 branch.

persistent/Database/Persist/Sql/Run.hs

@@ -44,6 +44,8 @@ unsafeAcquireSqlConnFromPool = do
 
     return $ fst <$> mkAcquireType (P.takeResource pool) freeConn
 
+{-# DEPRECATED unsafeAcquireSqlConnFromPool "The Pool ~> Acquire functions are unpredictable and may result in resource leaks with asynchronous exceptions. They will be removed in 2.12. If you need them, please file an issue and we'll try to help get you sorted. See issue #1199 on GitHub for the debugging log." #-}
+
 
 -- | The returned 'Acquire' gets a connection from the pool, starts a new
 -- transaction and gives access to the prepared connection.
@@ -66,6 +68,8 @@ acquireSqlConnFromPool = do
     connFromPool <- unsafeAcquireSqlConnFromPool
     return $ connFromPool >>= acquireSqlConn
 
+{-# DEPRECATED acquireSqlConnFromPool "The Pool ~> Acquire functions are unpredictable and may result in resource leaks with asynchronous exceptions. They will be removed in 2.12. If you need them, please file an issue and we'll try to help get you sorted. See issue #1199 on GitHub for the debugging log." #-}
+--
 -- | Like 'acquireSqlConnFromPool', but lets you specify an explicit isolation
 -- level.
 --
@@ -77,6 +81,8 @@ acquireSqlConnFromPoolWithIsolation isolation = do
     connFromPool <- unsafeAcquireSqlConnFromPool
     return $ connFromPool >>= acquireSqlConnWithIsolation isolation
 
+{-# DEPRECATED acquireSqlConnFromPoolWithIsolation "The Pool ~> Acquire functions are unpredictable and may result in resource leaks with asynchronous exceptions. They will be removed in 2.12. If you need them, please file an issue and we'll try to help get you sorted. See issue #1199 on GitHub for the debugging log." #-}
+
 -- | Get a connection from the pool, run the given action, and then return the
 -- connection to the pool.
 --
@@ -86,7 +92,19 @@ acquireSqlConnFromPoolWithIsolation isolation = do
 runSqlPool
     :: (MonadUnliftIO m, BackendCompatible SqlBackend backend)
     => ReaderT backend m a -> Pool backend -> m a
-runSqlPool r pconn = with (acquireSqlConnFromPool pconn) $ runReaderT r
+runSqlPool r pconn =
+    withRunInIO $ \runInIO ->
+    withResource pconn $ \conn ->
+        mask $ \restore -> do
+            let sqlBackend = projectBackend conn
+            let getter = getStmtConn sqlBackend
+            restore $ connBegin sqlBackend getter Nothing
+            a <- restore (runInIO (runReaderT r conn))
+                `UE.catchAny` \e -> do
+                    restore $ connRollback sqlBackend getter
+                    UE.throwIO e
+            restore $ connCommit sqlBackend getter
+            pure a
 
 -- | Like 'runSqlPool', but supports specifying an isolation level.
 --
@@ -95,29 +113,18 @@ runSqlPoolWithIsolation
     :: (MonadUnliftIO m, BackendCompatible SqlBackend backend)
     => ReaderT backend m a -> Pool backend -> IsolationLevel -> m a
 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.
---
--- @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 #-}
+    withRunInIO $ \runInIO ->
+    withResource pconn $ \conn ->
+        mask $ \restore -> do
+            let sqlBackend = projectBackend conn
+            let getter = getStmtConn sqlBackend
+            restore $ connBegin sqlBackend getter (Just i)
+            a <- restore (runInIO (runReaderT r conn))
+                `UE.catchAny` \e -> do
+                    restore $ connRollback sqlBackend getter
+                    UE.throwIO e
+            restore $ connCommit sqlBackend getter
+            pure a
 
 rawAcquireSqlConn
     :: forall backend m

persistent/persistent.cabal

@@ -1,5 +1,5 @@
 name:            persistent
-version:         2.10.5.3
+version:         2.10.5.4
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <[email protected]>