Attach CallStack to DBException

CHANGELOG.md

@@ -1,3 +1,6 @@
+# hpqtypes-1.12.0.0 (????-??-??)
+* Attach `CallStack` to `DBException`.
+
 # hpqtypes-1.11.1.2 (2023-11-08)
 * Support multihost setups and the `connect_timeout` parameter in the connection
   string.

hpqtypes.cabal

@@ -1,5 +1,5 @@
 name:                hpqtypes
-version:             1.11.1.2
+version:             1.12.0.0
 synopsis:            Haskell bindings to libpqtypes
 
 description:         Efficient and easy-to-use bindings to (slightly modified)

src/Database/PostgreSQL/PQTypes/Class.hs

@@ -5,6 +5,7 @@ module Database.PostgreSQL.PQTypes.Class
 
 import Control.Monad.Trans
 import Control.Monad.Trans.Control
+import GHC.Stack
 
 import Database.PostgreSQL.PQTypes.FromRow
 import Database.PostgreSQL.PQTypes.Internal.Connection
@@ -18,18 +19,18 @@ class (Applicative m, Monad m) => MonadDB m where
   -- for a given connection, only one thread may be executing 'runQuery' at
   -- a given time. If simultaneous call is made from another thread, it
   -- will block until currently running 'runQuery' finishes.
-  runQuery :: IsSQL sql => sql -> m Int
+  runQuery :: (HasCallStack, IsSQL sql) => sql -> m Int
   -- | Similar to 'runQuery', but it prepares and executes a statement under a
   -- given name.
-  runPreparedQuery :: IsSQL sql => QueryName -> sql -> m Int
+  runPreparedQuery :: (HasCallStack, IsSQL sql) => QueryName -> sql -> m Int
   -- | Get last SQL query that was executed.
   getLastQuery :: m SomeSQL
   -- | Subsequent queries in the callback do not alter the result of
   -- 'getLastQuery'.
   withFrozenLastQuery :: m a -> m a
 
   -- | Get current connection statistics.
-  getConnectionStats :: m ConnectionStats
+  getConnectionStats :: HasCallStack => m ConnectionStats
 
   -- | Get current query result.
   getQueryResult :: FromRow row => m (Maybe (QueryResult row))
@@ -76,11 +77,11 @@ instance {-# OVERLAPPABLE #-}
   , MonadTransControl t
   , MonadDB m
   ) => MonadDB (t m) where
-    runQuery = lift . runQuery
-    runPreparedQuery name = lift . runPreparedQuery name
+    runQuery = withFrozenCallStack $ lift . runQuery
+    runPreparedQuery name = withFrozenCallStack $ lift . runPreparedQuery name
     getLastQuery = lift getLastQuery
     withFrozenLastQuery m = controlT $ \run -> withFrozenLastQuery (run m)
-    getConnectionStats = lift getConnectionStats
+    getConnectionStats = withFrozenCallStack $ lift getConnectionStats
     getQueryResult = lift getQueryResult
     clearQueryResult = lift clearQueryResult
     getTransactionSettings = lift getTransactionSettings

src/Database/PostgreSQL/PQTypes/Cursor.hs

@@ -17,6 +17,7 @@ module Database.PostgreSQL.PQTypes.Cursor
 import Control.Monad
 import Control.Monad.Catch
 import Data.String
+import GHC.Stack
 
 import Data.Monoid.Utils
 import Database.PostgreSQL.PQTypes.Class
@@ -98,7 +99,7 @@ cursorQuery (Cursor _ query) = query
 
 -- | Create a cursor from the SQL query and use it within the given context.
 withCursor
-  :: (IsString sql, IsSQL sql, Monoid sql, MonadDB m, MonadMask m)
+  :: (HasCallStack, IsString sql, IsSQL sql, Monoid sql, MonadDB m, MonadMask m)
   => CursorName sql
   -> Scroll
   -> Hold
@@ -149,7 +150,7 @@ withCursorSQL = withCursor
 -- | Retrieve rows from a query using a cursor. See
 -- https://www.postgresql.org/docs/current/sql-fetch.html for more information.
 cursorFetch
