-- | Functions and datatypes for interpreting MSSQL database errors.
module Hasura.Backends.MSSQL.SQL.Error
  ( ErrorClass (..),
    defaultMSSQLTxErrorHandler,
    mutationMSSQLTxErrorHandler,
    mkMSSQLTxErrorHandler,

    -- * Exposed for testing
    ErrorSubclass (..),
    DataExceptionSubclass (..),
    SyntaxErrorOrAccessViolationSubclass (..),
    parseErrorClass,
  )
where

import Data.Aeson
import Data.Text qualified as T
import Database.MSSQL.Transaction
import Database.ODBC.SQLServer qualified as ODBC
import Hasura.Base.Error qualified as Error
import Hasura.Prelude

-- | The top-level error class. Errors in MSSQL are divided into different /classes/, which
-- are further subdivided into individual error subclasses. It is useful to determine the class of
-- database exception and handle it appropriately.
data ErrorClass
  = DataException (ErrorSubclass DataExceptionSubclass)
  | IntegrityConstraintViolation
  | SyntaxErrorOrAccessViolation (ErrorSubclass SyntaxErrorOrAccessViolationSubclass)
  deriving (ErrorClass -> ErrorClass -> Bool
(ErrorClass -> ErrorClass -> Bool)
-> (ErrorClass -> ErrorClass -> Bool) -> Eq ErrorClass
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ErrorClass -> ErrorClass -> Bool
== :: ErrorClass -> ErrorClass -> Bool
$c/= :: ErrorClass -> ErrorClass -> Bool
/= :: ErrorClass -> ErrorClass -> Bool
Eq)

instance Show ErrorClass where
  show :: ErrorClass -> String
show = \case
    DataException ErrorSubclass DataExceptionSubclass
subclass -> String -> ErrorSubclass DataExceptionSubclass -> String
forall a. Show a => String -> ErrorSubclass a -> String
withSubclass String
"Data exception." ErrorSubclass DataExceptionSubclass
subclass
    ErrorClass
IntegrityConstraintViolation -> String
"Integrity constraint violation."
    SyntaxErrorOrAccessViolation ErrorSubclass SyntaxErrorOrAccessViolationSubclass
subclass -> String
-> ErrorSubclass SyntaxErrorOrAccessViolationSubclass -> String
forall a. Show a => String -> ErrorSubclass a -> String
withSubclass String
"Syntax error or access violation." ErrorSubclass SyntaxErrorOrAccessViolationSubclass
subclass
    where
      withSubclass :: (Show a) => String -> ErrorSubclass a -> String
      withSubclass :: forall a. Show a => String -> ErrorSubclass a -> String
withSubclass String
classError = \case
        ErrorSubclass a
NoSubclass -> String
classError
        Subclass a
subclass -> String
classError String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
subclass

data ErrorSubclass a
  = -- | represents non-specific @000@ subclass code
    NoSubclass
  | -- | represents known, more specific sub class
    Subclass a
  deriving (ErrorSubclass a -> ErrorSubclass a -> Bool
(ErrorSubclass a -> ErrorSubclass a -> Bool)
-> (ErrorSubclass a -> ErrorSubclass a -> Bool)
-> Eq (ErrorSubclass a)
forall a. Eq a => ErrorSubclass a -> ErrorSubclass a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => ErrorSubclass a -> ErrorSubclass a -> Bool
== :: ErrorSubclass a -> ErrorSubclass a -> Bool
$c/= :: forall a. Eq a => ErrorSubclass a -> ErrorSubclass a -> Bool
/= :: ErrorSubclass a -> ErrorSubclass a -> Bool
Eq)

data DataExceptionSubclass
  = StringDataRightTruncated
  | NumericValueOutOfRange
  | InvalidDatetimeFormat
  | DatetimeFieldOverflow
  | IntervalFieldOverflow
  | InvalidEscapeCharacter
  | InvalidEscapeSequence
  deriving (DataExceptionSubclass -> DataExceptionSubclass -> Bool
(DataExceptionSubclass -> DataExceptionSubclass -> Bool)
-> (DataExceptionSubclass -> DataExceptionSubclass -> Bool)
-> Eq DataExceptionSubclass
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DataExceptionSubclass -> DataExceptionSubclass -> Bool
== :: DataExceptionSubclass -> DataExceptionSubclass -> Bool
$c/= :: DataExceptionSubclass -> DataExceptionSubclass -> Bool
/= :: DataExceptionSubclass -> DataExceptionSubclass -> Bool
Eq)

