fix: Listener retries should be performed with exceptions unmasked

forkFinally calls error handler with exceptions masked. Our handleFinally does not restore exception state before calling retryingListener so after first error the whole listener is running with exceptions masked.
This patch ensures handleFinally is run with exceptions unmasked.

Author: mkleczek

src/PostgREST/Listener.hs

@@ -39,7 +39,7 @@ 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 +53,16 @@ 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
+  -- We use mask to make sure onError is invoked in presence of asynchronous exceptions
+  -- but we execute the onError handler in an unmasked state to
+  -- 1. allow it to be interrupted
+  -- 2. make sure recursive call to retryingListen is not masked
+  -- TODO is masking really necessary here? We unmask the onError handler anyway...
+  void $ mask $ \unmask -> handle (unmask . onError) $ unmask $ do
     -- Make sure we don't leak connections on errors
     bracket
       -- acquire connection
@@ -81,6 +87,8 @@ retryingListen appState = do
 
           observer $ DBListenStart pqHost pqPort pgFullName dbChannel
 
+          -- wait for notifications indefinitely
+          -- this will never return, in case of an error it will throw and be caught by onError
           SQL.waitForNotifications handleNotification db
 
         Left err -> do

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 e  = showOnSingleLine '\t' $ show e
 
 
 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