af9b004 · typeable/postgresql-simple

git.iko.soy/typeable/postgresql-simple

Merge pull request #124 from haskellari/exception-class

Add superclass for all postgresql exceptions

commitaf9b004a5e58eaf8459fa01b6d5ef248e45c3daf authorOleg Grenrus <oleg.grenrus@iki.fi> dateMon 31 Jul 2023, 11:44 (3 years ago) parentdcfec6f 1e7df9f

7 files changed+112−6

compare with master

unifiedsplit

postgresql-simple.cabal+1 src/Database/PostgreSQL/Simple.hs+1 src/Database/PostgreSQL/Simple/Errors.hs+3−1 src/Database/PostgreSQL/Simple/FromField.hs+4−2 src/Database/PostgreSQL/Simple/Internal.hs+31−3 test/Exception.hs+70 test/Main.hs+2

postgresql-simple.cabal+1

@@ -128,6 +128,7 @@ test-suite test

128128 main-is: Main.hs

129129 other-modules:

130130 Common

131+ Exception

131132 Interval

132133 Notify

133134 Serializable

src/Database/PostgreSQL/Simple.hs+1

@@ -64,6 +64,7 @@ module Database.PostgreSQL.Simple

6464 , Only(..)

6565 , (:.)(..)

6666 -- ** Exceptions

67+ , SomePostgreSqlException(..)

6768 , SqlError(..)

6869 , PQ.ExecStatus(..)

6970 , FormatError(..)

src/Database/PostgreSQL/Simple/Errors.hs+3−1

@@ -59,7 +59,9 @@ data ConstraintViolation

5959 deriving (Show, Eq, Ord, Typeable)

6060

6161-- Default instance should be enough

62−instance Exception ConstraintViolation

62+instance Exception ConstraintViolation where

63+ toException = postgresqlExceptionToException

64+ fromException = postgresqlExceptionFromException

6365

6466

6567-- | Tries to convert 'SqlError' to 'ConstrainViolation', checks sqlState and

src/Database/PostgreSQL/Simple/FromField.hs+4−2

@@ -118,7 +118,7 @@ module Database.PostgreSQL.Simple.FromField

118118

119119import Control.Applicative ( Const(Const), (<|>), (<$>), pure, (*>), (<*) )

120120import Control.Concurrent.MVar (MVar, newMVar)

121−import Control.Exception (Exception)

121+import Control.Exception (Exception (toException, fromException))

122122import qualified Data.Aeson as JSON

123123import Data.Attoparsec.ByteString.Char8 hiding (Result)

124124import Data.ByteString (ByteString)

@@ -182,7 +182,9 @@ data ResultError = Incompatible { errSQLType :: String

182182 -- between metadata and actual data in a row).

183183 deriving (Eq, Show, Typeable)

184184

185−instance Exception ResultError

185+instance Exception ResultError where

186+ toException = postgresqlExceptionToException

187+ fromException = postgresqlExceptionFromException

186188

187189left :: Exception a => a -> Conversion b

188190left = conversionError

src/Database/PostgreSQL/Simple/Internal.hs+31−3

@@ -1,6 +1,8 @@

