From 16c767134c64278128ef9aec0c172d89e36fd6e5 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    | 17 +++++++++++------
 src/PostgREST/Observation.hs |  7 +++----
 3 files changed, 15 insertions(+), 10 deletions(-)

diff --git a/CHANGELOG.md b/CHANGELOG.md
index 1f00bb966..810abeebd 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -12,6 +12,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 d4d510e79..a551082c3 100644
--- a/src/PostgREST/Listener.hs
+++ b/src/PostgREST/Listener.hs
@@ -24,15 +24,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)
       unless configDbPoolAutomaticRecovery $
@@ -44,10 +45,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
@@ -68,7 +70,10 @@ retryingListen appState = do
             AppState.putNextListenerDelay appState 1
 
           observer $ DBListenStart 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 a75ee667c..bc4e63113 100644
--- a/src/PostgREST/Observation.hs
+++ b/src/PostgREST/Observation.hs
@@ -44,7 +44,7 @@ data Observation
   | SchemaCacheLoadedObs Double
   | ConnectionRetryObs Int
   | DBListenStart Text
-  | DBListenFail Text (Either SQL.ConnectionError (Either SomeException ()))
+  | DBListenFail Text (Either SQL.ConnectionError SomeException)
   | DBListenRetry Int
   | DBListenerGotSCacheMsg ByteString
   | DBListenerGotConfigMsg ByteString
@@ -167,9 +167,8 @@ 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