hpqtypes 1.11.1.1 → 1.11.1.2

raw patch · 5 files changed

+46/−185 lines, 5 filesdep +stmPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: stm

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• hpqtypes.cabal +4/−2
• src/Database/PostgreSQL/PQTypes/Internal/C/Interface.hs +4/−9
• src/Database/PostgreSQL/PQTypes/Internal/Connection.hs +34/−21
• src/Database/PostgreSQL/PQTypes/Interval.hs +0/−153

@@ -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. 

@@ -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 

@@ -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"

@@ -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 ++) . (": " ++) 

@@ -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 }