diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +# hpqtypes-1.11.1.2 (2023-11-08) +* Support multihost setups and the `connect_timeout` parameter in the connection + string. + # hpqtypes-1.11.1.1 (2023-03-14) * Add support for GHC 9.6. diff --git a/hpqtypes.cabal b/hpqtypes.cabal --- a/hpqtypes.cabal +++ b/hpqtypes.cabal @@ -1,5 +1,5 @@ name: hpqtypes -version: 1.11.1.1 +version: 1.11.1.2 synopsis: Haskell bindings to libpqtypes description: Efficient and easy-to-use bindings to (slightly modified) @@ -21,7 +21,8 @@ category: Database build-type: Simple cabal-version: 1.24 -tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.7 || ==9.4.4 || ==9.6.1 +tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.7 || ==9.6.3 + || ==9.8.1 extra-source-files: README.md , CHANGELOG.md @@ -108,6 +109,7 @@ , transformers >= 0.2.2 , containers >= 0.5.0.0 , exceptions >= 0.9 + , stm >= 2.5.0.0 , text-show >= 2 , uuid-types >= 1.0.3 diff --git a/src/Database/PostgreSQL/PQTypes/Internal/C/Interface.hs b/src/Database/PostgreSQL/PQTypes/Internal/C/Interface.hs --- a/src/Database/PostgreSQL/PQTypes/Internal/C/Interface.hs +++ b/src/Database/PostgreSQL/PQTypes/Internal/C/Interface.hs @@ -17,8 +17,7 @@ , c_PQfname , c_PQclear , c_PQcancel - , c_PQconnectStart - , c_PQconnectPoll + , c_PQconnectdb , c_PQfinish -- * libpqtypes imports , c_PQinitTypes @@ -65,13 +64,9 @@ foreign import ccall safe "PQconsumeInput" c_PQconsumeInput :: Ptr PGconn -> IO CInt --- | Safe as it might make a DNS lookup. -foreign import ccall safe "PQconnectStart" - c_PQconnectStart :: CString -> IO (Ptr PGconn) - --- | Safe as it reads data from a socket. -foreign import ccall safe "PQconnectPoll" - c_PQconnectPoll :: Ptr PGconn -> IO PostgresPollingStatusType +-- | Safe as it connects to the database, which can take some time. +foreign import ccall safe "PQconnectdb" + c_PQconnectdb :: CString -> IO (Ptr PGconn) -- | Safe as it sends a terminate command to the server. foreign import ccall safe "PQfinish" diff --git a/src/Database/PostgreSQL/PQTypes/Internal/Connection.hs b/src/Database/PostgreSQL/PQTypes/Internal/Connection.hs --- a/src/Database/PostgreSQL/PQTypes/Internal/Connection.hs +++ b/src/Database/PostgreSQL/PQTypes/Internal/Connection.hs @@ -20,11 +20,11 @@ import Control.Concurrent import Control.Concurrent.Async +import Control.Concurrent.STM import Control.Monad import Control.Monad.Base import Control.Monad.Catch import Data.Bifunctor -import Data.Function import Data.IORef import Data.Kind import Data.Pool @@ -212,27 +212,40 @@ openConnection :: (forall r. IO r -> IO r) -> CString -> IO (Ptr PGconn) openConnection unmask conninfo = do - -- We want to use non-blocking C functions to be able to observe incoming - -- asynchronous exceptions, hence we don't use PQconnectdb here. - conn <- c_PQconnectStart conninfo - when (conn == nullPtr) $ - throwError "PQconnectStart returned a null pointer" - (`onException` c_PQfinish conn) . unmask $ fix $ \loop -> do - ps <- c_PQconnectPoll conn - if | ps == c_PGRES_POLLING_READING -> (threadWaitRead =<< getFd conn) >> loop - | ps == c_PGRES_POLLING_WRITING -> (threadWaitWrite =<< getFd conn) >> loop - | ps == c_PGRES_POLLING_OK -> return conn - | otherwise -> do - merr <- c_PQerrorMessage conn >>= safePeekCString - let reason = maybe "" (\err -> ": " <> err) merr - throwError $ "openConnection failed" <> reason + -- We use synchronous version of connecting to the database using + -- 'PQconnectdb' instead of 'PQconnectStart' and 'PQconnectPoll', because + -- the second method doesn't properly support the connect_timeout + -- parameter from the connection string nor multihost setups. + -- + -- The disadvantage of this is that a call to 'PQconnectdb' cannot be + -- interrupted if the Haskell thread running it receives an asynchronous + -- exception, so to guarantee prompt return in such scenario 'PQconnectdb' + -- is run in a separate child thread. If the parent receives an exception + -- while the child still runs, the child is signaled to clean up after + -- itself and left behind. + connVar <- newEmptyTMVarIO + runningVar <- newTVarIO True + _ <- forkIO $ do + conn <- c_PQconnectdb conninfo + join . atomically $ readTVar runningVar >>= \case + True -> do + putTMVar connVar conn + pure $ pure () + False -> pure $ c_PQfinish conn + conn <- atomically (takeTMVar connVar) `onException` do + join . atomically $ do + writeTVar runningVar False + maybe (pure ()) c_PQfinish <$> tryTakeTMVar connVar + (`onException` c_PQfinish conn) . unmask $ do + when (conn == nullPtr) $ do + throwError "PQconnectdb returned a null pointer" + status <- c_PQstatus conn + when (status /= c_CONNECTION_OK) $ do + merr <- c_PQerrorMessage conn >>= safePeekCString + let reason = maybe "" (\err -> ": " <> err) merr + throwError $ "openConnection failed" <> reason + pure conn where - getFd conn = do - fd <- c_PQsocket conn - when (fd == -1) $ - throwError "invalid file descriptor" - return fd - throwError :: String -> IO a throwError = hpqTypesError . (fname ++) . (": " ++) diff --git a/src/Database/PostgreSQL/PQTypes/Interval.hs b/src/Database/PostgreSQL/PQTypes/Interval.hs deleted file mode 100644 --- a/src/Database/PostgreSQL/PQTypes/Interval.hs +++ /dev/null @@ -1,153 +0,0 @@ -{-# LINE 1 "src/Database/PostgreSQL/PQTypes/Interval.hsc" #-} -module Database.PostgreSQL.PQTypes.Interval ( - Interval(..) - , iyears - , imonths - , idays - , ihours - , iminutes - , iseconds - , imicroseconds - ) where - -import Data.Int -import Data.List -import Foreign.Storable -import qualified Data.ByteString.Char8 as BS -import qualified Data.Semigroup as SG - -import Database.PostgreSQL.PQTypes.Format -import Database.PostgreSQL.PQTypes.FromSQL -import Database.PostgreSQL.PQTypes.Internal.Utils -import Database.PostgreSQL.PQTypes.ToSQL - - - ----------------------------------------- - --- | Representation of INTERVAL PostgreSQL type. -data Interval = Interval - { intYears :: !Int32 - , intMonths :: !Int32 - , intDays :: !Int32 - , intHours :: !Int32 - , intMinutes :: !Int32 - , intSeconds :: !Int32 - , intMicroseconds :: !Int32 - } deriving (Eq, Ord) - -instance Show Interval where - showsPrec _ Interval{..} = (++) . intercalate ", " $ filter (not . null) [ - f intYears "year" - , f intMonths "month" - , f intDays "day" - , f intHours "hour" - , f intMinutes "minute" - , f intSeconds "second" - , f intMicroseconds "microsecond" - ] - where - f n desc = case n of - 0 -> "" - 1 -> show n ++ " " ++ desc - _ -> show n ++ " " ++ desc ++ "s" - -instance SG.Semigroup Interval where - a <> b = Interval { - intYears = intYears a + intYears b - , intMonths = intMonths a + intMonths b - , intDays = intDays a + intDays b - , intHours = intHours a + intHours b - , intMinutes = intMinutes a + intMinutes b - , intSeconds = intSeconds a + intSeconds b - , intMicroseconds = intMicroseconds a + intMicroseconds b - } - -instance Monoid Interval where - mempty = Interval 0 0 0 0 0 0 0 - mappend = (SG.<>) - -instance Storable Interval where - sizeOf _ = (28) -{-# LINE 71 "src/Database/PostgreSQL/PQTypes/Interval.hsc" #-} - alignment _ = 4 -{-# LINE 72 "src/Database/PostgreSQL/PQTypes/Interval.hsc" #-} - peek ptr = Interval - <$> (\hsc_ptr -> peekByteOff hsc_ptr 0) ptr -{-# LINE 74 "src/Database/PostgreSQL/PQTypes/Interval.hsc" #-} - <*> (\hsc_ptr -> peekByteOff hsc_ptr 4) ptr -{-# LINE 75 "src/Database/PostgreSQL/PQTypes/Interval.hsc" #-} - <*> (\hsc_ptr -> peekByteOff hsc_ptr 8) ptr -{-# LINE 76 "src/Database/PostgreSQL/PQTypes/Interval.hsc" #-} - <*> (\hsc_ptr -> peekByteOff hsc_ptr 12) ptr -{-# LINE 77 "src/Database/PostgreSQL/PQTypes/Interval.hsc" #-} - <*> (\hsc_ptr -> peekByteOff hsc_ptr 16) ptr -{-# LINE 78 "src/Database/PostgreSQL/PQTypes/Interval.hsc" #-} - <*> (\hsc_ptr -> peekByteOff hsc_ptr 20) ptr -{-# LINE 79 "src/Database/PostgreSQL/PQTypes/Interval.hsc" #-} - <*> (\hsc_ptr -> peekByteOff hsc_ptr 24) ptr -{-# LINE 80 "src/Database/PostgreSQL/PQTypes/Interval.hsc" #-} - poke ptr Interval{..} = do - (\hsc_ptr -> pokeByteOff hsc_ptr 0) ptr intYears -{-# LINE 82 "src/Database/PostgreSQL/PQTypes/Interval.hsc" #-} - (\hsc_ptr -> pokeByteOff hsc_ptr 4) ptr intMonths -{-# LINE 83 "src/Database/PostgreSQL/PQTypes/Interval.hsc" #-} - (\hsc_ptr -> pokeByteOff hsc_ptr 8) ptr intDays -{-# LINE 84 "src/Database/PostgreSQL/PQTypes/Interval.hsc" #-} - (\hsc_ptr -> pokeByteOff hsc_ptr 12) ptr intHours -{-# LINE 85 "src/Database/PostgreSQL/PQTypes/Interval.hsc" #-} - (\hsc_ptr -> pokeByteOff hsc_ptr 16) ptr intMinutes -{-# LINE 86 "src/Database/PostgreSQL/PQTypes/Interval.hsc" #-} - (\hsc_ptr -> pokeByteOff hsc_ptr 20) ptr intSeconds -{-# LINE 87 "src/Database/PostgreSQL/PQTypes/Interval.hsc" #-} - (\hsc_ptr -> pokeByteOff hsc_ptr 24) ptr intMicroseconds -{-# LINE 88 "src/Database/PostgreSQL/PQTypes/Interval.hsc" #-} - -instance PQFormat Interval where - pqFormat = BS.pack "%interval" - -instance FromSQL Interval where - type PQBase Interval = Interval - fromSQL Nothing = unexpectedNULL - fromSQL (Just int) = return int - -instance ToSQL Interval where - type PQDest Interval = Interval - toSQL int _ = putAsPtr int - ----------------------------------------- - --- | Convert 'Int32' to appropriate 'Interval' --- representation of given number of years. -iyears :: Int32 -> Interval -iyears v = mempty { intYears = v } - --- | Convert 'Int32' to appropriate 'Interval' --- representation of given number of months. -imonths :: Int32 -> Interval -imonths v = mempty { intMonths = v } - --- | Convert 'Int32' to appropriate 'Interval' --- representation of given number of days. -idays :: Int32 -> Interval -idays v = mempty { intDays = v } - --- | Convert 'Int32' to appropriate 'Interval' --- representation of given number of hours. -ihours :: Int32 -> Interval -ihours v = mempty { intHours = v } - --- | Convert 'Int32' to appropriate 'Interval' --- representation of given number of minutes. -iminutes :: Int32 -> Interval -iminutes v = mempty { intMinutes = v } - --- | Convert 'Int32' to appropriate 'Interval' --- representation of given number of seconds. -iseconds :: Int32 -> Interval -iseconds v = mempty { intSeconds = v } - --- | Convert 'Int32' to appropriate 'Interval' --- representation of given number of microseconds. -imicroseconds :: Int32 -> Interval -imicroseconds v = mempty { intMicroseconds = v }