Skip to content

Commit

Permalink
Attach CallStack to DBException (#68)
Browse files Browse the repository at this point in the history
* Attach CallStack to DBException

* Major version bump

* lazy callstack
arybczak authored Dec 18, 2023

Verified

This commit was created on GitHub.com and signed with GitHub’s verified signature. The key has expired.
1 parent 02156d6 commit 3a1ce54
Showing 12 changed files with 179 additions and 103 deletions.
3 changes: 3 additions & 0 deletions CHANGELOG.md
Original file line number Diff line number Diff line change
@@ -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.
2 changes: 1 addition & 1 deletion hpqtypes.cabal
Original file line number Diff line number Diff line change
@@ -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)
13 changes: 7 additions & 6 deletions src/Database/PostgreSQL/PQTypes/Class.hs
Original file line number Diff line number Diff line change
@@ -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
7 changes: 4 additions & 3 deletions src/Database/PostgreSQL/PQTypes/Cursor.hs
Original file line number Diff line number Diff line change
@@ -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
60 changes: 40 additions & 20 deletions src/Database/PostgreSQL/PQTypes/Fold.hs
Original file line number Diff line number Diff line change
@@ -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
16 changes: 12 additions & 4 deletions src/Database/PostgreSQL/PQTypes/Internal/Connection.hs
Original file line number Diff line number Diff line change
@@ -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
}
5 changes: 4 additions & 1 deletion src/Database/PostgreSQL/PQTypes/Internal/Exception.hs
Original file line number Diff line number Diff line change
@@ -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
}
9 changes: 5 additions & 4 deletions src/Database/PostgreSQL/PQTypes/Internal/Monad.hs
Original file line number Diff line number Diff line change
@@ -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"
Loading

0 comments on commit 3a1ce54

Please sign in to comment.