From 7d75de5714433eb859d870604cf7f01b4067aea0 Mon Sep 17 00:00:00 2001
From: Andrey Prokopenko <andrey@chordify.net>
Date: Wed, 26 Aug 2026 11:35:08 +0200
Subject: [PATCH 1/2] fix: prevent connections being interrupted and sockets
 leakages

---
 .../Database/Persist/MySQL.hs                   | 17 ++++++++++-------
 1 file changed, 10 insertions(+), 7 deletions(-)

diff --git a/persistent-mysql-haskell/Database/Persist/MySQL.hs b/persistent-mysql-haskell/Database/Persist/MySQL.hs
index 7a15c41fb..cd63f532e 100644
--- a/persistent-mysql-haskell/Database/Persist/MySQL.hs
+++ b/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

From 3e12f5753e2e0a1c56c41f79c5372ae5d057bdf3 Mon Sep 17 00:00:00 2001
From: Andrey Prokopenko <andrey@chordify.net>
Date: Wed, 26 Aug 2026 12:46:01 +0200
Subject: [PATCH 2/2] fix: make `loggedClose` uninterruptible

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

diff --git a/persistent/Database/Persist/Sql/Run.hs b/persistent/Database/Persist/Sql/Run.hs
index 62e699c1b..442fb99cb 100644
--- a/persistent/Database/Persist/Sql/Run.hs
+++ b/persistent/Database/Persist/Sql/Run.hs
@@ -280,11 +280,11 @@ 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.
     let
         loggedClose :: backend -> IO ()
-        loggedClose backend =
+        loggedClose backend = UE.uninterruptibleMask_ $
             close' backend `UE.catchAny` \e -> do
                 runLoggingT
                     (logError $ T.pack $ "Error closing database connection in pool: " ++ show e)