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..3f2599a41 100644 --- a/persistent/Database/Persist/Sql/Run.hs +++ b/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)