11{-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse, RecordWildCards #-}

22{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}

33{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4+{-# LANGUAGE ExistentialQuantification #-}

5+{-# LANGUAGE InstanceSigs #-}

57------------------------------------------------------------------------------

68-- |

@@ -81,6 +83,25 @@ data Connection = Connection {

8183instance Eq Connection where

8284 x == y = connectionHandle x == connectionHandle y

8385

86+-- | Superclass for postgresql exceptions

87+data SomePostgreSqlException = forall e. Exception e => SomePostgreSqlException e

88+ deriving Typeable

89+

90+postgresqlExceptionToException :: Exception e => e -> SomeException

91+postgresqlExceptionToException = toException . SomePostgreSqlException

92+

93+postgresqlExceptionFromException :: Exception e => SomeException -> Maybe e

94+postgresqlExceptionFromException x = do

95+ SomePostgreSqlException a <- fromException x

96+ cast a

97+

98+instance Show SomePostgreSqlException where

99+ showsPrec :: Int -> SomePostgreSqlException -> ShowS

100+ showsPrec p (SomePostgreSqlException e) = showsPrec p e

101+

102+instance Exception SomePostgreSqlException where

103+ displayException (SomePostgreSqlException e) = displayException e

104+

84105data SqlError = SqlError {

85106 sqlState :: ByteString

86107 , sqlExecStatus :: ExecStatus

@@ -92,7 +113,10 @@ data SqlError = SqlError {

92113fatalError :: ByteString -> SqlError

93114fatalError msg = SqlError "" FatalError msg "" ""

94115

95−instance Exception SqlError

116+instance Exception SqlError where

117+ toException = postgresqlExceptionToException

118+ fromException = postgresqlExceptionFromException

119+

96120

97121-- | Exception thrown if 'query' is used to perform an @INSERT@-like

98122-- operation, or 'execute' is used to perform a @SELECT@-like operation.

@@ -101,7 +125,9 @@ data QueryError = QueryError {

101125 , qeQuery :: Query

102126 } deriving (Eq, Show, Typeable)

103127

104−instance Exception QueryError

128+instance Exception QueryError where

129+ toException = postgresqlExceptionToException

130+ fromException = postgresqlExceptionFromException

105131

106132-- | Exception thrown if a 'Query' could not be formatted correctly.

107133-- This may occur if the number of \'@?@\' characters in the query

@@ -112,7 +138,9 @@ data FormatError = FormatError {

112138 , fmtParams :: [ByteString]

113139 } deriving (Eq, Show, Typeable)

114140

115−instance Exception FormatError

141+instance Exception FormatError where

142+ toException = postgresqlExceptionToException

143+ fromException = postgresqlExceptionFromException

116144

117145data ConnectInfo = ConnectInfo {

118146 connectHost :: String

test/Exception.hsnew file+70

@@ -0,0 +1,70 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

5+module Exception (testExceptions) where

7+import Database.PostgreSQL.Simple

8+import Test.Tasty.HUnit (Assertion, assertBool)

9+import Common (TestEnv)

10+import Control.Exception (Exception (..), SomeException)

11+import Data.Maybe (isJust)

12+import Data.Either (isLeft)

13+import Control.Exception (throwIO, try)

14+

15+testExceptions :: TestEnv -> Assertion

16+testExceptions _ = do

17+ let sqlError = SqlError

18+ { sqlState = ""

19+ , sqlExecStatus = FatalError

20+ , sqlErrorMsg = ""

21+ , sqlErrorDetail = ""

22+ , sqlErrorHint = ""

23+ }

24+ let sqlEx :: SomeException = toException sqlError

25+ assertBool "SqlError is SomePostgreSqlException" $ isJust (fromException sqlEx :: Maybe SomePostgreSqlException)

26+ assertBool "SqlError is SqlError" $ isJust (fromException sqlEx :: Maybe SqlError)

27+ eSqlError :: Either SqlError () <- try $ throwIO sqlEx

28+ assertBool "Can catch SqlError" $ isLeft eSqlError

29+ eSqlPostgreSqlEx :: Either SomePostgreSqlException () <- try $ throwIO sqlEx

30+ assertBool "Can catch SomePostgreSqlException from SqlError" $ isLeft eSqlPostgreSqlEx

31+

32+ let formatError = FormatError

33+ { fmtMessage = ""

34+ , fmtQuery = ""

35+ , fmtParams = []

36+ }

37+ let formatEx :: SomeException = toException formatError

38+ assertBool "FormatError is SomePostgreSqlException" $ isJust (fromException formatEx :: Maybe SomePostgreSqlException)

39+ assertBool "FormatError is FormatError" $ isJust (fromException formatEx :: Maybe FormatError)

40+ eFormatError :: Either FormatError () <- try $ throwIO formatEx

41+ assertBool "Can catch FormatError" $ isLeft eFormatError

42+ eFormatPostreSqlEx :: Either SomePostgreSqlException () <- try $ throwIO formatEx

43+ assertBool "Can catch SomePostgreSqlException from FormatError" $ isLeft eFormatPostreSqlEx

44+

45+ let queryError = QueryError

46+ { qeMessage = ""

47+ , qeQuery = ""

48+ }

49+ let queryEx :: SomeException = toException queryError

50+ assertBool "QueryError is SomePostgreSqlException" $ isJust (fromException queryEx :: Maybe SomePostgreSqlException)

51+ assertBool "QueryError is QueryError" $ isJust (fromException queryEx :: Maybe QueryError)

52+ eQueryError :: Either QueryError () <- try $ throwIO queryEx

53+ assertBool "Can catch QueryError" $ isLeft eQueryError

54+ eQueryPostgreSqlEx :: Either SomePostgreSqlException () <- try $ throwIO queryEx

55+ assertBool "Can catch SomePostgreSqlException from QueryError" $ isLeft eQueryPostgreSqlEx

56+

57+ let resultError = Incompatible

58+ { errSQLType = ""

59+ , errSQLTableOid = Nothing

60+ , errSQLField = ""

61+ , errHaskellType = ""

62+ , errMessage = ""

63+ }

64+ let resultEx :: SomeException = toException resultError

65+ assertBool "ResultError is SomePostgreSqlException" $ isJust (fromException resultEx :: Maybe SomePostgreSqlException)

66+ assertBool "ResultError is ResultError" $ isJust (fromException resultEx :: Maybe ResultError)

67+ eResultEx :: Either ResultError () <- try $ throwIO resultEx

68+ assertBool "Can catch ResultError" $ isLeft eResultEx

69+ eResultPostgreSqlEx :: Either SomePostgreSqlException () <- try $ throwIO resultEx

70+ assertBool "Can catch SomePostgreSqlException from ResultError" $ isLeft eResultPostgreSqlEx

test/Main.hs+2

@@ -55,6 +55,7 @@ import Notify

5555import Serializable

5656import Time

5757import Interval

58+import Exception (testExceptions)

5859

5960tests :: TestEnv -> TestTree

6061tests env = testGroup "tests"

@@ -84,6 +85,7 @@ tests env = testGroup "tests"

8485 , testCase "2-ary generic" . testGeneric2

8586 , testCase "3-ary generic" . testGeneric3

8687 , testCase "Timeout" . testTimeout

88+ , testCase "Exceptions" . testExceptions

8789 ]

8890

8991testBytea :: TestEnv -> TestTree