@@ -0,0 +1,110 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+
4+-- | Module for parsing errors from posgresql error messages.
5+-- Currently in only parses integrity violation errors (class 23).
6+--
7+-- /Note: Success of parsing may depend on language settings./
8+----------------------------------------------------------
9+module Database.PostgreSQL.Simple.Errors
10+ ( ConstraintViolation(..)
11+ , constraintViolation
12+ , constraintViolationE
13+ , catchViolation
14+ )
15+ where
16+
17+import Prelude hiding (catch)
18+
19+import Control.Applicative
20+import Control.Exception
21+
22+import Data.Attoparsec.Char8
23+import Data.ByteString (ByteString)
24+import Data.Typeable
25+
26+import Database.PostgreSQL.Simple.Internal
27+
28+-- Examples of parsed error messages
29+--
30+-- `ERROR: new row for relation "users" violates check
31+-- constraint "user_kind_check"`
32+--
33+-- `ERROR: insert or update on table "user_group_map" violates foreign key
34+-- constraint "user_id"`
35+--
36+-- `ERROR: null value in column "login" violates not-null constraint`
37+--
38+-- `ERROR: duplicate key value violates unique constraint "users_login_key"`
39+
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)
50+
51+-- Default instance should be enough
52+instance Exception ConstraintViolation
53+
54+
55+-- | Tries to convert 'SqlError' to 'ConstrainViolation', checks sqlState and
56+-- succeedes only if able to parse sqlErrorMsg.
57+--
58+-- > createUser = catchJust constraintViolation catcher $ execute conn ...
59+-- > where
60+-- > catcher UniqueViolation "user_login_key" = ...
61+-- > catcher _ = ...
62+constraintViolation :: SqlError -> Maybe ConstraintViolation
63+constraintViolation e =
64+ case sqlState e of
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
69+ _ -> Nothing
70+ where msg = sqlErrorMsg e
71+
72+
73+-- | Like constraintViolation, but also packs original SqlError.
74+--
75+-- > createUser = catchJust constraintViolationE catcher $ execute conn ...
76+-- > where
77+-- > catcher (_, UniqueViolation "user_login_key") = ...
78+-- > catcher (e, _) = throw e
79+--
80+constraintViolationE :: SqlError -> Maybe (SqlError, ConstraintViolation)
81+constraintViolationE e = fmap ((,) e) $ constraintViolation e
82+
83+-- | Catches SqlError, tries to convert to ConstraintViolation, re-throws
84+-- on fail. Provides alternative interface to catchJust
85+--
86+-- > createUser = catchViolation catcher $ execute conn ...
87+-- > where
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)
93+
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
101+ go _ _ = Just False
102+
103+parseQ1 :: Parser ByteString
104+parseQ1 = scanTillQuote *> char '"' *> scanTillQuote <* char '"'
105+
106+parseQ2 :: Parser (ByteString, ByteString)
107+parseQ2 = (,) <$> parseQ1 <*> parseQ1
108+
109+parseMaybe :: Parser a -> ByteString -> Maybe a
110+parseMaybe p b = either (const Nothing) Just $ parseOnly p b