Fix resource pool regression in persistent-mysql-haskell, persistent.

persistent-mysql-haskell/Database/Persist/MySQL.hs

@@ -48,6 +48,7 @@ module Database.Persist.MySQL
 ) where
 
 import Control.Arrow
+import Control.Exception (bracketOnError, uninterruptibleMask_)
 import Control.Monad
 import Control.Monad.IO.Class (MonadIO (..))
 import Control.Monad.IO.Unlift (MonadUnliftIO)
@@ -152,21 +153,23 @@ openMySQLConn :: (IsPersistBackend backend, BaseBackend backend ~ SqlBackend)
       -> LogFunc
       -> IO (MySQL.MySQLConn, backend)
 openMySQLConn ci@(MySQLConnectInfo innerCi _) logFunc = do
-    conn <- connect' ci
-    autocommit' conn False -- disable autocommit!
+    -- If anything after the socket is opened throws or is interrupted,
+    -- close the connection instead of leaking it.
+    conn <- bracketOnError (connect' ci) MySQL.close $ \conn -> do
+        autocommit' conn False -- disable autocommit!
+        pure conn
     smap <- newIORef $ Map.empty
     let stCache = mkStatementCache $ mkSimpleStatementCache smap
-    let backend =
-          mkPersistBackend $
-          projectBackend $
-          SqlBackend
+    let backend = mkPersistBackend $ projectBackend $ SqlBackend
           { connPrepare    = prepare' conn
           , connStmtMap    = stCache
           , connInsertSql  = insertSql'
           , connInsertManySql = Nothing
           , connUpsertSql = Nothing
           , connPutManySql = Just putManySql
-          , connClose      = MySQL.close conn
+          -- Since resource-pool-0.5.0.0 closing connection could be interrupted
+          -- by exception, leaking both the fd and server-side connection.
+          , connClose      = uninterruptibleMask_ (MySQL.close conn)
           , connMigrateSql = migrate' innerCi
           , connBegin      = const $ begin' conn
           , connCommit     = const $ commit' conn

persistent/Database/Persist/Sql/Run.hs

@@ -280,16 +280,17 @@ createSqlPoolWithConfig
     -> m (Pool backend)
 createSqlPoolWithConfig mkConn config = do
     logFunc <- askLoggerIO
-    -- Resource pool will swallow any exceptions from close. We want to log
-    -- them instead.
+    -- NOTE: resource-pool >= 0.5 no longer runs the pool's free action
+    -- uninterruptibly, and no longer swallows its exceptions.
+    -- - Sync exception will be caught and logged.
+    -- - Async exception will be propagated and also not interrupt closing.
     let
         loggedClose :: backend -> IO ()
-        loggedClose backend =
-            close' backend `UE.catchAny` \e -> do
+        loggedClose backend = UE.uninterruptibleMask_ $
+            close' backend `UE.catchAny` \e ->
                 runLoggingT
                     (logError $ T.pack $ "Error closing database connection in pool: " ++ show e)
                     logFunc
-                UE.throwIO e
     liftIO $
         createPool
             (mkConn logFunc)