{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes, RecordWildCards #-}
module Database.PostgreSQL.LibPQ.Notify
( getNotification
, getNotificationWithConfig
, defaultConfig
, Config (..)
) where
import Control.Exception (try, throwIO)
import qualified Database.PostgreSQL.LibPQ as PQ
import GHC.IO.Exception (IOException(..),IOErrorType(ResourceVanished))
#if defined(mingw32_HOST_OS)
import Control.Concurrent (threadDelay)
#else
import Control.Concurrent
import Control.Concurrent.STM(atomically)
#endif
import Data.Function(fix)
import Data.Bifunctor(first)
data Config = Config
{ startLoop :: IO ()
, beforeWait :: IO ()
#if defined(mingw32_HOST_OS)
, retryDelay :: Int
#endif
}
-- | Default configuration
defaultConfig :: Config
defaultConfig = Config
{ startLoop = pure ()
, beforeWait = pure ()
#if defined(mingw32_HOST_OS)
, retryDelay = 100000
#endif
}
funcName :: String
funcName = "Hasql.Notification.getNotification"
setLoc :: IOError -> IOError
setLoc err = err {ioe_location = funcName}
fdError :: IOError
fdError =
IOError { ioe_handle = Nothing
, ioe_type = ResourceVanished
, ioe_location = funcName
, ioe_description =
"failed to fetch file descriptor (did the connection time out?)"
, ioe_errno = Nothing
, ioe_filename = Nothing
}
{-|
Returns a single notification. If no notifications are
available, 'getNotificationWithConfig' blocks until one arrives.
Unlike 'getNotification', 'getNotificationWithConfig' takes in an
additional 'Config' parameter provides event hooks for operational insight.
The connection passed in cannot be used for anything else
while waiting on the notification or this call might never return.
Note that PostgreSQL does not
deliver notifications while a connection is inside a transaction.
-}
getNotificationWithConfig
:: Config
-- ^ 'Config' to instrument and configure the retry period on Windows.
-> PQ.Connection
-- ^ The connection. The connection cannot be used for anything else
-- while waiting on the notification or this call might never return.
-> IO (Either IOError PQ.Notify)
getNotificationWithConfig Config {..} c = fmap (first setLoc) $ try $ fix $ \next -> do
startLoop
PQ.notifies c >>= \case
-- We found a notification just return it
Just x -> pure x
-- There wasn't a notification so we need to register to wait on the file handle
Nothing -> PQ.socket c >>= \case
-- This is an odd error
Nothing -> throwIO fdError
-- Typical case. Register to wait on more data.
Just fd -> do
#if defined(mingw32_HOST_OS)
let fileNotification = threadDelay retryDelay
#else
action <-fst <$> threadWaitReadSTM fd
let fileNotification = atomically action
#endif
beforeWait
fileNotification
_ <- PQ.consumeInput c
next
getNotification
:: PQ.Connection
-> IO (Either IOError PQ.Notify)
getNotification = getNotificationWithConfig defaultConfig