instance Show DataExceptionSubclass where
  show :: DataExceptionSubclass -> String
show = \case
    DataExceptionSubclass
StringDataRightTruncated -> String
"String data, right-truncated."
    DataExceptionSubclass
NumericValueOutOfRange -> String
"Numeric value out of range."
    DataExceptionSubclass
InvalidDatetimeFormat -> String
"Invalid datetime format."
    DataExceptionSubclass
DatetimeFieldOverflow -> String
"Datetime field overflow."
    DataExceptionSubclass
IntervalFieldOverflow -> String
"Interval field overflow."
    DataExceptionSubclass
InvalidEscapeCharacter -> String
"Invalid escape character."
    DataExceptionSubclass
InvalidEscapeSequence -> String
"Invalid escape sequence."

data SyntaxErrorOrAccessViolationSubclass
  = TableOrViewAlreadyExists
  | TableOrViewNotFound
  | IndexAlreadyExists
  | IndexNotFound
  | ColumnAlreadyExists
  | ColumnNotFound
  deriving (SyntaxErrorOrAccessViolationSubclass
-> SyntaxErrorOrAccessViolationSubclass -> Bool
(SyntaxErrorOrAccessViolationSubclass
 -> SyntaxErrorOrAccessViolationSubclass -> Bool)
-> (SyntaxErrorOrAccessViolationSubclass
    -> SyntaxErrorOrAccessViolationSubclass -> Bool)
-> Eq SyntaxErrorOrAccessViolationSubclass
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SyntaxErrorOrAccessViolationSubclass
-> SyntaxErrorOrAccessViolationSubclass -> Bool
== :: SyntaxErrorOrAccessViolationSubclass
-> SyntaxErrorOrAccessViolationSubclass -> Bool
$c/= :: SyntaxErrorOrAccessViolationSubclass
-> SyntaxErrorOrAccessViolationSubclass -> Bool
/= :: SyntaxErrorOrAccessViolationSubclass
-> SyntaxErrorOrAccessViolationSubclass -> Bool
Eq)

instance Show SyntaxErrorOrAccessViolationSubclass where
  show :: SyntaxErrorOrAccessViolationSubclass -> String
show = \case
    SyntaxErrorOrAccessViolationSubclass
TableOrViewAlreadyExists -> String
"Table or view already exists."
    SyntaxErrorOrAccessViolationSubclass
TableOrViewNotFound -> String
"Table or view not found."
    SyntaxErrorOrAccessViolationSubclass
IndexAlreadyExists -> String
"Index already exists."
    SyntaxErrorOrAccessViolationSubclass
IndexNotFound -> String
"Index not found."
    SyntaxErrorOrAccessViolationSubclass
ColumnAlreadyExists -> String
"Column already exists."
    SyntaxErrorOrAccessViolationSubclass
ColumnNotFound -> String
"Column not found."

-- | Assign each error class' subclasses an appropriate API error code
errorClassCode :: ErrorClass -> Error.Code
errorClassCode :: ErrorClass -> Code
errorClassCode = \case
  DataException ErrorSubclass DataExceptionSubclass
_ -> Code
Error.DataException
  ErrorClass
IntegrityConstraintViolation -> Code
Error.ConstraintViolation
  SyntaxErrorOrAccessViolation ErrorSubclass SyntaxErrorOrAccessViolationSubclass
NoSubclass -> Code
Error.BadRequest
  SyntaxErrorOrAccessViolation (Subclass SyntaxErrorOrAccessViolationSubclass
subclass) -> case SyntaxErrorOrAccessViolationSubclass
subclass of
    SyntaxErrorOrAccessViolationSubclass
TableOrViewAlreadyExists -> Code
Error.AlreadyExists
    SyntaxErrorOrAccessViolationSubclass
TableOrViewNotFound -> Code
Error.NotFound
    SyntaxErrorOrAccessViolationSubclass
