Errors.hs

------------------------------------------------------------------------------

----------------------------------------------------------

-- |
-- 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
  = -- | The field is a column name
    NotNullViolation ByteString
  | -- | Table name and name of violated constraint
    ForeignKeyViolation ByteString ByteString
  | -- | Name of violated constraint
    UniqueViolation ByteString
  | -- | Relation name (usually table), constraint name
    CheckViolation ByteString ByteString
  | -- | Name of the exclusion violation constraint
    ExclusionViolation ByteString
  deriving (Show, Eq, Ord, Typeable)

-- Default instance should be enough
instance Exception ConstraintViolation where
  toException = postgresqlExceptionToException
  fromException = 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 e =
  case sqlState e of
    "23502" -> NotNullViolation <$> parseMaybe parseQ1 msg
    "23503" -> uncurry ForeignKeyViolation <$> parseMaybe parseQ2 msg
    "23505" -> UniqueViolation <$> parseMaybe parseQ1 msg
    "23514" -> uncurry CheckViolation <$> parseMaybe parseQ2 msg
    "23P01" -> ExclusionViolation <$> parseMaybe parseQ1 msg
    _ -> Nothing
  where
    msg = sqlErrorMsg 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 e = fmap ((,) e) $ constraintViolation 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 f m =
  E.catch
    m
    (\e -> maybe (throwIO e) (f e) $ constraintViolation e)

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

parseQ1 :: Parser ByteString
parseQ1 = scanTillQuote *> char '"' *> scanTillQuote <* char '"'

parseQ2 :: Parser (ByteString, ByteString)
parseQ2 = (,) <$> parseQ1 <*> parseQ1

parseMaybe :: Parser a -> ByteString -> Maybe a
parseMaybe p b = either (const Nothing) Just $ parseOnly p b

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

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

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

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

isSqlState :: ByteString -> SqlError -> Bool
isSqlState s SqlError {..} = sqlState == s