hpqtypes 1.9.4.0 → 1.10.0.0

raw patch · 14 files changed

+47/−118 lines, 14 filesdep ~resource-poolPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: resource-pool

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• hpqtypes.cabal +6/−6
• src/Data/Monoid/Utils.hs +0/−5
• src/Database/PostgreSQL/PQTypes/Class.hs +0/−11
• src/Database/PostgreSQL/PQTypes/Fold.hs +0/−7
• src/Database/PostgreSQL/PQTypes/Internal/Connection.hs +22/−22
• src/Database/PostgreSQL/PQTypes/Internal/Error.hs +8/−2
• src/Database/PostgreSQL/PQTypes/Internal/Monad.hs +0/−30
• src/Database/PostgreSQL/PQTypes/Notification.hs +0/−4
• src/Database/PostgreSQL/PQTypes/Transaction.hs +0/−9
• src/Database/PostgreSQL/PQTypes/Utils.hs +0/−15
• test/Main.hs +2/−3
• test/Prelude/Instances.hs +1/−3
• test/Test/QuickCheck/Arbitrary/Instances.hs +1/−1

@@ -1,3 +1,10 @@+# hpqtypes-1.10.0.0 (2022-09-14)+* Improve `Show` instances of `HPQTypesError` and `LibPQError`.+* Remove `INLINE` and `INLINABLE` pragmas.+* Fix a rare bug in the `connect` function related to file descriptors.+* Add support for GHC 9.4.+* Require `resource-pool >= 0.3` (changes type signature of `poolSource`).+ # hpqtypes-1.9.4.0 (2022-05-18) * Add support for prepared statements. * Make more foreign C calls safe.

@@ -1,5 +1,5 @@ name:                hpqtypes-version:             1.9.4.0+version:             1.10.0.0 synopsis:            Haskell bindings to libpqtypes  description:         Efficient and easy-to-use bindings to (slightly modified)@@ -39,7 +39,7 @@ category:            Database build-type:          Custom cabal-version:       1.24-tested-with:         GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.2+tested-with:         GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.4 || ==9.4.2   extra-source-files: README.md@@ -71,7 +71,7 @@  custom-setup   setup-depends: base  >= 4.13 && < 5,-                 Cabal >= 1.24 && < 3.7,+                 Cabal >= 1.24 && < 3.9,                  directory,                  filepath @@ -132,9 +132,9 @@                      , time              >= 1.4                      , vector            >= 0.10                      , transformers-base >= 0.4-                     , monad-control     >= 0.3+                     , monad-control     >= 1.0.3                      , lifted-base       >= 0.2-                     , resource-pool     >= 0.2+                     , resource-pool     >= 0.3                      , mtl               >= 2.1                      , transformers      >= 0.2.2                      , containers        >= 0.5.0.0@@ -215,7 +215,7 @@                      , bytestring >= 0.9                      , exceptions >= 0.6                      , lifted-base >= 0.2-                     , monad-control >= 1.0+                     , monad-control >= 1.0.3                      , mtl >= 2.1                      , random >= 1.0                      , scientific