-  :: (IsSQL sql, IsString sql, Monoid sql, MonadDB m)
+  :: (HasCallStack, IsSQL sql, IsString sql, Monoid sql, MonadDB m)
   => Cursor sql
   -> CursorDirection
   -> m Int
@@ -172,7 +173,7 @@ cursorFetch_ cursor = void . cursorFetch cursor
 -- except it only positions the cursor and does not return rows. See
 -- https://www.postgresql.org/docs/current/sql-move.html for more information.
 cursorMove
-  :: (IsSQL sql, IsString sql, Monoid sql, MonadDB m)
+  :: (HasCallStack, IsSQL sql, IsString sql, Monoid sql, MonadDB m)
   => Cursor sql
   -> CursorDirection
   -> m Int

src/Database/PostgreSQL/PQTypes/Fold.hs

@@ -9,7 +9,7 @@ module Database.PostgreSQL.PQTypes.Fold (
   ) where
 
 import Control.Monad.Catch
-import qualified Data.Foldable as F
+import GHC.Stack
 
 import Database.PostgreSQL.PQTypes.Class
 import Database.PostgreSQL.PQTypes.FromRow
@@ -18,36 +18,56 @@ import Database.PostgreSQL.PQTypes.Internal.QueryResult
 import Database.PostgreSQL.PQTypes.Utils
 
 -- | Get current 'QueryResult' or throw an exception if there isn't one.
-queryResult :: (MonadDB m, MonadThrow m, FromRow row) => m (QueryResult row)
-queryResult = getQueryResult
+queryResult
+  :: (HasCallStack, MonadDB m, MonadThrow m, FromRow row)
+  => m (QueryResult row)
+queryResult = withFrozenCallStack $ getQueryResult
   >>= maybe (throwDB . HPQTypesError $ "queryResult: no query result") return
 
 ----------------------------------------
 
--- | Specialization of 'F.foldrM' for convenient query results fetching.
-foldrDB :: (MonadDB m, FromRow row) => (row -> acc -> m acc) -> acc -> m acc
-foldrDB f acc = maybe (return acc) (F.foldrM f acc) =<< getQueryResult
+-- | Fetcher of rows returned by a query as a monadic right fold.
+foldrDB
+  :: (HasCallStack, MonadDB m, FromRow row)
+  => (row -> acc -> m acc)
+  -> acc
+  -> m acc
+foldrDB f acc = withFrozenCallStack $ getQueryResult
+  >>= maybe (return acc) (foldrImpl False f acc)
 
--- | Specialization of 'F.foldlM' for convenient query results fetching.
-foldlDB :: (MonadDB m, FromRow row) => (acc -> row -> m acc) -> acc -> m acc
-foldlDB f acc = maybe (return acc) (F.foldlM f acc) =<< getQueryResult
+-- | Fetcher of rows returned by a query as a monadic left fold.
+foldlDB
+  :: (HasCallStack, MonadDB m, FromRow row)
+  => (acc -> row -> m acc)
+  -> acc
+  -> m acc
+foldlDB f acc = withFrozenCallStack $ getQueryResult
+  >>= maybe (return acc) (foldlImpl False f acc)
 
--- | Specialization of 'F.mapM_' for convenient mapping over query results.
-mapDB_ :: (MonadDB m, FromRow row) => (row -> m t) -> m ()
-mapDB_ f = maybe (return ()) (F.mapM_ f) =<< getQueryResult
+-- | Fetcher of rows returned by a query as a monadic map.
+mapDB_
+  :: (HasCallStack, MonadDB m, FromRow row)
+  => (row -> m r)
+  -> m ()
+mapDB_ f = withFrozenCallStack $ getQueryResult
+  >>= maybe (return ()) (foldlImpl False (\() row -> () <$ f row) ())
 
 ----------------------------------------
 
 -- | Specialization of 'foldrDB' that fetches a list of rows.