IndexAlreadyExists -> Code
Error.AlreadyExists
    SyntaxErrorOrAccessViolationSubclass
IndexNotFound -> Code
Error.NotFound
    SyntaxErrorOrAccessViolationSubclass
ColumnAlreadyExists -> Code
Error.AlreadyExists
    SyntaxErrorOrAccessViolationSubclass
ColumnNotFound -> Code
Error.NotFound

-- | Parsing error class and subclass information from a SQLSTATE code.
-- SQLSTATE provides detailed information about the cause of a warning or error.
-- A SQLSTATE consists of 5 chars. They are divided into two parts: the first and
-- second chars contain a class and the following three a subclass.
parseErrorClass :: String -> Maybe ErrorClass
parseErrorClass :: String -> Maybe ErrorClass
parseErrorClass String
sqlStateCode =
  [Maybe ErrorClass] -> Maybe ErrorClass
forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice
    [ Text
-> (ErrorSubclass DataExceptionSubclass -> ErrorClass)
-> [Maybe (ErrorSubclass DataExceptionSubclass)]
-> Maybe ErrorClass
forall a.
Text
-> (ErrorSubclass a -> ErrorClass)
-> [Maybe (ErrorSubclass a)]
-> Maybe ErrorClass
withClass
        Text
"22"
        ErrorSubclass DataExceptionSubclass -> ErrorClass
DataException
        [ Text
-> DataExceptionSubclass
-> Maybe (ErrorSubclass DataExceptionSubclass)
forall a. Text -> a -> Maybe (ErrorSubclass a)
withSubclass Text
"001" DataExceptionSubclass
StringDataRightTruncated,
          Text
-> DataExceptionSubclass
-> Maybe (ErrorSubclass DataExceptionSubclass)
forall a. Text -> a -> Maybe (ErrorSubclass a)
withSubclass Text
"003" DataExceptionSubclass
NumericValueOutOfRange,
          Text
-> DataExceptionSubclass
-> Maybe (ErrorSubclass DataExceptionSubclass)
forall a. Text -> a -> Maybe (ErrorSubclass a)
withSubclass Text
"007" DataExceptionSubclass
InvalidDatetimeFormat,
          Text
-> DataExceptionSubclass
-> Maybe (ErrorSubclass DataExceptionSubclass)
forall a. Text -> a -> Maybe (ErrorSubclass a)
withSubclass Text
"008" DataExceptionSubclass
DatetimeFieldOverflow,
          Text
-> DataExceptionSubclass
-> Maybe (ErrorSubclass DataExceptionSubclass)
forall a. Text -> a -> Maybe (ErrorSubclass a)
withSubclass Text
"015" DataExceptionSubclass
IntervalFieldOverflow,
          Text
-> DataExceptionSubclass
-> Maybe (ErrorSubclass DataExceptionSubclass)
forall a. Text -> a -> Maybe (ErrorSubclass a)
withSubclass Text
"019" DataExceptionSubclass
InvalidEscapeCharacter,
          Text
-> DataExceptionSubclass
-> Maybe (ErrorSubclass DataExceptionSubclass)
forall a. Text -> a -> Maybe (ErrorSubclass a)
withSubclass Text
"025" DataExceptionSubclass
InvalidEscapeSequence
        ],
      Text
-> (ErrorSubclass Any -> ErrorClass)
-> [Maybe (ErrorSubclass Any)]
-> Maybe ErrorClass
forall a.
Text
-> (ErrorSubclass a -> ErrorClass)
-> [Maybe (ErrorSubclass a)]
-> Maybe ErrorClass
withClass Text
"23" (ErrorClass -> ErrorSubclass Any -> ErrorClass
forall a b. a -> b -> a
const ErrorClass
IntegrityConstraintViolation) [],
      Text
-> (ErrorSubclass SyntaxErrorOrAccessViolationSubclass
    -> ErrorClass)
-> [Maybe (ErrorSubclass SyntaxErrorOrAccessViolationSubclass)]
-> Maybe ErrorClass
forall a.
Text
-> (ErrorSubclass a -> ErrorClass)
-> [Maybe (ErrorSubclass a)]
-> Maybe ErrorClass
withClass
        Text
"42"
        ErrorSubclass SyntaxErrorOrAccessViolationSubclass -> ErrorClass
SyntaxErrorOrAccessViolation
        [ Text
-> SyntaxErrorOrAccessViolationSubclass
-> Maybe (ErrorSubclass SyntaxErrorOrAccessViolationSubclass)
forall a. Text -> a -> Maybe (ErrorSubclass a)
withSubclass Text
"S01" SyntaxErrorOrAccessViolationSubclass
TableOrViewAlreadyExists,
          Text
-> SyntaxErrorOrAccessViolationSubclass
-> Maybe (ErrorSubclass SyntaxErrorOrAccessViolationSubclass)
forall a. Text -> a -> Maybe (ErrorSubclass a)
withSubclass Text
"S02" SyntaxErrorOrAccessViolationSubclass
TableOrViewNotFound,
          Text
-> SyntaxErrorOrAccessViolationSubclass
-> Maybe (ErrorSubclass SyntaxErrorOrAccessViolationSubclass)
forall a. Text -> a -> Maybe (ErrorSubclass a)
withSubclass Text
"S11" SyntaxErrorOrAccessViolationSubclass
IndexAlreadyExists,
          Text
-> SyntaxErrorOrAccessViolationSubclass
-> Maybe (ErrorSubclass SyntaxErrorOrAccessViolationSubclass)
forall a. Text -> a -> Maybe (ErrorSubclass a)
withSubclass Text
"S12" SyntaxErrorOrAccessViolationSubclass
IndexNotFound,
          Text
-> SyntaxErrorOrAccessViolationSubclass
-> Maybe (ErrorSubclass SyntaxErrorOrAccessViolationSubclass)
forall a. Text -> a -> Maybe (ErrorSubclass a)
withSubclass Text
"S21" SyntaxErrorOrAccessViolationSubclass
ColumnAlreadyExists,
          Text
-> SyntaxErrorOrAccessViolationSubclass
-> Maybe (ErrorSubclass SyntaxErrorOrAccessViolationSubclass)
forall a. Text -> a -> Maybe (ErrorSubclass a)
withSubclass Text
"S22" SyntaxErrorOrAccessViolationSubclass
ColumnNotFound
        ]
    ]
  where
    (Text
classText, Text
subclassText) = Int -> Text -> (Text, Text)
T.splitAt Int
2 (Text -> (Text, Text)) -> Text -> (Text, Text)
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
sqlStateCode

    withClass ::
      Text ->
      (ErrorSubclass a -> ErrorClass) ->
      [Maybe (ErrorSubclass a)] ->
      Maybe ErrorClass
    withClass :: forall a.
