From 09406a445b90fa62b7b3e69290b37a7d76aceb2a Mon Sep 17 00:00:00 2001 From: Josh Miller Date: Sat, 3 Sep 2022 18:25:58 -0500 Subject: [PATCH] Prevent FdData leaks in getNotification The rationale for this change is a memory leak observed in a production application using `postgresql-simple-0.6.4`. The related code is proprietary but I will try to give the gist of the issue. If a minimal repro is requested I could put one together. When `getNotification` is blocking in an `async`-spawned thread, upon cancelling and restarting the thread in a loop (reusing the same connection) a heap profile shows an increasing amount of `FdData` closures building up (along with a few other closures, e.g. the `TVar Nothing` created in `threadWaitSTM`). Forgive my limited knowledge of the GHC `EventManager`, but it seems that the registered callback made by `threadWaitReadSTM` does not get removed from the `EventManager` state when `waitRead` (I presume) is interrupted by the `AsyncCancelled`. This change somewhat mirrors how the non-STM `threadWait` handles exceptions, and so I think it should be benign. I've tested this change against our application and confirmed the `FdData` and related closures are no longer hanging around. --- src/Database/PostgreSQL/Simple/Notification.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Database/PostgreSQL/Simple/Notification.hs b/src/Database/PostgreSQL/Simple/Notification.hs index 5ffda98..961ee5d 100644 --- a/src/Database/PostgreSQL/Simple/Notification.hs +++ b/src/Database/PostgreSQL/Simple/Notification.hs @@ -37,7 +37,7 @@ module Database.PostgreSQL.Simple.Notification ) where import Control.Monad ( join, void ) -import Control.Exception ( throwIO, catch ) +import Control.Exception ( throwIO, onException, mapException ) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 import Database.PostgreSQL.Simple.Internal @@ -120,9 +120,10 @@ getNotification conn = join $ withConnection conn fetch -- the lock... but such a major bug is likely to exhibit -- itself in an at least somewhat more dramatic fashion.) Just fd -> do - (waitRead, _) <- threadWaitReadSTM fd + (waitRead, unregister) <- threadWaitReadSTM fd return $ do - atomically waitRead `catch` (throwIO . setIOErrorLocation) + mapException setIOErrorLocation + (atomically waitRead `onException` unregister) loop #endif