-fetchMany :: (MonadDB m, FromRow row) => (row -> t) -> m [t]
-fetchMany f = foldrDB (\row acc -> return $ f row : acc) []
+fetchMany :: (HasCallStack, MonadDB m, FromRow row) => (row -> t) -> m [t]
+fetchMany f = withFrozenCallStack $ 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.
-fetchMaybe :: (MonadDB m, MonadThrow m, FromRow row) => (row -> t) -> m (Maybe t)
-fetchMaybe f = getQueryResult >>= \mqr -> case mqr of
-  Nothing -> return Nothing
-  Just qr -> fst <$> foldlDB go (Nothing, f <$> qr)
+fetchMaybe
+  :: (HasCallStack, MonadDB m, MonadThrow m, FromRow row)
+  => (row -> t)
+  -> m (Maybe t)
+fetchMaybe f = withFrozenCallStack $ do
+  getQueryResult >>= \mqr -> case mqr of
+    Nothing -> return Nothing
+    Just qr -> fst <$> foldlDB go (Nothing, f <$> qr)
   where
     go (Nothing, qr) row = return (Just $ f row, qr)
     go (Just _, qr) _ = throwDB AffectedRowsMismatch {
@@ -57,8 +77,8 @@ fetchMaybe f = getQueryResult >>= \mqr -> case mqr of
 
 -- | Specialization of 'fetchMaybe' that fetches exactly one row. If
 -- no row is delivered, 'AffectedRowsMismatch' exception is thrown.
-fetchOne :: (MonadDB m, MonadThrow m, FromRow row) => (row -> t) -> m t
-fetchOne f = do
+fetchOne :: (HasCallStack, MonadDB m, MonadThrow m, FromRow row) => (row -> t) -> m t
+fetchOne f = withFrozenCallStack $ do
   mt <- fetchMaybe f
   case mt of
     Just t  -> return t

src/Database/PostgreSQL/PQTypes/Internal/Connection.hs

@@ -33,6 +33,7 @@ import Foreign.C.String
 import Foreign.ForeignPtr
 import Foreign.Ptr
 import GHC.Conc (closeFdWith)
+import GHC.Stack
 import qualified Control.Exception as E
 import qualified Data.ByteString.Char8 as BS
 import qualified Data.Foldable as F
@@ -274,7 +275,7 @@ disconnect (Connection mvconn) = modifyMVar_ mvconn $ \mconn -> do
 
 -- | Low-level function for running an SQL query.
 runQueryIO
-  :: IsSQL sql
+  :: (HasCallStack, IsSQL sql)
   => Connection
   -> sql
   -> IO (Int, ForeignPtr PGresult)
@@ -291,7 +292,7 @@ newtype QueryName = QueryName T.Text
 
 -- | Low-level function for running a prepared SQL query.
 runPreparedQueryIO
-  :: IsSQL sql
+  :: (HasCallStack, IsSQL sql)
   => Connection
   -> QueryName
   -> sql
@@ -302,6 +303,7 @@ runPreparedQueryIO conn (QueryName queryName) sql = do
       E.throwIO DBException
         { dbeQueryContext = sql
         , dbeError = HPQTypesError "runPreparedQueryIO: unnamed prepared query is not supported"
+        , dbeCallStack = callStack
         }
     let allocParam = ParamAllocator $ withPGparam cdPtr
     withSQL sql allocParam $ \param query -> do
@@ -319,7 +321,7 @@ runPreparedQueryIO conn (QueryName queryName) sql = do
 
 -- | Shared implementation of 'runQueryIO' and 'runPreparedQueryIO'.
 runQueryImpl
-  :: IsSQL sql
+  :: (HasCallStack, IsSQL sql)
   => String
   -> Connection
   -> sql
@@ -374,7 +376,12 @@ runQueryImpl fname conn sql execSql = do
   where
     withConnDo = withConnectionData conn fname
 
-verifyResult :: IsSQL sql => sql -> Ptr PGconn -> Ptr PGresult -> IO (Either Int Int)
+verifyResult
+  :: (HasCallStack, IsSQL sql)
+  => sql
+  -> Ptr PGconn
+  -> Ptr PGresult
+  -> IO (Either Int Int)
 verifyResult sql conn res = do
   -- works even if res is NULL
   rst <- c_PQresultStatus res
@@ -416,4 +423,5 @@ verifyResult sql conn res = do
       throwParseError sn = E.throwIO DBException {
         dbeQueryContext = sql
       , dbeError = HPQTypesError ("verifyResult: string returned by PQcmdTuples is not a valid number: " ++ show sn)
+      , dbeCallStack = callStack
       }

src/Database/PostgreSQL/PQTypes/Internal/Exception.hs

@@ -4,6 +4,7 @@ module Database.PostgreSQL.PQTypes.Internal.Exception (
   , rethrowWithContext
   ) where
 
+import GHC.Stack
 import qualified Control.Exception as E
 
 import Database.PostgreSQL.PQTypes.SQL.Class
@@ -15,15 +16,17 @@ data DBException = forall e sql. (E.Exception e, Show sql) => DBException
     dbeQueryContext :: !sql
     -- | Specific error.
   , dbeError        :: !e
+  , dbeCallStack    :: !CallStack
   }
 
 deriving instance Show DBException
 
 instance E.Exception DBException
 
 -- | Rethrow supplied exception enriched with given SQL.