Text
-> (ErrorSubclass a -> ErrorClass)
-> [Maybe (ErrorSubclass a)]
-> Maybe ErrorClass
withClass Text
expectedClassText ErrorSubclass a -> ErrorClass
mkClass [Maybe (ErrorSubclass a)]
subclasses = do
      Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Text
classText Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
expectedClassText)
      ErrorSubclass a -> ErrorClass
mkClass
        (ErrorSubclass a -> ErrorClass)
-> Maybe (ErrorSubclass a) -> Maybe ErrorClass
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> if Text
subclassText Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"000"
          then ErrorSubclass a -> Maybe (ErrorSubclass a)
forall a. a -> Maybe a
Just ErrorSubclass a
forall a. ErrorSubclass a
NoSubclass
          else [Maybe (ErrorSubclass a)] -> Maybe (ErrorSubclass a)
forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice [Maybe (ErrorSubclass a)]
subclasses

    withSubclass :: Text -> a -> Maybe (ErrorSubclass a)
    withSubclass :: forall a. Text -> a -> Maybe (ErrorSubclass a)
withSubclass Text
expectedSubclassText a
subclassValue =
      Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Text
subclassText Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
expectedSubclassText) Maybe () -> ErrorSubclass a -> Maybe (ErrorSubclass a)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> a -> ErrorSubclass a
forall a. a -> ErrorSubclass a
Subclass a
subclassValue

