    {-# LANGUAGE DeriveDataTypeable #-}
    {-# LANGUAGE OverloadedStrings  #-}
    {-# LANGUAGE RecordWildCards    #-}
    ------------------------------------------------------------------------------
    -- |
    -- Module:      Database.PostgreSQL.Simple.Errors
    -- Copyright:   (c) 2012-2013 Leonid Onokhov, Joey Adams
    -- License:     BSD3
    -- Maintainer:  Leon P Smith <leon@melding-monads.com>
    -- Stability:   experimental
    --
    -- | Module for parsing errors from postgresql error messages.
    --  Currently only parses integrity violation errors (class 23).
    --
    -- /Note: Success of parsing may depend on language settings./
    ----------------------------------------------------------
    module Database.PostgreSQL.Simple.Errors
           ( ConstraintViolation(..)
           , constraintViolation
           , constraintViolationE
           , catchViolation
           , isSerializationError
           , isNoActiveTransactionError
           , isFailedTransactionError
           )
           where

    import Control.Exception as E

    import Data.Attoparsec.ByteString.Char8
    import Data.ByteString       (ByteString)
    import Data.Typeable

    import Database.PostgreSQL.Simple.Internal

    -- Examples of parsed error messages
    --
    -- `ERROR:  new row for relation "users" violates check
    -- constraint "user_kind_check"`
    --
    -- `ERROR:  insert or update on table "user_group_map" violates foreign key
    --  constraint "user_id"`
    --
    -- `ERROR: null value in column "login" violates not-null constraint`
    --
    -- `ERROR: duplicate key value violates unique constraint "users_login_key"`

    data ConstraintViolation
       = NotNullViolation ByteString
       -- ^ The field is a column name
       | ForeignKeyViolation ByteString ByteString
       -- ^ Table name and name of violated constraint
       | UniqueViolation ByteString
       -- ^ Name of violated constraint
       | CheckViolation ByteString ByteString
       -- ^ Relation name (usually table), constraint name
       | ExclusionViolation ByteString
       -- ^ Name of the exclusion violation constraint
       deriving (Int -> ConstraintViolation -> ShowS
    [ConstraintViolation] -> ShowS
    ConstraintViolation -> String
    (Int -> ConstraintViolation -> ShowS)
    -> (ConstraintViolation -> String)
    -> ([ConstraintViolation] -> ShowS)
    -> Show ConstraintViolation
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> ConstraintViolation -> ShowS
    showsPrec :: Int -> ConstraintViolation -> ShowS
    $cshow :: ConstraintViolation -> String
    show :: ConstraintViolation -> String
    $cshowList :: [ConstraintViolation] -> ShowS
    showList :: [ConstraintViolation] -> ShowS
    Show, ConstraintViolation -> ConstraintViolation -> Bool
    (ConstraintViolation -> ConstraintViolation -> Bool)
    -> (ConstraintViolation -> ConstraintViolation -> Bool)
    -> Eq ConstraintViolation
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: ConstraintViolation -> ConstraintViolation -> Bool
    == :: ConstraintViolation -> ConstraintViolation -> Bool
    $c/= :: ConstraintViolation -> ConstraintViolation -> Bool
    /= :: ConstraintViolation -> ConstraintViolation -> Bool
    Eq, Eq ConstraintViolation
    Eq ConstraintViolation =>
    (ConstraintViolation -> ConstraintViolation -> Ordering)
    -> (ConstraintViolation -> ConstraintViolation -> Bool)
    -> (ConstraintViolation -> ConstraintViolation -> Bool)
    -> (ConstraintViolation -> ConstraintViolation -> Bool)
    -> (ConstraintViolation -> ConstraintViolation -> Bool)
    -> (ConstraintViolation
        -> ConstraintViolation -> ConstraintViolation)
    -> (ConstraintViolation
        -> ConstraintViolation -> ConstraintViolation)
    -> Ord ConstraintViolation
    ConstraintViolation -> ConstraintViolation -> Bool
    ConstraintViolation -> ConstraintViolation -> Ordering
    ConstraintViolation -> ConstraintViolation -> ConstraintViolation
    forall a.
    Eq a =>
    (a -> a -> Ordering)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> a)
    -> (a -> a -> a)
    -> Ord a
    $ccompare :: ConstraintViolation -> ConstraintViolation -> Ordering
    compare :: ConstraintViolation -> ConstraintViolation -> Ordering
    $c< :: ConstraintViolation -> ConstraintViolation -> Bool
    < :: ConstraintViolation -> ConstraintViolation -> Bool
    $c<= :: ConstraintViolation -> ConstraintViolation -> Bool
    <= :: ConstraintViolation -> ConstraintViolation -> Bool
    $c> :: ConstraintViolation -> ConstraintViolation -> Bool
    > :: ConstraintViolation -> ConstraintViolation -> Bool
    $c>= :: ConstraintViolation -> ConstraintViolation -> Bool
    >= :: ConstraintViolation -> ConstraintViolation -> Bool
    $cmax :: ConstraintViolation -> ConstraintViolation -> ConstraintViolation
    max :: ConstraintViolation -> ConstraintViolation -> ConstraintViolation
    $cmin :: ConstraintViolation -> ConstraintViolation -> ConstraintViolation
    min :: ConstraintViolation -> ConstraintViolation -> ConstraintViolation
    Ord, Typeable)

    -- Default instance should be enough
    instance Exception ConstraintViolation where
      toException :: ConstraintViolation -> SomeException
    toException = ConstraintViolation -> SomeException
    forall e. Exception e => e -> SomeException
    postgresqlExceptionToException
      fromException :: SomeException -> Maybe ConstraintViolation
    fromException = SomeException -> Maybe ConstraintViolation
    forall e. Exception e => SomeException -> Maybe e
    postgresqlExceptionFromException

    -- | Tries to convert 'SqlError' to 'ConstrainViolation', checks sqlState and
    -- succeeds only if able to parse sqlErrorMsg.
    --
    -- > createUser = handleJust constraintViolation handler $ execute conn ...
    -- >   where
    -- >     handler (UniqueViolation "user_login_key") = ...
    -- >     handler _ = ...
    constraintViolation :: SqlError -> Maybe ConstraintViolation
    constraintViolation :: SqlError -> Maybe ConstraintViolation
    constraintViolation SqlError
    e =
      case SqlError -> ByteString
    sqlState SqlError
    e of
        ByteString
    "23502" -> ByteString -> ConstraintViolation
    NotNullViolation (ByteString -> ConstraintViolation)
    -> Maybe ByteString -> Maybe ConstraintViolation
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Parser ByteString -> ByteString -> Maybe ByteString
    forall a. Parser a -> ByteString -> Maybe a
    parseMaybe Parser ByteString
    parseQ1 ByteString
    msg
        ByteString
    "23503" -> (ByteString -> ByteString -> ConstraintViolation)
    -> (ByteString, ByteString) -> ConstraintViolation
    forall a b c. (a -> b -> c) -> (a, b) -> c
    uncurry ByteString -> ByteString -> ConstraintViolation
    ForeignKeyViolation ((ByteString, ByteString) -> ConstraintViolation)
    -> Maybe (ByteString, ByteString) -> Maybe ConstraintViolation
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Parser (ByteString, ByteString)
    -> ByteString -> Maybe (ByteString, ByteString)
    forall a. Parser a -> ByteString -> Maybe a
    parseMaybe Parser (ByteString, ByteString)
    parseQ2 ByteString
    msg
        ByteString
    "23505" -> ByteString -> ConstraintViolation
    UniqueViolation (ByteString -> ConstraintViolation)
    -> Maybe ByteString -> Maybe ConstraintViolation
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Parser ByteString -> ByteString -> Maybe ByteString
    forall a. Parser a -> ByteString -> Maybe a
    parseMaybe Parser ByteString
    parseQ1 ByteString
    msg
        ByteString
    "23514" -> (ByteString -> ByteString -> ConstraintViolation)
    -> (ByteString, ByteString) -> ConstraintViolation
    forall a b c. (a -> b -> c) -> (a, b) -> c
    uncurry ByteString -> ByteString -> ConstraintViolation
    CheckViolation ((ByteString, ByteString) -> ConstraintViolation)
    -> Maybe (ByteString, ByteString) -> Maybe ConstraintViolation
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Parser (ByteString, ByteString)
    -> ByteString -> Maybe (ByteString, ByteString)
    forall a. Parser a -> ByteString -> Maybe a
    parseMaybe Parser (ByteString, ByteString)
    parseQ2 ByteString
    msg
        ByteString
    "23P01" -> ByteString -> ConstraintViolation
    ExclusionViolation (ByteString -> ConstraintViolation)
    -> Maybe ByteString -> Maybe ConstraintViolation
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Parser ByteString -> ByteString -> Maybe ByteString
    forall a. Parser a -> ByteString -> Maybe a
    parseMaybe Parser ByteString
    parseQ1 ByteString
    msg
        ByteString
    _ -> Maybe ConstraintViolation
    forall a. Maybe a
    Nothing
      where msg :: ByteString
    msg = SqlError -> ByteString
    sqlErrorMsg SqlError
    e

    -- | Like constraintViolation, but also packs original SqlError.
    --
    -- > createUser = handleJust constraintViolationE handler $ execute conn ...
    -- >   where
    -- >     handler (_, UniqueViolation "user_login_key") = ...
    -- >     handler (e, _) = throwIO e
    --
    constraintViolationE :: SqlError -> Maybe (SqlError, ConstraintViolation)
    constraintViolationE :: SqlError -> Maybe (SqlError, ConstraintViolation)
    constraintViolationE SqlError
    e = (ConstraintViolation -> (SqlError, ConstraintViolation))
    -> Maybe ConstraintViolation
    -> Maybe (SqlError, ConstraintViolation)
    forall a b. (a -> b) -> Maybe a -> Maybe b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap ((,) SqlError
    e) (Maybe ConstraintViolation
     -> Maybe (SqlError, ConstraintViolation))
    -> Maybe ConstraintViolation
    -> Maybe (SqlError, ConstraintViolation)
    forall a b. (a -> b) -> a -> b
    $ SqlError -> Maybe ConstraintViolation
    constraintViolation SqlError
    e

    -- | Catches SqlError, tries to convert to ConstraintViolation, re-throws
    -- on fail. Provides alternative interface to 'E.handleJust'
    --
    -- > createUser = catchViolation catcher $ execute conn ...
    -- >   where
    -- >     catcher _ (UniqueViolation "user_login_key") = ...
    -- >     catcher e _ = throwIO e
    catchViolation :: (SqlError -> ConstraintViolation -> IO a) -> IO a -> IO a
    catchViolation :: forall a. (SqlError -> ConstraintViolation -> IO a) -> IO a -> IO a
    catchViolation SqlError -> ConstraintViolation -> IO a
    f IO a
    m = IO a -> (SqlError -> IO a) -> IO a
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
    E.catch IO a
    m
                         (\SqlError
    e -> IO a
    -> (ConstraintViolation -> IO a)
    -> Maybe ConstraintViolation
    -> IO a
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe (SqlError -> IO a
    forall e a. (HasCallStack, Exception e) => e -> IO a
    throwIO SqlError
    e) (SqlError -> ConstraintViolation -> IO a
    f SqlError
    e) (Maybe ConstraintViolation -> IO a)
    -> Maybe ConstraintViolation -> IO a
    forall a b. (a -> b) -> a -> b
    $ SqlError -> Maybe ConstraintViolation
    constraintViolation SqlError
    e)

    -- Parsers just try to extract quoted strings from error messages, number
    -- of quoted strings depend on error type.
    scanTillQuote :: Parser ByteString
    scanTillQuote :: Parser ByteString
    scanTillQuote = Bool -> (Bool -> Char -> Maybe Bool) -> Parser ByteString
    forall s. s -> (s -> Char -> Maybe s) -> Parser ByteString
    scan Bool
    False Bool -> Char -> Maybe Bool
    go
      where go :: Bool -> Char -> Maybe Bool
    go Bool
    True Char
    _ = Bool -> Maybe Bool
    forall a. a -> Maybe a
    Just Bool
    False -- escaped character
            go Bool
    False Char
    '"' = Maybe Bool
    forall a. Maybe a
    Nothing -- end parse
            go Bool
    False Char
    '\\' = Bool -> Maybe Bool
    forall a. a -> Maybe a
    Just Bool
    True -- next one is escaped
            go Bool
    _ Char
    _ = Bool -> Maybe Bool
    forall a. a -> Maybe a
    Just Bool
    False

    parseQ1 :: Parser ByteString
    parseQ1 :: Parser ByteString
    parseQ1 = Parser ByteString
    scanTillQuote Parser ByteString
    -> Parser ByteString Char -> Parser ByteString Char
    forall a b.
    Parser ByteString a -> Parser ByteString b -> Parser ByteString b
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
    *> Char -> Parser ByteString Char
    char Char
    '"' Parser ByteString Char -> Parser ByteString -> Parser ByteString
    forall a b.
    Parser ByteString a -> Parser ByteString b -> Parser ByteString b
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
    *> Parser ByteString
    scanTillQuote Parser ByteString -> Parser ByteString Char -> Parser ByteString
    forall a b.
    Parser ByteString a -> Parser ByteString b -> Parser ByteString a
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
    <* Char -> Parser ByteString Char
    char Char
    '"'

    parseQ2 :: Parser (ByteString, ByteString)
    parseQ2 :: Parser (ByteString, ByteString)
    parseQ2 = (,) (ByteString -> ByteString -> (ByteString, ByteString))
    -> Parser ByteString
    -> Parser ByteString (ByteString -> (ByteString, ByteString))
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Parser ByteString
    parseQ1 Parser ByteString (ByteString -> (ByteString, ByteString))
    -> Parser ByteString -> Parser (ByteString, ByteString)
    forall a b.
    Parser ByteString (a -> b)
    -> Parser ByteString a -> Parser ByteString b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> Parser ByteString
    parseQ1

    parseMaybe :: Parser a -> ByteString -> Maybe a
    parseMaybe :: forall a. Parser a -> ByteString -> Maybe a
    parseMaybe Parser a
    p ByteString
    b = (String -> Maybe a) -> (a -> Maybe a) -> Either String a -> Maybe a
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
    either (Maybe a -> String -> Maybe a
    forall a b. a -> b -> a
    const Maybe a
    forall a. Maybe a
    Nothing) a -> Maybe a
    forall a. a -> Maybe a
    Just (Either String a -> Maybe a) -> Either String a -> Maybe a
    forall a b. (a -> b) -> a -> b
    $ Parser a -> ByteString -> Either String a
    forall a. Parser a -> ByteString -> Either String a
    parseOnly Parser a
    p ByteString
    b

    ------------------------------------------------------------------------
    -- Error predicates
    --
    -- https://www.postgresql.org/docs/9.5/static/errcodes-appendix.html

    isSerializationError :: SqlError -> Bool
    isSerializationError :: SqlError -> Bool
    isSerializationError = ByteString -> SqlError -> Bool
    isSqlState ByteString
    "40001"

    isNoActiveTransactionError :: SqlError -> Bool
    isNoActiveTransactionError :: SqlError -> Bool
    isNoActiveTransactionError = ByteString -> SqlError -> Bool
    isSqlState ByteString
    "25P01"

    isFailedTransactionError :: SqlError -> Bool
    isFailedTransactionError :: SqlError -> Bool
    isFailedTransactionError = ByteString -> SqlError -> Bool
    isSqlState ByteString
    "25P02"

    isSqlState :: ByteString -> SqlError -> Bool
    isSqlState :: ByteString -> SqlError -> Bool
    isSqlState ByteString
    s SqlError{ByteString
    ExecStatus
    sqlState :: SqlError -> ByteString
    sqlErrorMsg :: SqlError -> ByteString
    sqlState :: ByteString
    sqlExecStatus :: ExecStatus
    sqlErrorMsg :: ByteString
    sqlErrorDetail :: ByteString
    sqlErrorHint :: ByteString
    sqlErrorHint :: SqlError -> ByteString
    sqlErrorDetail :: SqlError -> ByteString
    sqlExecStatus :: SqlError -> ExecStatus
    ..} = ByteString
    sqlState ByteString -> ByteString -> Bool
    forall a. Eq a => a -> a -> Bool
    == ByteString
    s