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/3] 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/3] 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)

From 99ad3b362b02308d4c1dc6de3e27202313a0e3c5 Mon Sep 17 00:00:00 2001
From: Andrey Prokopenko <andrey@chordify.net>
Date: Mon, 31 Aug 2026 13:06:48 +0200
Subject: [PATCH 3/3] fix: do not rethrow sync exception, log it once

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

diff --git a/persistent/Database/Persist/Sql/Run.hs b/persistent/Database/Persist/Sql/Run.hs
index 442fb99cb..3f2599a41 100644
--- a/persistent/Database/Persist/Sql/Run.hs
+++ b/persistent/Database/Persist/Sql/Run.hs
@@ -282,14 +282,15 @@ createSqlPoolWithConfig mkConn config = do
     logFunc <- askLoggerIO
     -- 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 = UE.uninterruptibleMask_ $
-            close' backend `UE.catchAny` \e -> do
+            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)