{-# 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.Applicative
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
showList :: [ConstraintViolation] -> ShowS
$cshowList :: [ConstraintViolation] -> ShowS
show :: ConstraintViolation -> String
$cshow :: ConstraintViolation -> String
showsPrec :: Int -> ConstraintViolation -> ShowS
$cshowsPrec :: Int -> ConstraintViolation -> ShowS
Show, ConstraintViolation -> ConstraintViolation -> Bool
(ConstraintViolation -> ConstraintViolation -> Bool)
-> (ConstraintViolation -> ConstraintViolation -> Bool)
-> Eq ConstraintViolation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConstraintViolation -> ConstraintViolation -> Bool
$c/= :: ConstraintViolation -> ConstraintViolation -> Bool
== :: ConstraintViolation -> ConstraintViolation -> Bool
$c== :: 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
min :: ConstraintViolation -> ConstraintViolation -> ConstraintViolation
$cmin :: ConstraintViolation -> ConstraintViolation -> ConstraintViolation
max :: ConstraintViolation -> ConstraintViolation -> ConstraintViolation
$cmax :: ConstraintViolation -> ConstraintViolation -> ConstraintViolation
>= :: ConstraintViolation -> ConstraintViolation -> Bool
$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
compare :: ConstraintViolation -> ConstraintViolation -> Ordering
$ccompare :: ConstraintViolation -> ConstraintViolation -> Ordering
$cp1Ord :: Eq ConstraintViolation
Ord, Typeable)

-- Default instance should be enough
instance Exception ConstraintViolation


-- | 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 (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 :: (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. 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 (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 (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString
scanTillQuote Parser ByteString -> Parser ByteString Char -> Parser ByteString
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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString
parseQ1

parseMaybe :: Parser a -> ByteString -> Maybe a
parseMaybe :: 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
sqlErrorHint :: SqlError -> ByteString
sqlErrorDetail :: SqlError -> ByteString
sqlExecStatus :: SqlError -> ExecStatus
sqlErrorHint :: ByteString
sqlErrorDetail :: ByteString
sqlErrorMsg :: ByteString
sqlExecStatus :: ExecStatus
sqlState :: ByteString
sqlErrorMsg :: SqlError -> ByteString
sqlState :: SqlError -> ByteString
..} = ByteString
sqlState ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
s