@@ -10,27 +10,22 @@ import Data.String  -- | Generalization of 'intercalate' to arbitrary 'Monoid'.-{-# INLINE mintercalate #-} mintercalate :: Monoid m => m -> [m] -> m mintercalate m = mconcat . intersperse m  -- | Generalization of separator to arbitrary 'Monoid'.-{-# INLINE mspace #-} mspace :: (IsString m, Monoid m) => m mspace = fromString " "  -- | Concatenate two elements with separator between them.-{-# INLINE smappend #-} smappend :: (IsString m, Monoid m) => m -> m -> m smappend a b = mconcat [a, mspace, b]  -- | Concatenate a list of elements, inserting separators between them.-{-# INLINE smconcat #-} smconcat :: (IsString m, Monoid m) => [m] -> m smconcat = mintercalate mspace  -- | Infix version of 'smappend'.-{-# INLINE (<+>) #-} (<+>) :: (IsString m, Monoid m) => m -> m -> m (<+>) = smappend infixr 6 <+>

@@ -88,14 +88,3 @@     setTransactionSettings = lift . setTransactionSettings     getNotification = lift . getNotification     withNewConnection m = controlT $ \run -> withNewConnection (run m)-    {-# INLINE runQuery #-}-    {-# INLINE runPreparedQuery #-}-    {-# INLINE getLastQuery #-}-    {-# INLINE withFrozenLastQuery #-}-    {-# INLINE getConnectionStats #-}-    {-# INLINE getQueryResult #-}-    {-# INLINE clearQueryResult #-}-    {-# INLINE getTransactionSettings #-}-    {-# INLINE setTransactionSettings #-}-    {-# INLINE getNotification #-}-    {-# INLINE withNewConnection #-}

@@ -18,7 +18,6 @@ import Database.PostgreSQL.PQTypes.Utils  -- | Get current 'QueryResult' or throw an exception if there isn't one.-{-# INLINABLE queryResult #-} queryResult :: (MonadDB m, MonadThrow m, FromRow row) => m (QueryResult row) queryResult = getQueryResult   >>= maybe (throwDB . HPQTypesError $ "queryResult: no query result") return@@ -26,30 +25,25 @@ ----------------------------------------  -- | Specialization of 'F.foldrM' for convenient query results fetching.-{-# INLINABLE foldrDB #-} foldrDB :: (MonadDB m, FromRow row) => (row -> acc -> m acc) -> acc -> m acc foldrDB f acc = maybe (return acc) (F.foldrM f acc) =<< getQueryResult  -- | Specialization of 'F.foldlM' for convenient query results fetching.-{-# INLINABLE foldlDB #-} foldlDB :: (MonadDB m, FromRow row) => (acc -> row -> m acc) -> acc -> m acc foldlDB f acc = maybe (return acc) (F.foldlM f acc) =<< getQueryResult  -- | Specialization of 'F.mapM_' for convenient mapping over query results.-{-# INLINABLE mapDB_ #-} mapDB_ :: (MonadDB m, FromRow row) => (row -> m t) -> m () mapDB_ f = maybe (return ()) (F.mapM_ f) =<< getQueryResult  ----------------------------------------  -- | Specialization of 'foldrDB' that fetches a list of rows.-{-# INLINABLE fetchMany #-} fetchMany :: (MonadDB m, FromRow row) => (row -> t) -> m [t] fetchMany f = foldrDB (\row acc -> return $ f row : acc) []  -- | Specialization of 'foldlDB' that fetches one or zero rows. If -- more rows are delivered, 'AffectedRowsMismatch' exception is thrown.-{-# INLINABLE fetchMaybe #-} fetchMaybe :: (MonadDB m, MonadThrow m, FromRow row) => (row -> t) -> m (Maybe t) fetchMaybe f = getQueryResult >>= \mqr -> case mqr of   Nothing -> return Nothing@@ -63,7 +57,6 @@  -- | Specialization of 'fetchMaybe' that fetches exactly one row. If -- no row is delivered, 'AffectedRowsMismatch' exception is thrown.-{-# INLINABLE fetchOne #-} fetchOne :: (MonadDB m, MonadThrow m, FromRow row) => (row -> t) -> m t fetchOne f = do   mt <- fetchMaybe f

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} module Database.PostgreSQL.PQTypes.Internal.Connection (     Connection(..)   , ConnectionData(..)@@ -23,7 +22,6 @@ import Data.IORef import Data.Kind import Data.Pool-import Data.Time.Clock import Foreign.C.String import Foreign.Ptr import GHC.Conc (closeFdWith)@@ -135,28 +133,31 @@   withConnection = bracket (liftBase $ connect cs) (liftBase . disconnect) } --- | Pooled source. It uses striped pool from resource-pool--- package to cache established connections and reuse them.+-- | Pooled source. It uses striped pool from @resource-pool@ package to cache+-- established connections and reuse them. poolSource   :: ConnectionSettings-  -> Int -- ^ Stripe count. The number of distinct sub-pools-  -- to maintain. The smallest acceptable value is 1.-  -> NominalDiffTime -- ^ Amount of time for which an unused database-  -- connection is kept open. The smallest acceptable value is 0.5-  -- seconds.+  -> Double+  -- ^ The amount of seconds for which an unused database connection is kept+  -- open. The smallest acceptable value is 0.5 seconds.   ---  -- The elapsed time before closing database connection may be-  -- a little longer than requested, as the reaper thread wakes-  -- at 1-second intervals.-  -> Int -- ^ Maximum number of database connections to keep open-  -- per stripe. The smallest acceptable value is 1.+  -- /Note:/ the elapsed time before closing database connection may be a little+  -- longer than requested, as the reaper thread wakes at 1-second intervals.+  -> Int+  -- ^ The maximum number of database connections to keep open.   ---  -- Requests for database connections will block if this limit is-  -- reached on a single stripe, even if other stripes have idle-  -- connections available.+  -- /Note:/ for each stripe the number of resources is divided by the number of+  -- capabilities and rounded up. Therefore the pool might end up creating up to+  -- @N - 1@ resources more in total than specified, where @N@ is the number of+  -- capabilities.   -> IO (ConnectionSource [MonadBase IO, MonadMask])-poolSource cs numStripes idleTime maxResources = do-  pool <- createPool (connect cs) disconnect numStripes idleTime maxResources+poolSource cs idleTime maxResources = do+  pool <- newPool PoolConfig+    { createResource = connect cs+    , freeResource = disconnect+    , poolCacheTTL = idleTime+    , poolMaxResources = maxResources+    }   return $ ConnectionSource $ ConnectionSourceM {     withConnection = doWithConnection pool . (clearStats >=>)   }@@ -210,11 +211,10 @@       conn <- c_PQconnectStart conninfo       when (conn == nullPtr) $         throwError "PQconnectStart returned a null pointer"-      fd <- getFd conn       (`onException` c_PQfinish conn) . unmask $ fix $ \loop -> do         ps <- c_PQconnectPoll conn-        if | ps == c_PGRES_POLLING_READING -> threadWaitRead  fd >> loop-           | ps == c_PGRES_POLLING_WRITING -> threadWaitWrite fd >> loop+        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                     -> throwError "openConnection failed"       where

@@ -42,11 +42,17 @@  -- | Internal error in this library. newtype HPQTypesError = HPQTypesError String-  deriving (Eq, Ord, Show)+  deriving (Eq, Ord) +instance Show HPQTypesError where+  show (HPQTypesError s) = "HPQTypesError (PostgreSQL): " <> s+ -- | Internal error in libpq/libpqtypes library. newtype LibPQError = LibPQError String-  deriving (Eq, Ord, Show)+  deriving (Eq, Ord)++instance Show LibPQError where+  show (LibPQError s) = "LibPQError (PostgreSQL): " <> s  -- | Data conversion error. Since it's polymorphic in error type, -- it nicely reports arbitrarily nested conversion errors.

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} module Database.PostgreSQL.PQTypes.Internal.Monad (     DBT_(..)   , DBT@@ -41,7 +40,6 @@  -- | Evaluate monadic action with supplied -- connection source and transaction settings.-{-# INLINABLE runDBT #-} runDBT   :: (MonadBase IO m, MonadMask m)   => ConnectionSourceM m@@ -63,7 +61,6 @@       else m  -- | Transform the underlying monad.-{-# INLINABLE mapDBT #-} mapDBT   :: (DBState n -> DBState m)   -> (m (a, DBState m) -> n (b, DBState n))@@ -105,61 +102,34 @@     res <- runDBT cs ts m     return (res, st) -  {-# INLINABLE runQuery #-}-  {-# INLINABLE getLastQuery #-}-  {-# INLINABLE withFrozenLastQuery #-}-  {-# INLINABLE getConnectionStats #-}-  {-# INLINABLE getQueryResult #-}-  {-# INLINABLE clearQueryResult #-}-  {-# INLINABLE getTransactionSettings #-}-  {-# INLINABLE setTransactionSettings #-}-  {-# INLINABLE getNotification #-}-  {-# INLINABLE withNewConnection #-}- ----------------------------------------  instance MonadTransControl (DBT_ m) where   type StT (DBT_ m) a = StT (InnerDBT m) a   liftWith = defaultLiftWith DBT unDBT   restoreT = defaultRestoreT DBT-  {-# INLINE liftWith #-}-  {-# INLINE restoreT #-}  instance (m ~ n, MonadBaseControl b m) => MonadBaseControl b (DBT_ m n) where   type StM (DBT_ m n) a = ComposeSt (DBT_ m) m a   liftBaseWith = defaultLiftBaseWith   restoreM     = defaultRestoreM-  {-# INLINE liftBaseWith #-}-  {-# INLINE restoreM #-}  instance (m ~ n, MonadError e m) => MonadError e (DBT_ m n) where   throwError = lift . throwError   catchError m h = DBT $ S.liftCatch catchError (unDBT m) (unDBT . h)-  {-# INLINE throwError #-}-  {-# INLINE catchError #-}  instance (m ~ n, MonadReader r m) => MonadReader r (DBT_ m n) where   ask = lift ask   local f = mapDBT id (local f)   reader = lift . reader-  {-# INLINE ask #-}-  {-# INLINE local #-}-  {-# INLINE reader #-}  instance (m ~ n, MonadState s m) => MonadState s (DBT_ m n) where   get = lift get   put = lift . put   state = lift . state-  {-# INLINE get #-}-  {-# INLINE put #-}-  {-# INLINE state #-}  instance (m ~ n, MonadWriter w m) => MonadWriter w (DBT_ m n) where   writer = lift . writer   tell = lift . tell   listen = DBT . S.liftListen listen . unDBT   pass = DBT . S.liftPass pass . unDBT-  {-# INLINE writer #-}-  {-# INLINE tell #-}-  {-# INLINE listen #-}-  {-# INLINE pass #-}

@@ -16,22 +16,18 @@ import Database.PostgreSQL.PQTypes.Utils  -- | Start listening for notifications on a given channel.-{-# INLINABLE listen #-} listen :: MonadDB m => Channel -> m () listen (Channel chan) = runQuery_ $ "LISTEN" <+> chan  -- | Stop listening for notifications on a given channel.-{-# INLINABLE unlisten #-} unlisten :: MonadDB m => Channel -> m () unlisten (Channel chan) = runQuery_ $ "UNLISTEN" <+> chan  -- | Cancel all listener registrations for the current session.-{-# INLINABLE unlistenAll #-} unlistenAll :: MonadDB m => m () unlistenAll = runSQL_ "UNLISTEN *"  -- | Generate a notification on a given channel.-{-# INLINABLE notify #-} notify :: MonadDB m => Channel -> Text -> m () notify (Channel chan) payload = runQuery_   $ rawSQL "SELECT pg_notify($1, $2)" (unRawSQL chan, payload)

@@ -35,7 +35,6 @@ -- provides something like \"nested transaction\". -- -- See <http://www.postgresql.org/docs/current/static/sql-savepoint.html>-{-# INLINABLE withSavepoint #-} withSavepoint :: (MonadDB m, MonadMask m) => Savepoint -> m a -> m a withSavepoint (Savepoint savepoint) m = fst <$> generalBracket   (runQuery_ $ "SAVEPOINT" <+> savepoint)@@ -58,22 +57,18 @@ -- monadic action won't have any effect  on the final 'commit' -- / 'rollback' as settings that were in effect during the call -- to 'withTransaction' will be used.-{-# INLINABLE withTransaction #-} withTransaction :: (MonadDB m, MonadMask m) => m a -> m a withTransaction m = getTransactionSettings >>= flip withTransaction' m  -- | Begin transaction using current transaction settings.-{-# INLINABLE begin #-} begin :: MonadDB m => m () begin = getTransactionSettings >>= begin'  -- | Commit active transaction using current transaction settings.-{-# INLINABLE commit #-} commit :: MonadDB m => m () commit = getTransactionSettings >>= commit'  -- | Rollback active transaction using current transaction settings.-{-# INLINABLE rollback #-} rollback :: MonadDB m => m () rollback = getTransactionSettings >>= rollback' @@ -82,7 +77,6 @@ -- | Execute monadic action within a transaction using given transaction -- settings. Note that it won't work as expected if a transaction is already -- active (in such case 'withSavepoint' should be used instead).-{-# INLINABLE withTransaction' #-} withTransaction' :: (MonadDB m, MonadMask m)                  => TransactionSettings -> m a -> m a withTransaction' ts m = (`fix` 1) $ \loop n -> do@@ -115,7 +109,6 @@       guard $ f err n  -- | Begin transaction using given transaction settings.-{-# INLINABLE begin' #-} begin' :: MonadDB m => TransactionSettings -> m () begin' ts = runSQL_ . mintercalate " " $ ["BEGIN", isolationLevel, permissions]   where@@ -130,7 +123,6 @@       ReadWrite          -> "READ WRITE"  -- | Commit active transaction using given transaction settings.-{-# INLINABLE commit' #-} commit' :: MonadDB m => TransactionSettings -> m () commit' ts = do   runSQL_ "COMMIT"@@ -138,7 +130,6 @@     begin' ts  -- | Rollback active transaction using given transaction settings.-{-# INLINABLE rollback' #-} rollback' :: MonadDB m => TransactionSettings -> m () rollback' ts = do   runSQL_ "ROLLBACK"

@@ -32,7 +32,6 @@  -- | When given 'DBException', throw it immediately. Otherwise -- wrap it in 'DBException' with the current query context first.-{-# INLINABLE throwDB #-} throwDB :: (Exception e, MonadDB m, MonadThrow m) => e -> m a throwDB e = case fromException $ toException e of   Just (dbe::DBException) -> throwM dbe@@ -52,14 +51,12 @@ ----------------------------------------  -- | Specialization of 'runQuery' that discards the result.-{-# INLINABLE runQuery_ #-} runQuery_ :: (IsSQL sql, MonadDB m) => sql -> m () runQuery_ = void . runQuery  -- | Specialization of 'runQuery' that checks whether affected/returned -- number of rows is in range [0, 1] and returns appropriate 'Bool' value. -- Otherwise, 'AffectedRowsMismatch' exception is thrown.-{-# INLINABLE runQuery01 #-} runQuery01 :: (IsSQL sql, MonadDB m, MonadThrow m) => sql -> m Bool runQuery01 sql = do   n <- runQuery sql@@ -70,43 +67,36 @@   return $ n == 1  -- | Specialization of 'runQuery01' that discards the result.-{-# INLINABLE runQuery01_ #-} runQuery01_ :: (IsSQL sql, MonadDB m, MonadThrow m) => sql -> m () runQuery01_ = void . runQuery01  ----------------------------------------  -- | Specialization of 'runQuery' to 'SQL' type.-{-# INLINABLE runSQL #-} runSQL :: MonadDB m => SQL -> m Int runSQL = runQuery  -- | Specialization of 'runQuery_' to 'SQL' type.-{-# INLINABLE runSQL_ #-} runSQL_ :: MonadDB m => SQL -> m () runSQL_ = runQuery_  -- | Specialization of 'runQuery01' to 'SQL' type.-{-# INLINABLE runSQL01 #-} runSQL01 :: (MonadDB m, MonadThrow m) => SQL -> m Bool runSQL01 = runQuery01  -- | Specialization of 'runQuery01_' to 'SQL' type.-{-# INLINABLE runSQL01_ #-} runSQL01_ :: (MonadDB m, MonadThrow m) => SQL -> m () runSQL01_ = runQuery01_  ----------------------------------------  -- | Specialization of 'runPreparedQuery' that discards the result.-{-# INLINABLE runPreparedQuery_ #-} runPreparedQuery_ :: (IsSQL sql, MonadDB m) => QueryName -> sql -> m () runPreparedQuery_ name = void . runPreparedQuery name  -- | Specialization of 'runPreparedQuery' that checks whether affected/returned -- number of rows is in range [0, 1] and returns appropriate 'Bool' value. -- Otherwise, 'AffectedRowsMismatch' exception is thrown.-{-# INLINABLE runPreparedQuery01 #-} runPreparedQuery01 :: (IsSQL sql, MonadDB m, MonadThrow m) => QueryName -> sql -> m Bool runPreparedQuery01 name sql = do   n <- runPreparedQuery name sql@@ -117,28 +107,23 @@   return $ n == 1  -- | Specialization of 'runPreparedQuery01' that discards the result.-{-# INLINABLE runPreparedQuery01_ #-} runPreparedQuery01_ :: (IsSQL sql, MonadDB m, MonadThrow m) => QueryName -> sql -> m () runPreparedQuery01_ name = void . runPreparedQuery01 name  ----------------------------------------  -- | Specialization of 'runPreparedQuery' to 'SQL' type.-{-# INLINABLE runPreparedSQL #-} runPreparedSQL :: MonadDB m => QueryName -> SQL -> m Int runPreparedSQL = runPreparedQuery  -- | Specialization of 'runPreparedQuery_' to 'SQL' type.-{-# INLINABLE runPreparedSQL_ #-} runPreparedSQL_ :: MonadDB m => QueryName -> SQL -> m () runPreparedSQL_ = runPreparedQuery_  -- | Specialization of 'runPreparedQuery01' to 'SQL' type.-{-# INLINABLE runPreparedSQL01 #-} runPreparedSQL01 :: (MonadDB m, MonadThrow m) => QueryName -> SQL -> m Bool runPreparedSQL01 = runPreparedQuery01  -- | Specialization of 'runPreparedQuery01_' to 'SQL' type.-{-# INLINABLE runPreparedSQL01_ #-} runPreparedSQL01_ :: (MonadDB m, MonadThrow m) => QueryName -> SQL -> m () runPreparedSQL01_ = runPreparedQuery01_

@@ -1,6 +1,5 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE TypeApplications #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wno-orphans #-} module Main where  import Control.Concurrent.Lifted@@ -661,7 +660,7 @@    createStructures connSource   ConnectionSource connPool <--    poolSource (connSettings { csComposites = ["simple_", "nested_"] }) 1 30 16+    poolSource (connSettings { csComposites = ["simple_", "nested_"] }) 30 16   gen <- newQCGen   putStrLn $ "PRNG:" <+> show gen 

@@ -1,7 +1,5 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wno-orphans #-} module Prelude.Instances where--  deriving instance (     Eq a1, Eq a2, Eq a3, Eq a4, Eq a5, Eq a6, Eq a7, Eq a8, Eq a9, Eq a10

@@ -1,6 +1,6 @@-{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE CPP #-} {-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wno-orphans #-} module Test.QuickCheck.Arbitrary.Instances where  import Data.Aeson