From 73a465501e9574fbd77505fb807a461392f3c52e Mon Sep 17 00:00:00 2001
From: Michal Kleczek <michal@kleczek.org>
Date: Wed, 28 Jan 2026 23:13:59 +0100
Subject: [PATCH] fix: listener running with exception masked after first
 failure

---
 CHANGELOG.md                 |  1 +
 src/PostgREST/Listener.hs    | 16 ++++++++++------
 src/PostgREST/Observation.hs | 12 +++++-------
 3 files changed, 16 insertions(+), 13 deletions(-)

diff --git a/CHANGELOG.md b/CHANGELOG.md
index 7aa83be92..6417be375 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -15,6 +15,7 @@ All notable changes to this project will be documented in this file. From versio
 
 - Ensure Listener connections are released by @mkleczek in #4614
 - Fix incorrectly filtering the returned representation for PATCH requests when using `or/and` filters by @laurenceisla in #3707
+- Fix listener running with exception masked after first failure #4615
 
 ## [14.3] - 2026-01-03
 
diff --git a/src/PostgREST/Listener.hs b/src/PostgREST/Listener.hs
index 9fcf77263..e801e1d69 100644
--- a/src/PostgREST/Listener.hs
+++ b/src/PostgREST/Listener.hs
@@ -31,15 +31,16 @@ runListener :: AppState -> IO ()
 runListener appState = do
   AppConfig{..} <- getConfig appState
   when configDbChannelEnabled $
-    void . forkIO $ retryingListen appState
+    void . forkIO . void $ retryingListen appState
 
 -- | Starts a LISTEN connection and handles notifications. It recovers with exponential backoff with a cap of 32 seconds, if the LISTEN connection is lost.
-retryingListen :: AppState -> IO ()
+-- | This function never returns (but can throw) and return type enforces that.
+retryingListen :: AppState -> IO Void
 retryingListen appState = do
   AppConfig{..} <- AppState.getConfig appState
   let
     dbChannel = toS configDbChannel
-    handleFinally err = do
+    onError err = do
       AppState.putIsListenerOn appState False
       observer $ DBListenFail dbChannel (Right err)
       when (isDbListenerBug err) $
@@ -53,10 +54,11 @@ retryingListen appState = do
       threadDelay (delay * oneSecondInMicro)
       unless (delay == maxDelay) $
         AppState.putNextListenerDelay appState (delay * 2)
+      -- loop running the listener
       retryingListen appState
 
-  -- forkFinally allows to detect if the thread dies
-  void . flip forkFinally handleFinally $ do
+  -- Execute the listener with with error handling
+  handle onError $ do
     -- Make sure we don't leak connections on errors
     bracket
       -- acquire connection
@@ -81,7 +83,9 @@ retryingListen appState = do
 
           observer $ DBListenStart pqHost pqPort pgFullName dbChannel
 
-          SQL.waitForNotifications handleNotification db
+          -- wait for notifications
+          -- this will never return, in case of an error it will throw and be caught by onError
+          forever $ SQL.waitForNotifications handleNotification db
 
         Left err -> do
           observer $ DBListenFail dbChannel (Left err)
diff --git a/src/PostgREST/Observation.hs b/src/PostgREST/Observation.hs
index 9f1e646e4..96a8a30ef 100644
--- a/src/PostgREST/Observation.hs
+++ b/src/PostgREST/Observation.hs
@@ -45,7 +45,7 @@ data Observation
   | SchemaCacheLoadedObs Double
   | ConnectionRetryObs Int
   | DBListenStart (Maybe ByteString) (Maybe ByteString) Text Text -- host, port, version string, channel
-  | DBListenFail Text (Either SQL.ConnectionError (Either SomeException ()))
+  | DBListenFail Text (Either SQL.ConnectionError SomeException)
   | DBListenRetry Int
   | DBListenBugHint -- https://github.com/PostgREST/postgrest/issues/3147
   | DBListenerGotSCacheMsg ByteString
@@ -171,14 +171,12 @@ observationMessage = \case
     showListenerConnError :: SQL.ConnectionError -> Text
     showListenerConnError = maybe "Connection error" (showOnSingleLine '\t' . T.decodeUtf8)
 
-    showListenerException :: Either SomeException () -> Text
-    showListenerException (Right _) = "Failed getting notifications" -- should not happen as the listener will never finish (hasql-notifications uses `forever` internally) with a Right result
-    showListenerException (Left e)  = showOnSingleLine '\t' $ show e
+    showListenerException :: SomeException -> Text
+    showListenerException = showOnSingleLine '\t' . show
 
 
 showOnSingleLine :: Char -> Text -> Text
 showOnSingleLine split txt = T.intercalate " " $ T.filter (/= split) <$> T.lines txt -- the errors from hasql-notifications come intercalated with "\t\n"
 
-isDbListenerBug :: Either SomeException () -> Bool
-isDbListenerBug (Left e) = "could not access status of transaction" `T.isInfixOf` show e
-isDbListenerBug _        = False
+isDbListenerBug :: SomeException -> Bool
+isDbListenerBug e = "could not access status of transaction" `T.isInfixOf` show e