-- | A default transaction error handler where all errors are unexpected.
defaultMSSQLTxErrorHandler :: MSSQLTxError -> Error.QErr
defaultMSSQLTxErrorHandler :: MSSQLTxError -> QErr
defaultMSSQLTxErrorHandler = (ErrorClass -> Bool) -> MSSQLTxError -> QErr
mkMSSQLTxErrorHandler (Bool -> ErrorClass -> Bool
forall a b. a -> b -> a
const Bool
False)

-- | A transaction error handler to be used in constructing mutation transactions,
-- i.e INSERT, UPDATE and DELETE. We expect data exception and integrity constraint violation.
mutationMSSQLTxErrorHandler :: MSSQLTxError -> Error.QErr
mutationMSSQLTxErrorHandler :: MSSQLTxError -> QErr
mutationMSSQLTxErrorHandler = (ErrorClass -> Bool) -> MSSQLTxError -> QErr
mkMSSQLTxErrorHandler ((ErrorClass -> Bool) -> MSSQLTxError -> QErr)
-> (ErrorClass -> Bool) -> MSSQLTxError -> QErr
forall a b. (a -> b) -> a -> b
$ \case
  DataException ErrorSubclass DataExceptionSubclass
_ -> Bool
True
  ErrorClass
IntegrityConstraintViolation -> Bool
True
  SyntaxErrorOrAccessViolation ErrorSubclass SyntaxErrorOrAccessViolationSubclass
_ -> Bool
False

-- | Constructs a transaction error handler given a predicate that determines which error
-- classes (and subclasses) are expected and should be reported to the user. All other errors
-- are considered internal errors.
-- Example:-
--   Consider a insert mutation where we insert some data into columns of a table.
--   Except for the basic data type, such as Boolean, String, Float, Int etc.
--   we cannot invalidate data any further, such as validating timestamp string format.
--   In this case, a @'DataException' is expected from the database and it is handled and
--   thrown with proper error message.
mkMSSQLTxErrorHandler :: (ErrorClass -> Bool) -> MSSQLTxError -> Error.QErr
mkMSSQLTxErrorHandler :: (ErrorClass -> Bool) -> MSSQLTxError -> QErr
mkMSSQLTxErrorHandler ErrorClass -> Bool
isExpectedError = \case
  MSSQLQueryError Query
query ODBCException
exception ->
    let unexpectedQueryError :: QErr
unexpectedQueryError =
          (Text -> QErr
Error.internalError Text
"database query error")
            { qeInternal :: Maybe QErrExtra
Error.qeInternal =
                QErrExtra -> Maybe QErrExtra
forall a. a -> Maybe a
Just
                  (QErrExtra -> Maybe QErrExtra) -> QErrExtra -> Maybe QErrExtra
forall a b. (a -> b) -> a -> b
$ Value -> QErrExtra
Error.ExtraInternal
                  (Value -> QErrExtra) -> Value -> QErrExtra
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object
                    [ Key
"query" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Query -> Text
ODBC.renderQuery Query
query,
                      Key
"exception" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= ODBCException -> Value
odbcExceptionToJSONValue ODBCException
exception
                    ]
            }
     in QErr -> Maybe QErr -> QErr
forall a. a -> Maybe a -> a
fromMaybe QErr
unexpectedQueryError
          (Maybe QErr -> QErr) -> Maybe QErr -> QErr
forall a b. (a -> b) -> a -> b
$ ODBCException -> Maybe QErr
asExpectedError ODBCException
exception
          Maybe QErr -> (QErr -> QErr) -> Maybe QErr
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \QErr
err -> QErr
err {qeInternal :: Maybe QErrExtra
Error.qeInternal = QErrExtra -> Maybe QErrExtra
forall a. a -> Maybe a
Just (QErrExtra -> Maybe QErrExtra) -> QErrExtra -> Maybe QErrExtra
forall a b. (a -> b) -> a -> b
$ Value -> QErrExtra
Error.ExtraInternal (Value -> QErrExtra) -> Value -> QErrExtra
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [Key
"query" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Query -> Text
ODBC.renderQuery Query
query]}
  MSSQLConnError ODBCException
exception ->
    let unexpectedConnError :: QErr
