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 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)