content: {-# 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 (Show, Eq, Ord, Typeable)
  
  -- Default instance should be enough
  instance Exception ConstraintViolation
  
  
  -- | Tries to convert 'SqlError' to 'ConstrainViolation', checks sqlState and
  -- succeedes 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
  