unexpectedConnError =
          (Text -> QErr
Error.internalError Text
"mssql connection error")
            { qeInternal :: Maybe QErrExtra
Error.qeInternal =
                QErrExtra -> Maybe QErrExtra
forall a. a -> Maybe a
Just
                  (QErrExtra -> Maybe QErrExtra) -> QErrExtra -> Maybe QErrExtra
forall a b. (a -> b) -> a -> b
$ Value -> QErrExtra
Error.ExtraInternal
                  (Value -> QErrExtra) -> Value -> QErrExtra
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [Key
"exception" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= ODBCException -> Value
odbcExceptionToJSONValue ODBCException
exception]
            }
     in QErr -> Maybe QErr -> QErr
forall a. a -> Maybe a -> a
fromMaybe QErr
unexpectedConnError (Maybe QErr -> QErr) -> Maybe QErr -> QErr
forall a b. (a -> b) -> a -> b
$ ODBCException -> Maybe QErr
asExpectedError ODBCException
exception
  MSSQLInternal Text
err ->
    (Text -> QErr
Error.internalError Text
"mssql internal error")
      { qeInternal :: Maybe QErrExtra
Error.qeInternal = QErrExtra -> Maybe QErrExtra
forall a. a -> Maybe a
Just (QErrExtra -> Maybe QErrExtra) -> QErrExtra -> Maybe QErrExtra
forall a b. (a -> b) -> a -> b
$ Value -> QErrExtra
Error.ExtraInternal (Value -> QErrExtra) -> Value -> QErrExtra
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [Key
"error" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text
err]
      }
  where
    asExpectedError :: ODBC.ODBCException -> Maybe Error.QErr
    asExpectedError :: ODBCException -> Maybe QErr
asExpectedError = \case
      ODBC.UnsuccessfulReturnCode String
_ Int16
_ String
databaseMessage Maybe String
sqlState -> do
        ErrorClass
errorClass <- String -> Maybe ErrorClass
parseErrorClass (String -> Maybe ErrorClass) -> Maybe String -> Maybe ErrorClass
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe String
sqlState
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ ErrorClass -> Bool
isExpectedError ErrorClass
errorClass
        let errorMessage :: String
errorMessage = ErrorClass -> String
forall a. Show a => a -> String
show ErrorClass
errorClass String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
databaseMessage
        QErr -> Maybe QErr
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (QErr -> Maybe QErr) -> QErr -> Maybe QErr
forall a b. (a -> b) -> a -> b
$ Code -> Text -> QErr
Error.err400 (ErrorClass -> Code
errorClassCode ErrorClass
errorClass) (Text -> QErr) -> Text -> QErr
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
errorMessage
      ODBCException
_ -> Maybe QErr
forall a. Maybe a
Nothing

-- | The @'ODBC.ODBCException' type has no @'ToJSON' instance.
-- This is an attempt to convert the odbc exception to a JSON @'Value'
odbcExceptionToJSONValue :: ODBC.ODBCException -> Value
odbcExceptionToJSONValue :: ODBCException -> Value
odbcExceptionToJSONValue ODBCException
exception =
  let (String
ty, String
message) = ODBCException -> (String, String)
decodeODBCException ODBCException
exception
   in [Pair] -> Value
object [Key
"type" Key -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= String
ty, Key
"message" Key -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= String
message]
  where
    decodeODBCException :: ODBC.ODBCException -> (String, String)
    decodeODBCException :: ODBCException -> (String, String)
decodeODBCException = \case
      ODBC.UnsuccessfulReturnCode String
_ Int16
_ String
errMessage Maybe String
_ -> (String
"unsuccessful_return_code", String
errMessage)
      ODBC.AllocationReturnedNull String
_ -> (String
"allocation_returned_null", String
"allocating an ODBC resource failed")
      ODBC.UnknownDataType String
_ Int16
_ -> (String
"unknown_data_type", String
"An unsupported/unknown data type was returned from the ODBC driver")
      ODBC.DatabaseIsClosed String
_ -> (String
"database_is_closed", String
"Using database connection that is no longer available")
      ODBCException
ODBC.DatabaseAlreadyClosed -> (String
"database_already_closed", String
"The database is already closed")
      ODBC.NoTotalInformation Int
_ -> (String
"no_total_information", String
"No total length information for column")
      ODBC.DataRetrievalError String
errMessage -> (String
"data_retrieval_error", String
errMessage)