From 1e7df9f795e035353c99ef74cd58b536ef558de4 Mon Sep 17 00:00:00 2001 From: Marc Jakobi Date: Wed, 2 Nov 2022 21:55:45 +0100 Subject: [PATCH] Add superclass for all postgresql exceptions - add test cases to prove all exception types can be caught --- postgresql-simple.cabal | 1 + src/Database/PostgreSQL/Simple.hs | 1 + src/Database/PostgreSQL/Simple/Errors.hs | 4 +- src/Database/PostgreSQL/Simple/FromField.hs | 6 +- src/Database/PostgreSQL/Simple/Internal.hs | 34 +++++++++- test/Exception.hs | 70 +++++++++++++++++++++ test/Main.hs | 2 + 7 files changed, 112 insertions(+), 6 deletions(-) create mode 100644 test/Exception.hs diff --git a/postgresql-simple.cabal b/postgresql-simple.cabal index c627c3a..b9ade5d 100644 --- a/postgresql-simple.cabal +++ b/postgresql-simple.cabal @@ -128,6 +128,7 @@ test-suite test main-is: Main.hs other-modules: Common + Exception Interval Notify Serializable diff --git a/src/Database/PostgreSQL/Simple.hs b/src/Database/PostgreSQL/Simple.hs index 816cea5..6ecc86d 100644 --- a/src/Database/PostgreSQL/Simple.hs +++ b/src/Database/PostgreSQL/Simple.hs @@ -64,6 +64,7 @@ module Database.PostgreSQL.Simple , Only(..) , (:.)(..) -- ** Exceptions + , SomePostgreSqlException(..) , SqlError(..) , PQ.ExecStatus(..) , FormatError(..) diff --git a/src/Database/PostgreSQL/Simple/Errors.hs b/src/Database/PostgreSQL/Simple/Errors.hs index e9221d8..e3ce9d2 100644 --- a/src/Database/PostgreSQL/Simple/Errors.hs +++ b/src/Database/PostgreSQL/Simple/Errors.hs @@ -59,7 +59,9 @@ data ConstraintViolation deriving (Show, Eq, Ord, Typeable) -- Default instance should be enough -instance Exception ConstraintViolation +instance Exception ConstraintViolation where + toException = postgresqlExceptionToException + fromException = postgresqlExceptionFromException -- | Tries to convert 'SqlError' to 'ConstrainViolation', checks sqlState and diff --git a/src/Database/PostgreSQL/Simple/FromField.hs b/src/Database/PostgreSQL/Simple/FromField.hs index 89ed40c..feab6c7 100644 --- a/src/Database/PostgreSQL/Simple/FromField.hs +++ b/src/Database/PostgreSQL/Simple/FromField.hs @@ -118,7 +118,7 @@ module Database.PostgreSQL.Simple.FromField import Control.Applicative ( Const(Const), (<|>), (<$>), pure, (*>), (<*) ) import Control.Concurrent.MVar (MVar, newMVar) -import Control.Exception (Exception) +import Control.Exception (Exception (toException, fromException)) import qualified Data.Aeson as JSON import Data.Attoparsec.ByteString.Char8 hiding (Result) import Data.ByteString (ByteString) @@ -182,7 +182,9 @@ data ResultError = Incompatible { errSQLType :: String -- between metadata and actual data in a row). deriving (Eq, Show, Typeable) -instance Exception ResultError +instance Exception ResultError where + toException = postgresqlExceptionToException + fromException = postgresqlExceptionFromException left :: Exception a => a -> Conversion b left = conversionError diff --git a/src/Database/PostgreSQL/Simple/Internal.hs b/src/Database/PostgreSQL/Simple/Internal.hs index f4d14ff..b7adad4 100644 --- a/src/Database/PostgreSQL/Simple/Internal.hs +++ b/src/Database/PostgreSQL/Simple/Internal.hs @@ -1,6 +1,8 @@ {-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse, RecordWildCards #-} {-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE InstanceSigs #-} ------------------------------------------------------------------------------ -- | @@ -81,6 +83,25 @@ data Connection = Connection { instance Eq Connection where x == y = connectionHandle x == connectionHandle y +-- | Superclass for postgresql exceptions +data SomePostgreSqlException = forall e. Exception e => SomePostgreSqlException e + deriving Typeable + +postgresqlExceptionToException :: Exception e => e -> SomeException +postgresqlExceptionToException = toException . SomePostgreSqlException + +postgresqlExceptionFromException :: Exception e => SomeException -> Maybe e +postgresqlExceptionFromException x = do + SomePostgreSqlException a <- fromException x + cast a + +instance Show SomePostgreSqlException where + showsPrec :: Int -> SomePostgreSqlException -> ShowS + showsPrec p (SomePostgreSqlException e) = showsPrec p e + +instance Exception SomePostgreSqlException where + displayException (SomePostgreSqlException e) = displayException e + data SqlError = SqlError { sqlState :: ByteString , sqlExecStatus :: ExecStatus @@ -92,7 +113,10 @@ data SqlError = SqlError { fatalError :: ByteString -> SqlError fatalError msg = SqlError "" FatalError msg "" "" -instance Exception SqlError +instance Exception SqlError where + toException = postgresqlExceptionToException + fromException = postgresqlExceptionFromException + -- | Exception thrown if 'query' is used to perform an @INSERT@-like -- operation, or 'execute' is used to perform a @SELECT@-like operation. @@ -101,7 +125,9 @@ data QueryError = QueryError { , qeQuery :: Query } deriving (Eq, Show, Typeable) -instance Exception QueryError +instance Exception QueryError where + toException = postgresqlExceptionToException + fromException = postgresqlExceptionFromException -- | Exception thrown if a 'Query' could not be formatted correctly. -- This may occur if the number of \'@?@\' characters in the query @@ -112,7 +138,9 @@ data FormatError = FormatError { , fmtParams :: [ByteString] } deriving (Eq, Show, Typeable) -instance Exception FormatError +instance Exception FormatError where + toException = postgresqlExceptionToException + fromException = postgresqlExceptionFromException data ConnectInfo = ConnectInfo { connectHost :: String diff --git a/test/Exception.hs b/test/Exception.hs new file mode 100644 index 0000000..b7465b0 --- /dev/null +++ b/test/Exception.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Exception (testExceptions) where + +import Database.PostgreSQL.Simple +import Test.Tasty.HUnit (Assertion, assertBool) +import Common (TestEnv) +import Control.Exception (Exception (..), SomeException) +import Data.Maybe (isJust) +import Data.Either (isLeft) +import Control.Exception (throwIO, try) + +testExceptions :: TestEnv -> Assertion +testExceptions _ = do + let sqlError = SqlError + { sqlState = "" + , sqlExecStatus = FatalError + , sqlErrorMsg = "" + , sqlErrorDetail = "" + , sqlErrorHint = "" + } + let sqlEx :: SomeException = toException sqlError + assertBool "SqlError is SomePostgreSqlException" $ isJust (fromException sqlEx :: Maybe SomePostgreSqlException) + assertBool "SqlError is SqlError" $ isJust (fromException sqlEx :: Maybe SqlError) + eSqlError :: Either SqlError () <- try $ throwIO sqlEx + assertBool "Can catch SqlError" $ isLeft eSqlError + eSqlPostgreSqlEx :: Either SomePostgreSqlException () <- try $ throwIO sqlEx + assertBool "Can catch SomePostgreSqlException from SqlError" $ isLeft eSqlPostgreSqlEx + + let formatError = FormatError + { fmtMessage = "" + , fmtQuery = "" + , fmtParams = [] + } + let formatEx :: SomeException = toException formatError + assertBool "FormatError is SomePostgreSqlException" $ isJust (fromException formatEx :: Maybe SomePostgreSqlException) + assertBool "FormatError is FormatError" $ isJust (fromException formatEx :: Maybe FormatError) + eFormatError :: Either FormatError () <- try $ throwIO formatEx + assertBool "Can catch FormatError" $ isLeft eFormatError + eFormatPostreSqlEx :: Either SomePostgreSqlException () <- try $ throwIO formatEx + assertBool "Can catch SomePostgreSqlException from FormatError" $ isLeft eFormatPostreSqlEx + + let queryError = QueryError + { qeMessage = "" + , qeQuery = "" + } + let queryEx :: SomeException = toException queryError + assertBool "QueryError is SomePostgreSqlException" $ isJust (fromException queryEx :: Maybe SomePostgreSqlException) + assertBool "QueryError is QueryError" $ isJust (fromException queryEx :: Maybe QueryError) + eQueryError :: Either QueryError () <- try $ throwIO queryEx + assertBool "Can catch QueryError" $ isLeft eQueryError + eQueryPostgreSqlEx :: Either SomePostgreSqlException () <- try $ throwIO queryEx + assertBool "Can catch SomePostgreSqlException from QueryError" $ isLeft eQueryPostgreSqlEx + + let resultError = Incompatible + { errSQLType = "" + , errSQLTableOid = Nothing + , errSQLField = "" + , errHaskellType = "" + , errMessage = "" + } + let resultEx :: SomeException = toException resultError + assertBool "ResultError is SomePostgreSqlException" $ isJust (fromException resultEx :: Maybe SomePostgreSqlException) + assertBool "ResultError is ResultError" $ isJust (fromException resultEx :: Maybe ResultError) + eResultEx :: Either ResultError () <- try $ throwIO resultEx + assertBool "Can catch ResultError" $ isLeft eResultEx + eResultPostgreSqlEx :: Either SomePostgreSqlException () <- try $ throwIO resultEx + assertBool "Can catch SomePostgreSqlException from ResultError" $ isLeft eResultPostgreSqlEx diff --git a/test/Main.hs b/test/Main.hs index 0cb7b35..32eb230 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -55,6 +55,7 @@ import Notify import Serializable import Time import Interval +import Exception (testExceptions) tests :: TestEnv -> TestTree tests env = testGroup "tests" @@ -84,6 +85,7 @@ tests env = testGroup "tests" , testCase "2-ary generic" . testGeneric2 , testCase "3-ary generic" . testGeneric3 , testCase "Timeout" . testTimeout + , testCase "Exceptions" . testExceptions ] testBytea :: TestEnv -> TestTree