@@ -0,0 +1,110 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+{-# LANGUAGE OverloadedStrings #-}
4+-- | Module for parsing errors from posgresql error messages.
5+-- Currently in only parses integrity violation errors (class 23).
7+-- /Note: Success of parsing may depend on language settings./
8+----------------------------------------------------------
9+module Database.PostgreSQL.Simple.Errors
10+ ( ConstraintViolation(..)
11+ , constraintViolation
12+ , constraintViolationE
17+import Prelude hiding (catch)
19+import Control.Applicative
20+import Control.Exception
22+import Data.Attoparsec.Char8
23+import Data.ByteString (ByteString)
26+import Database.PostgreSQL.Simple.Internal
28+-- Examples of parsed error messages
30+-- `ERROR: new row for relation "users" violates check
31+-- constraint "user_kind_check"`
33+-- `ERROR: insert or update on table "user_group_map" violates foreign key
34+-- constraint "user_id"`
36+-- `ERROR: null value in column "login" violates not-null constraint`
38+-- `ERROR: duplicate key value violates unique constraint "users_login_key"`
40+data ConstraintViolation
41+ = NotNullViolation ByteString
42+ -- ^ The field is a column name
43+ | ForeignKeyViolation ByteString ByteString
44+ -- ^ Table name and name of violated constraint
45+ | UniqueViolation ByteString
46+ -- ^ Name of violated constraint
47+ | CheckViolation ByteString ByteString
48+ -- ^ Relation name (usually table), constraint name
49+ deriving (Show, Eq, Ord, Typeable)
51+-- Default instance should be enough
52+instance Exception ConstraintViolation
55+-- | Tries to convert 'SqlError' to 'ConstrainViolation', checks sqlState and
56+-- succeedes only if able to parse sqlErrorMsg.
58+-- > createUser = catchJust constraintViolation catcher $ execute conn ...
60+-- > catcher UniqueViolation "user_login_key" = ...
62+constraintViolation :: SqlError -> Maybe ConstraintViolation
63+constraintViolation e =
65+ "23502" -> NotNullViolation <$> parseMaybe parseQ1 msg
66+ "23503" -> uncurry ForeignKeyViolation <$> parseMaybe parseQ2 msg
67+ "23505" -> UniqueViolation <$> parseMaybe parseQ1 msg
68+ "23514" -> uncurry CheckViolation <$> parseMaybe parseQ2 msg
70+ where msg = sqlErrorMsg e
73+-- | Like constraintViolation, but also packs original SqlError.
75+-- > createUser = catchJust constraintViolationE catcher $ execute conn ...
77+-- > catcher (_, UniqueViolation "user_login_key") = ...
78+-- > catcher (e, _) = throw e
80+constraintViolationE :: SqlError -> Maybe (SqlError, ConstraintViolation)
81+constraintViolationE e = fmap ((,) e) $ constraintViolation e
83+-- | Catches SqlError, tries to convert to ConstraintViolation, re-throws
84+-- on fail. Provides alternative interface to catchJust
86+-- > createUser = catchViolation catcher $ execute conn ...
88+-- > catcher _ (UniqueViolation "user_login_key") = ...
89+-- > catcher e _ = throw e
90+catchViolation :: (SqlError -> ConstraintViolation -> IO a) -> IO a -> IO a
91+catchViolation f m = catch m
92+ (\e -> maybe (throw e) (f e) $ constraintViolation e)
94+-- Parsers just try to extract quoted strings from error messages, number
95+-- of quoted strings depend on error type.
96+scanTillQuote :: Parser ByteString
97+scanTillQuote = scan False go
98+ where go True _ = Just False -- escaped character
99+ go False '"' = Nothing -- end parse
100+ go False '\\' = Just True -- next one is escaped
103+parseQ1 :: Parser ByteString
104+parseQ1 = scanTillQuote *> char '"' *> scanTillQuote <* char '"'
106+parseQ2 :: Parser (ByteString, ByteString)
107+parseQ2 = (,) <$> parseQ1 <*> parseQ1
109+parseMaybe :: Parser a -> ByteString -> Maybe a
110+parseMaybe p b = either (const Nothing) Just $ parseOnly p b