Merge pull request #978 from yesodweb/log-close-exceptions

Log exceptions when closing a connection fails

persistent/ChangeLog.md

@@ -1,5 +1,9 @@
 # Changelog for persistent
 
+## 2.10.4
+
+* Log exceptions when closing a connection fails. See point 1 in [yesod #1635](https://github.com/yesodweb/yesod/issues/1635#issuecomment-547300856). [#978](https://github.com/yesodweb/persistent/pull/978)
+
 ## 2.10.3
 
 * Added support for GHC 8.8 about MonadFail changes [#976](https://github.com/yesodweb/persistent/pull/976)

persistent/Database/Persist/Sql/Run.hs

@@ -4,12 +4,14 @@ module Database.Persist.Sql.Run where
 import Control.Exception (bracket, mask, onException)
 import Control.Monad (liftM)
 import Control.Monad.IO.Unlift
-import Control.Monad.Logger
+import qualified UnliftIO.Exception as UE
+import Control.Monad.Logger.CallStack
 import Control.Monad.Trans.Reader hiding (local)
 import Control.Monad.Trans.Resource
 import Data.IORef (readIORef)
 import Data.Pool as P
 import qualified Data.Map as Map
+import qualified Data.Text as T
 import System.Timeout (timeout)
 
 import Database.Persist.Class.PersistStore
@@ -110,13 +112,19 @@ withSqlPool mkConn connCount f = withUnliftIO $ \u -> bracket
     (unliftIO u . f)
 
 createSqlPool
-    :: (MonadLogger m, MonadUnliftIO m, BackendCompatible SqlBackend backend)
+    :: forall m backend. (MonadLogger m, MonadUnliftIO m, BackendCompatible SqlBackend backend)
     => (LogFunc -> IO backend)
     -> Int
     -> m (Pool backend)
 createSqlPool mkConn size = do
     logFunc <- askLogFunc
-    liftIO $ createPool (mkConn logFunc) close' 1 20 size
+    -- Resource pool will swallow any exceptions from close. We want to log
+    -- them instead.
+    let loggedClose :: backend -> IO ()
+        loggedClose backend = close' backend `UE.catchAny` \e -> runLoggingT
+          (logError $ T.pack $ "Error closing database connection in pool: " ++ show e)
+          logFunc
+    liftIO $ createPool (mkConn logFunc) loggedClose 1 20 size
 
 -- NOTE: This function is a terrible, ugly hack. It would be much better to
 -- just clean up monad-logger.

persistent/persistent.cabal

@@ -1,5 +1,5 @@
 name:            persistent
-version:         2.10.3
+version:         2.10.4
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -44,6 +44,7 @@ library
                    , time                     >= 1.6
                    , transformers             >= 0.5
                    , unliftio-core
+                   , unliftio
                    , unordered-containers
                    , vector