@@ -0,0 +1,89 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE DeriveDataTypeable #-}
3+
4+module Database.PostgreSQL.Simple.Errors
5+ ( ConstraintViolation(..)
6+ , constraintViolation
7+ , constraintViolationE
8+ , catchViolation
9+ )
10+ where
11+
12+import Prelude hiding (catch)
13+
14+import Control.Applicative
15+import Control.Exception
16+import Control.Monad.IO.Class
17+
18+import Data.Attoparsec.Char8
19+import Data.ByteString(ByteString)
20+import Data.Typeable
21+
22+import Database.PostgreSQL.Simple.Internal
23+
24+
25+data ConstraintViolation
26+ = NotNullViolation ByteString
27+ | ForeignKeyViolation ByteString ByteString
28+ | UniqueViolation ByteString
29+ | CheckViolation ByteString ByteString
30+ deriving (Show, Eq, Ord, Typeable)
31+
32+
33+-- | Tries to convert 'SqlError' to 'ConstrainViolation', checks sqlState and
34+-- succeedes only if able to parse sqlErrorMsg. May depend on postgres language
35+-- settings.
36+--
37+-- > createUser = catchJust constraintViolation catcher $ execute conn ...
38+-- > where
39+-- > catcher UniqueViolation "user_login_key" = ...
40+-- > catcher _ = ...
41+constraintViolation :: SqlError -> Maybe ConstraintViolation
42+constraintViolation e =
43+ case sqlState e of
44+ "23502" -> parseMaybe parseQ1 msg >>= Just . NotNullViolation
45+ "23503" -> parseMaybe parseQ2 msg >>= Just . uncurry ForeignKeyViolation
46+ "23505" -> parseMaybe parseQ1 msg >>= Just . UniqueViolation
47+ "23514" -> parseMaybe parseQ2 msg >>= Just . uncurry CheckViolation
48+ _ -> Nothing
49+ where msg = sqlErrorMsg e
50+
51+
52+-- | Like constraintViolation, but also packs original SqlError.
53+--
54+-- > createUser = catchJust constraintViolationE catcher $ execute conn ...
55+-- > where
56+-- > catcher (_, UniqueViolation "user_login_key") = ...
57+-- > catcher (e, _) = throw e
58+--
59+constraintViolationE :: SqlError -> Maybe (SqlError, ConstraintViolation)
60+constraintViolationE e = fmap ((,) e) $ constraintViolation e
61+
62+-- | Catches SqlError, tries to convert to ConstraintViolation, re-throws
63+-- on fail. Unlike catchJust, provides alternative interface to catchJust
64+--
65+-- > createUser = catchViolation catcher $ execute conn ...
66+-- > where
67+-- > catcher _ (UniqueViolation "user_login_key") = ...
68+-- > catcher e _ = throw e
69+catchViolation :: (SqlError -> ConstraintViolation -> IO a) -> IO a -> IO a
70+catchViolation f m = catch m
71+ (\e -> maybe (throw e) (f e) $ constraintViolation e)
72+
73+-- Parsers just try to extract quoted strings from error messages, number
74+-- of quoted strings depend on error type.
75+scanTillQuote :: Parser ByteString
76+scanTillQuote = scan False go
77+ where go True _ = Just False -- escaped character
78+ go False '"' = Nothing -- end parse
79+ go False '\\' = Just True -- nest one is escaped
80+ go _ _ = Just False
81+
82+parseQ1 :: Parser ByteString
83+parseQ1 = scanTillQuote *> char '"' *> scanTillQuote <* char '"'
84+
85+parseQ2 :: Parser (ByteString, ByteString)
86+parseQ2 = (,) <$> parseQ1 <*> parseQ1
87+
88+parseMaybe :: Parser a -> ByteString -> Maybe a
89+parseMaybe p b = either (const Nothing) Just $ parseOnly p b