nikita-volkov/hasql
1
1
Fork 0
mirror of https://github.com/nikita-volkov/hasql.git synced 2024-11-22 01:52:45 +03:00
Code Issues Projects Releases Wiki Activity

Revise errors

Browse Source
This commit is contained in:
Nikita Volkov 2024-04-21 16:15:51 +03:00
parent d88476e2a9
commit 5e8147b737
11 changed files with 143 additions and 133 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
hasql.cabal
View File

@ -63,6 +63,7 @@ common base
RoleAnnotations
ScopedTypeVariables
StandaloneDeriving
StrictData
TemplateHaskell
TupleSections
TypeFamilies

2
library/Hasql/Decoders/All.hs
View File

@ -38,7 +38,7 @@ rowsAffected = Result (Results.single Result.rowsAffected)
-- |
-- Exactly one row.
-- Will raise the 'Errors.UnexpectedAmountOfRows' error if it's any other.
-- Will raise the 'Errors.UnexpectedAmountOfRowsResultError' error if it's any other.
{-# INLINEABLE singleRow #-}
singleRow :: Row a -> Result a
singleRow (Row row) = Result (Results.single (Result.single row))

26
library/Hasql/Decoders/Result.hs
View File

@ -45,13 +45,13 @@ rowsAffected =
notNothing >=> notEmpty >=> decimal
where
notNothing =
Prelude.maybe (Left (UnexpectedResult "No bytes")) Right
Prelude.maybe (Left (UnexpectedResultError "No bytes")) Right
notEmpty bytes =
if ByteString.null bytes
then Left (UnexpectedResult "Empty bytes")
then Left (UnexpectedResultError "Empty bytes")
else Right bytes
decimal bytes =
mapLeft (\m -> UnexpectedResult ("Decimal parsing failure: " <> fromString m))
mapLeft (\m -> UnexpectedResultError ("Decimal parsing failure: " <> fromString m))
$ Attoparsec.parseOnly (Attoparsec.decimal <* Attoparsec.endOfInput) bytes
{-# INLINE checkExecStatus #-}
@ -70,7 +70,7 @@ checkExecStatus expectedList =
unexpectedResult :: Text -> Result a
unexpectedResult =
Result . lift . ExceptT . pure . Left . UnexpectedResult
Result . lift . ExceptT . pure . Left . UnexpectedResultError
{-# INLINE serverError #-}
serverError :: Result ()
@ -90,7 +90,7 @@ serverError =
LibPQ.resultErrorField result LibPQ.DiagMessageHint
position <-
parsePosition <$> LibPQ.resultErrorField result LibPQ.DiagStatementPosition
pure $ Left $ ServerError code message detail hint position
pure $ Left $ ServerResultError code message detail hint position
where
parsePosition = \case
Nothing -> Nothing
@ -112,9 +112,8 @@ maybe rowDec =
0 -> return (Right Nothing)
1 -> do
maxCols <- LibPQ.nfields result
let fromRowError (col, err) = RowError 0 col err
fmap (fmap Just . mapLeft fromRowError) $ Row.run rowDec (result, 0, maxCols, integerDatetimes)
_ -> return (Left (UnexpectedAmountOfRows (rowToInt maxRows)))
fmap (fmap Just . mapLeft (RowResultError 0)) $ Row.run rowDec (result, 0, maxCols, integerDatetimes)
_ -> return (Left (UnexpectedAmountOfRowsResultError (rowToInt maxRows)))
where
rowToInt (LibPQ.Row n) =
fromIntegral n
@ -131,9 +130,8 @@ single rowDec =
case maxRows of
1 -> do
maxCols <- LibPQ.nfields result
let fromRowError (col, err) = RowError 0 col err
fmap (mapLeft fromRowError) $ Row.run rowDec (result, 0, maxCols, integerDatetimes)
_ -> return (Left (UnexpectedAmountOfRows (rowToInt maxRows)))
fmap (mapLeft (RowResultError 0)) $ Row.run rowDec (result, 0, maxCols, integerDatetimes)
_ -> return (Left (UnexpectedAmountOfRowsResultError (rowToInt maxRows)))
where
rowToInt (LibPQ.Row n) =
fromIntegral n
@ -153,7 +151,7 @@ vector rowDec =
forMFromZero_ (rowToInt maxRows) $ \rowIndex -> do
rowResult <- Row.run rowDec (result, intToRow rowIndex, maxCols, integerDatetimes)
case rowResult of
Left !(!colIndex, !x) -> writeIORef failureRef (Just (RowError rowIndex colIndex x))
Left !rowError -> writeIORef failureRef (Just (RowResultError rowIndex rowError))
Right !x -> MutableVector.unsafeWrite mvector rowIndex x
readIORef failureRef >>= \case
Nothing -> Right <$> Vector.unsafeFreeze mvector
@ -183,7 +181,7 @@ foldl step init rowDec =
forMFromZero_ (rowToInt maxRows) $ \rowIndex -> do
rowResult <- Row.run rowDec (result, intToRow rowIndex, maxCols, integerDatetimes)
case rowResult of
Left !(!colIndex, !x) -> writeIORef failureRef (Just (RowError rowIndex colIndex x))
Left !rowError -> writeIORef failureRef (Just (RowResultError rowIndex rowError))
Right !x -> modifyIORef' accRef (\acc -> step acc x)
readIORef failureRef >>= \case
Nothing -> Right <$> readIORef accRef
@ -210,7 +208,7 @@ foldr step init rowDec =
forMToZero_ (rowToInt maxRows) $ \rowIndex -> do
rowResult <- Row.run rowDec (result, intToRow rowIndex, maxCols, integerDatetimes)
case rowResult of
Left !(!colIndex, !x) -> writeIORef failureRef (Just (RowError rowIndex colIndex x))
Left !rowError -> writeIORef failureRef (Just (RowResultError rowIndex rowError))
Right !x -> modifyIORef accRef (\acc -> step x acc)
readIORef failureRef >>= \case
Nothing -> Right <$> readIORef accRef

16
library/Hasql/Decoders/Results.hs
View File

@ -17,11 +17,11 @@ import Hasql.Prelude hiding (many, maybe)
import Hasql.Prelude qualified as Prelude
newtype Results a
= Results (ReaderT (Bool, LibPQ.Connection) (ExceptT CommandError IO) a)
= Results (ReaderT (Bool, LibPQ.Connection) (ExceptT QueryError IO) a)
deriving (Functor, Applicative, Monad)
{-# INLINE run #-}
run :: Results a -> LibPQ.Connection -> Bool -> IO (Either CommandError a)
run :: Results a -> LibPQ.Connection -> Bool -> IO (Either QueryError a)
run (Results stack) conn idt =
runExceptT (runReaderT stack (idt, conn))
@ -32,7 +32,7 @@ clientError =
$ ReaderT
$ \(_, connection) ->
ExceptT
$ fmap (Left . ClientError) (LibPQ.errorMessage connection)
$ fmap (Left . ClientQueryError) (LibPQ.errorMessage connection)
-- |
-- Parse a single result.
@ -45,9 +45,9 @@ single resultDec =
resultMaybe <- LibPQ.getResult connection
case resultMaybe of
Just result ->
mapLeft ResultError <$> Result.run resultDec integerDatetimes result
mapLeft ResultQueryError <$> Result.run resultDec integerDatetimes result
Nothing ->
fmap (Left . ClientError) (LibPQ.errorMessage connection)
fmap (Left . ClientQueryError) (LibPQ.errorMessage connection)
-- |
-- Fetch a single result.
@ -60,7 +60,7 @@ getResult =
resultMaybe <- LibPQ.getResult connection
case resultMaybe of
Just result -> pure (Right result)
Nothing -> fmap (Left . ClientError) (LibPQ.errorMessage connection)
Nothing -> fmap (Left . ClientQueryError) (LibPQ.errorMessage connection)
-- |
-- Fetch a single result.
@ -84,11 +84,11 @@ dropRemainders =
loop integerDatetimes connection <* checkErrors
where
checkErrors =
ExceptT $ fmap (mapLeft ResultError) $ Result.run Result.noResult integerDatetimes result
ExceptT $ fmap (mapLeft ResultQueryError) $ Result.run Result.noResult integerDatetimes result
refine :: (a -> Either Text b) -> Results a -> Results b
refine refiner (Results stack) = Results
$ ReaderT
$ \env -> ExceptT $ do
resultEither <- runExceptT $ runReaderT stack env
return $ resultEither >>= mapLeft (ResultError . UnexpectedResult) . refiner
return $ resultEither >>= mapLeft (ResultQueryError . UnexpectedResultError) . refiner

16
library/Hasql/Decoders/Row.hs
View File

@ -7,11 +7,11 @@ import Hasql.Prelude hiding (error)
import PostgreSQL.Binary.Decoding qualified as A
newtype Row a
= Row (ReaderT Env (ExceptT RowError IO) a)
= Row (ReaderT Env (ExceptT ColumnError IO) a)
deriving (Functor, Applicative, Monad)
instance MonadFail Row where
fail = error . ValueError . fromString
fail = error . ValueColumnError . fromString
data Env
= Env !LibPQ.Result !LibPQ.Row !LibPQ.Column !Bool !(IORef LibPQ.Column)
@ -19,7 +19,7 @@ data Env
-- * Functions
{-# INLINE run #-}
run :: Row a -> (LibPQ.Result, LibPQ.Row, LibPQ.Column, Bool) -> IO (Either (Int, RowError) a)
run :: Row a -> (LibPQ.Result, LibPQ.Row, LibPQ.Column, Bool) -> IO (Either RowError a)
run (Row impl) (result, row, columnsAmount, integerDatetimes) =
do
columnRef <- newIORef 0
@ -27,11 +27,11 @@ run (Row impl) (result, row, columnsAmount, integerDatetimes) =
Left e -> do
LibPQ.Col col <- readIORef columnRef
-- -1 because succ is applied before the error is returned
pure $ Left (fromIntegral col - 1, e)
pure $ Left (ColumnRowError (fromIntegral col - 1) e)
Right x -> pure $ Right x
{-# INLINE error #-}
error :: RowError -> Row a
error :: ColumnError -> Row a
error x =
Row (ReaderT (const (ExceptT (pure (Left x)))))
@ -55,9 +55,9 @@ value valueDec =
Right Nothing
Just value ->
fmap Just
$ mapLeft ValueError
$ mapLeft ValueColumnError
$ {-# SCC "decode" #-} A.valueParser (Value.run valueDec integerDatetimes) value
else pure (Left EndOfInput)
else pure (Left EndOfInputColumnError)
-- |
-- Next value, decoded using the provided value decoder.
@ -65,4 +65,4 @@ value valueDec =
nonNullValue :: Value.Value a -> Row a
nonNullValue valueDec =
{-# SCC "nonNullValue" #-}
value valueDec >>= maybe (error UnexpectedNull) pure
value valueDec >>= maybe (error UnexpectedNullColumnError) pure

187
library/Hasql/Errors.hs
View File

@ -1,13 +1,3 @@
-- |
-- An API for retrieval of multiple results.
-- Can be used to handle:
--
-- * A single result,
--
-- * Individual results of a multi-statement query
-- with the help of "Applicative" and "Monad",
--
-- * Row-by-row fetching.
module Hasql.Errors where
import Data.ByteString.Char8 qualified as BC
@ -18,90 +8,97 @@ data SessionError
= -- |
-- An error during the execution of a query.
-- Comes packed with the query template and a textual representation of the provided params.
QuerySessionError ByteString [Text] CommandError
QuerySessionError
-- | SQL template.
ByteString
-- | Parameters rendered as human-readable SQL literals.
[Text]
-- | Error details
QueryError
deriving (Show, Eq, Typeable)
instance Exception SessionError where
displayException (QuerySessionError query params commandError) =
let queryContext :: Maybe (ByteString, Int)
queryContext = case commandError of
ClientError _ -> Nothing
ResultError resultError -> case resultError of
ServerError _ message _ _ (Just position) -> Just (message, position)
_ -> Nothing
displayException = \case
QuerySessionError query params commandError ->
let queryContext :: Maybe (ByteString, Int)
queryContext = case commandError of
ClientQueryError _ -> Nothing
ResultQueryError resultError -> case resultError of
ServerResultError _ message _ _ (Just position) -> Just (message, position)
_ -> Nothing
-- find the line number and position of the error
findLineAndPos :: ByteString -> Int -> (Int, Int)
findLineAndPos byteString errorPos =
let (_, line, pos) =
BC.foldl'
( \(total, line, pos) c ->
case total + 1 of
0 -> (total, line, pos)
cursor
| cursor == errorPos -> (-1, line, pos + 1)
| c == '\n' -> (total + 1, line + 1, 0)
| otherwise -> (total + 1, line, pos + 1)
)
(0, 1, 0)
byteString
in (line, pos)
-- find the line number and position of the error
findLineAndPos :: ByteString -> Int -> (Int, Int)
findLineAndPos byteString errorPos =
let (_, line, pos) =
BC.foldl'
( \(total, line, pos) c ->
case total + 1 of
0 -> (total, line, pos)
cursor
| cursor == errorPos -> (-1, line, pos + 1)
| c == '\n' -> (total + 1, line + 1, 0)
| otherwise -> (total + 1, line, pos + 1)
)
(0, 1, 0)
byteString
in (line, pos)
formatErrorContext :: ByteString -> ByteString -> Int -> ByteString
formatErrorContext query message errorPos =
let lines = BC.lines query
(lineNum, linePos) = findLineAndPos query errorPos
in BC.unlines (take lineNum lines)
<> BC.replicate (linePos - 1) ' '
<> "^ "
<> message
formatErrorContext :: ByteString -> ByteString -> Int -> ByteString
formatErrorContext query message errorPos =
let lines = BC.lines query
(lineNum, linePos) = findLineAndPos query errorPos
in BC.unlines (take lineNum lines)
<> BC.replicate (linePos - 1) ' '
<> "^ "
<> message
prettyQuery :: ByteString
prettyQuery = case queryContext of
Nothing -> query
Just (message, pos) -> formatErrorContext query message pos
in "QuerySessionError!\n"
<> "\n Query:\n"
<> BC.unpack prettyQuery
<> "\n"
<> "\n Params: "
<> show params
<> "\n Error: "
<> case commandError of
ClientError (Just message) -> "Client error: " <> show message
ClientError Nothing -> "Unknown client error"
ResultError resultError -> case resultError of
ServerError code message details hint position ->
"Server error "
<> BC.unpack code
<> ": "
<> BC.unpack message
<> maybe "" (\d -> "\n Details: " <> BC.unpack d) details
<> maybe "" (\h -> "\n Hint: " <> BC.unpack h) hint
UnexpectedResult message -> "Unexpected result: " <> show message
RowError row column rowError ->
"Row error: " <> show row <> ":" <> show column <> " " <> show rowError
UnexpectedAmountOfRows amount ->
"Unexpected amount of rows: " <> show amount
prettyQuery :: ByteString
prettyQuery = case queryContext of
Nothing -> query
Just (message, pos) -> formatErrorContext query message pos
in "QuerySessionError!\n"
<> "\n Query:\n"
<> BC.unpack prettyQuery
<> "\n"
<> "\n Params: "
<> show params
<> "\n Error: "
<> case commandError of
ClientQueryError (Just message) -> "Client error: " <> show message
ClientQueryError Nothing -> "Client error without details"
ResultQueryError resultError -> case resultError of
ServerResultError code message details hint position ->
"Server error "
<> BC.unpack code
<> ": "
<> BC.unpack message
<> maybe "" (\d -> "\n Details: " <> BC.unpack d) details
<> maybe "" (\h -> "\n Hint: " <> BC.unpack h) hint
UnexpectedResultError message -> "Unexpected result: " <> show message
RowResultError row (ColumnRowError column rowError) ->
"Row error: " <> show row <> ":" <> show column <> " " <> show rowError
UnexpectedAmountOfRowsResultError amount ->
"Unexpected amount of rows: " <> show amount
-- |
-- An error of some command in the session.
data CommandError
data QueryError
= -- |
-- An error on the client-side,
-- with a message generated by the \"libpq\" library.
-- with a message generated by the \"libpq\" driver.
-- Usually indicates problems with connection.
ClientError (Maybe ByteString)
ClientQueryError (Maybe ByteString)
| -- |
-- Some error with a command result.
ResultError ResultError
ResultQueryError ResultError
deriving (Show, Eq)
-- |
-- An error with a command result.
data ResultError
= -- | An error reported by the DB.
ServerError
ServerResultError
-- | __Code__. The SQLSTATE code for the error. It's recommended to use
-- <http://hackage.haskell.org/package/postgresql-error-codes
-- the "postgresql-error-codes" package> to work with those.
@ -120,29 +117,43 @@ data ResultError
-- | __Position__. Error cursor position as an index into the original
-- statement string. Positions are measured in characters not bytes.
(Maybe Int)
| -- |
-- The database returned an unexpected result.
| -- | The database returned an unexpected result.
-- Indicates an improper statement or a schema mismatch.
UnexpectedResult Text
| -- |
-- An error of the row reader, preceded by the indexes of the row and column.
RowError Int Int RowError
| -- |
-- An unexpected amount of rows.
UnexpectedAmountOfRows Int
UnexpectedResultError
-- | Details.
Text
| -- | Error decoding a specific row.
RowResultError
-- | Row index.
Int
-- | Details.
RowError
| -- | Unexpected amount of rows.
UnexpectedAmountOfRowsResultError
-- | Actual amount of rows in the result.
Int
deriving (Show, Eq)
data RowError
= -- | Error at a specific column.
ColumnRowError
-- | Column index.
Int
-- | Error details.
ColumnError
deriving (Show, Eq)
-- |
-- An error during the decoding of a specific row.
data RowError
-- Error during the decoding of a specific column.
data ColumnError
= -- |
-- Appears on the attempt to parse more columns than there are in the result.
EndOfInput
EndOfInputColumnError
| -- |
-- Appears on the attempt to parse a @NULL@ as some value.
UnexpectedNull
UnexpectedNullColumnError
| -- |
-- Appears when a wrong value parser is used.
-- Comes with the error details.
ValueError Text
ValueColumnError Text
deriving (Show, Eq)

16
library/Hasql/IO.hs
View File

@ -56,7 +56,7 @@ initConnection c =
void $ LibPQ.exec c (Commands.asBytes (Commands.setEncodersToUTF8 <> Commands.setMinClientMessagesToWarning))
{-# INLINE getResults #-}
getResults :: LibPQ.Connection -> Bool -> ResultsDecoders.Results a -> IO (Either CommandError a)
getResults :: LibPQ.Connection -> Bool -> ResultsDecoders.Results a -> IO (Either QueryError a)
getResults connection integerDatetimes decoder =
{-# SCC "getResults" #-}
(<*) <$> get <*> dropRemainders
@ -72,7 +72,7 @@ getPreparedStatementKey ::
PreparedStatementRegistry.PreparedStatementRegistry ->
ByteString ->
[LibPQ.Oid] ->
IO (Either CommandError ByteString)
IO (Either QueryError ByteString)
getPreparedStatementKey connection registry template oidList =
{-# SCC "getPreparedStatementKey" #-}
PreparedStatementRegistry.update localKey onNewRemoteKey onOldRemoteKey registry
@ -96,10 +96,10 @@ getPreparedStatementKey connection registry template oidList =
pure (pure key)
{-# INLINE checkedSend #-}
checkedSend :: LibPQ.Connection -> IO Bool -> IO (Either CommandError ())
checkedSend :: LibPQ.Connection -> IO Bool -> IO (Either QueryError ())
checkedSend connection send =
send >>= \case
False -> fmap (Left . ClientError) $ LibPQ.errorMessage connection
False -> fmap (Left . ClientQueryError) $ LibPQ.errorMessage connection
True -> pure (Right ())
{-# INLINE sendPreparedParametricStatement #-}
@ -110,7 +110,7 @@ sendPreparedParametricStatement ::
ByteString ->
ParamsEncoders.Params a ->
a ->
IO (Either CommandError ())
IO (Either QueryError ())
sendPreparedParametricStatement connection registry integerDatetimes template encoder input =
runExceptT $ do
key <- ExceptT $ getPreparedStatementKey connection registry template oidList
@ -126,7 +126,7 @@ sendUnpreparedParametricStatement ::
ByteString ->
ParamsEncoders.Params a ->
a ->
IO (Either CommandError ())
IO (Either QueryError ())
sendUnpreparedParametricStatement connection integerDatetimes template encoder input =
checkedSend connection
$ LibPQ.sendQueryParams
@ -144,7 +144,7 @@ sendParametricStatement ::
ParamsEncoders.Params a ->
Bool ->
a ->
IO (Either CommandError ())
IO (Either QueryError ())
sendParametricStatement connection integerDatetimes registry template encoder prepared params =
{-# SCC "sendParametricStatement" #-}
if prepared
@ -152,6 +152,6 @@ sendParametricStatement connection integerDatetimes registry template encoder pr
else sendUnpreparedParametricStatement connection integerDatetimes template encoder params
{-# INLINE sendNonparametricStatement #-}
sendNonparametricStatement :: LibPQ.Connection -> ByteString -> IO (Either CommandError ())
sendNonparametricStatement :: LibPQ.Connection -> ByteString -> IO (Either QueryError ())
sendNonparametricStatement connection sql =
checkedSend connection $ LibPQ.sendQuery connection sql

6
library/Hasql/Pipeline/Core.hs
View File

@ -89,7 +89,7 @@ statement params (Statement.Statement sql (Encoders.Params encoder) (Decoders.Re
sent <- Pq.sendPrepare connection key sql (mfilter (not . null) (Just oidList))
if sent
then pure (True, Right (key, recv))
else (False,) . Left . commandToSessionError . ClientError <$> Pq.errorMessage connection
else (False,) . Left . commandToSessionError . ClientQueryError <$> Pq.errorMessage connection
where
recv =
fmap (mapLeft commandToSessionError)
@ -101,7 +101,7 @@ statement params (Statement.Statement sql (Encoders.Params encoder) (Decoders.Re
sendQuery key =
Pq.sendQueryPrepared connection key valueAndFormatList Pq.Binary >>= \case
False -> Left . commandToSessionError . ClientError <$> Pq.errorMessage connection
False -> Left . commandToSessionError . ClientQueryError <$> Pq.errorMessage connection
True -> pure (Right recv)
where
recv =
@ -112,7 +112,7 @@ statement params (Statement.Statement sql (Encoders.Params encoder) (Decoders.Re
runUnprepared =
Pq.sendQueryParams connection sql (Encoders.Params.compileUnpreparedStatementData encoder integerDatetimes params) Pq.Binary >>= \case
False -> Left . commandToSessionError . ClientError <$> Pq.errorMessage connection
False -> Left . commandToSessionError . ClientQueryError <$> Pq.errorMessage connection
True -> pure (Right recv)
where
recv =

2
library/Hasql/Statement.hs
View File

@ -75,7 +75,7 @@ instance Profunctor Statement where
-- |
-- Refine the result of a statement,
-- causing the running session to fail with the `UnexpectedResult` error in case of a refinement failure.
-- causing the running session to fail with the `UnexpectedResultError` error in case of a refinement failure.
--
-- This function is especially useful for refining the results of statements produced with
-- <http://hackage.haskell.org/package/hasql-th the \"hasql-th\" library>.

2
tasty/Main.hs
View File

@ -218,7 +218,7 @@ tree =
where
resultTest =
\case
Right (Left (Session.QuerySessionError _ _ (Session.ResultError (Session.ServerError "26000" _ _ _ _)))) -> False
Right (Left (Session.QuerySessionError _ _ (Session.ResultQueryError (Session.ServerResultError "26000" _ _ _ _)))) -> False
_ -> True
session =
catchError session (const (pure ())) *> session

2
testing-utils/Hasql/TestingUtils/TestingDsl.hs
View File

@ -2,7 +2,7 @@ module Hasql.TestingUtils.TestingDsl
( Session.Session,
Error (..),
Session.SessionError (..),
Session.CommandError (..),
Session.QueryError (..),
Pipeline.Pipeline,
Statement.Statement (..),
runSessionOnLocalDb,