-rethrowWithContext :: IsSQL sql => sql -> E.SomeException -> IO a
+rethrowWithContext :: (HasCallStack, IsSQL sql) => sql -> E.SomeException -> IO a
 rethrowWithContext sql (E.SomeException e) = E.throwIO DBException {
     dbeQueryContext = sql
   , dbeError = e
+  , dbeCallStack = callStack
   }

src/Database/PostgreSQL/PQTypes/Internal/Monad.hs

@@ -16,6 +16,7 @@ import Control.Monad.State.Strict
 import Control.Monad.Trans.Control
 import Control.Monad.Writer.Class
 import Data.Bifunctor
+import GHC.Stack
 import qualified Control.Monad.Trans.State.Strict as S
 import qualified Control.Monad.Fail as MF
 
@@ -42,7 +43,7 @@ type DBT m = DBT_ m m
 -- | Evaluate monadic action with supplied
 -- connection source and transaction settings.
 runDBT
-  :: (MonadBase IO m, MonadMask m)
+  :: (HasCallStack, MonadBase IO m, MonadMask m)
   => ConnectionSourceM m
   -> TransactionSettings
   -> DBT m a
@@ -72,9 +73,9 @@ mapDBT f g m = DBT . StateT $ g . runStateT (unDBT m) . f
 ----------------------------------------
 
 instance (m ~ n, MonadBase IO m, MonadMask m) => MonadDB (DBT_ m n) where
-  runQuery sql = DBT . StateT $ \st -> liftBase $ do
+  runQuery sql = withFrozenCallStack $ DBT . StateT $ \st -> liftBase $ do
     second (updateStateWith st sql) <$> runQueryIO (dbConnection st) sql
-  runPreparedQuery name sql = DBT . StateT $ \st -> liftBase $ do
+  runPreparedQuery name sql = withFrozenCallStack $ DBT . StateT $ \st -> liftBase $ do
     second (updateStateWith st sql) <$> runPreparedQueryIO (dbConnection st) name sql
 
   getLastQuery = DBT . gets $ dbLastQuery
@@ -84,7 +85,7 @@ instance (m ~ n, MonadBase IO m, MonadMask m) => MonadDB (DBT_ m n) where
     (x, st'') <- runStateT (unDBT callback) st'
     pure (x, st'' { dbRecordLastQuery = dbRecordLastQuery st })
 
-  getConnectionStats = do
+  getConnectionStats = withFrozenCallStack $ do
     mconn <- DBT $ liftBase . readMVar =<< gets (unConnection . dbConnection)
     case mconn of
       Nothing -> throwDB $ HPQTypesError "getConnectionStats: no connection"