Merge pull request #124 from haskellari/exception-class

Add superclass for all postgresql exceptions

postgresql-simple.cabal

@@ -128,6 +128,7 @@ test-suite test
   main-is:            Main.hs
   other-modules:
     Common
+    Exception
     Interval
     Notify
     Serializable

src/Database/PostgreSQL/Simple.hs

@@ -64,6 +64,7 @@ module Database.PostgreSQL.Simple
     , Only(..)
     , (:.)(..)
     -- ** Exceptions
+    , SomePostgreSqlException(..)
     , SqlError(..)
     , PQ.ExecStatus(..)
     , FormatError(..)

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

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

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

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

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