diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,13 @@ +### Version 0.7.0.0 (2023-07-31) + + * Remove Eq Null instance. (Future `base` may break it, we remove it profilacticly). + * Use `postgresql-libpq >=0.10.0.0`. It includes critical fixes, + by using `postgresql-simple >=0.7` you won't get older `postgresql-libpq`. + * Drop support for GHC prior 8.6 + * Added a class for `postgresql-simple` exceptions: `SomePostgreSqlException`. + This allows to catch all `postgresql-simple` exceptions at once. + (c.f. `AsyncException` in `base). + ### Version 0.6.5.1 (2023-07-09) * Support `aeson-2.2.0.0` diff --git a/postgresql-simple.cabal b/postgresql-simple.cabal --- a/postgresql-simple.cabal +++ b/postgresql-simple.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 name: postgresql-simple -version: 0.6.5.1 +version: 0.7.0.0 synopsis: Mid-Level PostgreSQL client library description: Mid-Level PostgreSQL client library, forked from mysql-simple. @@ -23,13 +23,7 @@ test/results/unique-constraint-violation.expected tested-with: - GHC ==7.6.3 - || ==7.8.4 - || ==7.10.3 - || ==8.0.2 - || ==8.2.2 - || ==8.4.4 - || ==8.6.5 + GHC ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 @@ -81,34 +75,25 @@ -- GHC bundled libs build-depends: - base >=4.6.0.0 && <4.19 - , bytestring >=0.10.0.0 && <0.12 - , containers >=0.5.0.0 && <0.7 - , template-haskell >=2.8.0.0 && <2.21 - , text >=1.2.3.0 && <1.3 || >=2.0 && <2.1 + base >=4.12.0.0 && <4.19 + , bytestring >=0.10.8.2 && <0.12 + , containers >=0.6.0.1 && <0.7 + , template-haskell >=2.14.0.0 && <2.21 + , text >=1.2.3.0 && <1.3 || >=2.0 && <2.1 , time-compat >=1.9.5 && <1.12 - , transformers >=0.3.0.0 && <0.7 + , transformers >=0.5.6.2 && <0.7 -- Other dependencies build-depends: - aeson >=1.4.1.0 && <1.6 || >=2.0.0.0 && <2.3 - , attoparsec >=0.13.2.2 && <0.15 - , bytestring-builder >=0.10.8.1.0 && <0.11 - , case-insensitive >=1.2.0.11 && <1.3 - , hashable >=1.2.7.0 && <1.5 - , Only >=0.1 && <0.1.1 - , postgresql-libpq >=0.9.4.3 && <0.10 - , scientific >=0.3.6.2 && <0.4 - , uuid-types >=1.0.3 && <1.1 - , vector >=0.12.0.1 && <0.14 - - if !impl(ghc >=8.0) - build-depends: - fail >=4.9.0.0 && <4.10 - , semigroups >=0.18.5 && <0.21 - - if !impl(ghc >=7.6) - build-depends: ghc-prim + aeson >=2.1.2.1 && <2.3 + , attoparsec >=0.14.4 && <0.15 + , case-insensitive >=1.2.1.0 && <1.3 + , hashable >=1.4.3.0 && <1.5 + , Only >=0.1 && <0.1.1 + , postgresql-libpq >=0.10.0.0 && <0.11 + , scientific >=0.3.7.0 && <0.4 + , uuid-types >=1.0.5 && <1.1 + , vector >=0.13.0.0 && <0.14 default-extensions: BangPatterns @@ -123,15 +108,7 @@ type: git location: http://github.com/haskellari/postgresql-simple -source-repository this - type: git - location: http://github.com/haskellari/postgresql-simple - tag: v0.6.3 - test-suite inspection - if !impl(ghc >=8.0) - buildable: False - default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: test @@ -151,10 +128,11 @@ main-is: Main.hs other-modules: Common + Exception + Interval Notify Serializable Time - Interval ghc-options: -threaded ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind @@ -183,9 +161,6 @@ , text , time-compat , vector - - if !impl(ghc >=7.6) - build-depends: ghc-prim benchmark select default-language: Haskell2010 diff --git a/src/Database/PostgreSQL/Simple.hs b/src/Database/PostgreSQL/Simple.hs --- a/src/Database/PostgreSQL/Simple.hs +++ b/src/Database/PostgreSQL/Simple.hs @@ -64,6 +64,7 @@ , Only(..) , (:.)(..) -- ** Exceptions + , SomePostgreSqlException(..) , SqlError(..) , PQ.ExecStatus(..) , FormatError(..) diff --git a/src/Database/PostgreSQL/Simple/Compat.hs b/src/Database/PostgreSQL/Simple/Compat.hs --- a/src/Database/PostgreSQL/Simple/Compat.hs +++ b/src/Database/PostgreSQL/Simple/Compat.hs @@ -12,36 +12,13 @@ ) where import qualified Control.Exception as E -import Data.Monoid import Data.ByteString (ByteString) -#if MIN_VERSION_bytestring(0,10,0) import Data.ByteString.Lazy (toStrict) -#else -import qualified Data.ByteString as B -import Data.ByteString.Lazy (toChunks) -#endif import Data.ByteString.Builder (Builder, toLazyByteString) - -#if MIN_VERSION_scientific(0,3,0) import Data.Text.Lazy.Builder.Scientific (scientificBuilder) -#else -import Data.Scientific (scientificBuilder) -#endif - -#if __GLASGOW_HASKELL__ >= 702 import System.IO.Unsafe (unsafeDupablePerformIO) -#elif __GLASGOW_HASKELL__ >= 611 -import GHC.IO (unsafeDupablePerformIO) -#else -import GHC.IOBase (unsafeDupablePerformIO) -#endif - import Data.Fixed (Pico) -#if MIN_VERSION_base(4,7,0) import Data.Fixed (Fixed(MkFixed)) -#else -import Unsafe.Coerce (unsafeCoerce) -#endif -- | Like 'E.mask', but backported to base before version 4.3.0. -- @@ -51,44 +28,14 @@ -- 'withTransactionMode' function calls the restore callback only once, so we -- don't need that polymorphism. mask :: ((IO a -> IO a) -> IO b) -> IO b -#if MIN_VERSION_base(4,3,0) mask io = E.mask $ \restore -> io restore -#else -mask io = do - b <- E.blocked - E.block $ io $ \m -> if b then m else E.unblock m -#endif {-# INLINE mask #-} -#if !MIN_VERSION_base(4,5,0) -infixr 6 <> - -(<>) :: Monoid m => m -> m -> m -(<>) = mappend -{-# INLINE (<>) #-} -#endif - toByteString :: Builder -> ByteString -#if MIN_VERSION_bytestring(0,10,0) toByteString x = toStrict (toLazyByteString x) -#else -toByteString x = B.concat (toChunks (toLazyByteString x)) -#endif -#if MIN_VERSION_base(4,7,0) - toPico :: Integer -> Pico toPico = MkFixed fromPico :: Pico -> Integer fromPico (MkFixed i) = i - -#else - -toPico :: Integer -> Pico -toPico = unsafeCoerce - -fromPico :: Pico -> Integer -fromPico = unsafeCoerce - -#endif diff --git a/src/Database/PostgreSQL/Simple/Copy.hs b/src/Database/PostgreSQL/Simple/Copy.hs --- a/src/Database/PostgreSQL/Simple/Copy.hs +++ b/src/Database/PostgreSQL/Simple/Copy.hs @@ -86,12 +86,8 @@ PQ.TuplesOk -> err PQ.CopyOut -> return () PQ.CopyIn -> return () -#if MIN_VERSION_postgresql_libpq(0,9,3) PQ.CopyBoth -> errMsg "COPY BOTH is not supported" -#endif -#if MIN_VERSION_postgresql_libpq(0,9,2) PQ.SingleTuple -> errMsg "single-row mode is not supported" -#endif PQ.BadResponse -> throwResultError funcName result status PQ.NonfatalError -> throwResultError funcName result status PQ.FatalError -> throwResultError funcName result status diff --git a/src/Database/PostgreSQL/Simple/Errors.hs b/src/Database/PostgreSQL/Simple/Errors.hs --- a/src/Database/PostgreSQL/Simple/Errors.hs +++ b/src/Database/PostgreSQL/Simple/Errors.hs @@ -25,7 +25,6 @@ ) where -import Control.Applicative import Control.Exception as E import Data.Attoparsec.ByteString.Char8 @@ -60,7 +59,9 @@ 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 --- a/src/Database/PostgreSQL/Simple/FromField.hs +++ b/src/Database/PostgreSQL/Simple/FromField.hs @@ -118,7 +118,7 @@ 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) @@ -154,11 +154,7 @@ import Data.Scientific (Scientific) import GHC.Real (infinity, notANumber) -#if MIN_VERSION_aeson(2,1,2) import qualified Data.Aeson.Types as JSON -#else -import qualified Data.Aeson.Internal as JSON -#endif -- | Exception thrown if conversion from a SQL value to a Haskell -- value fails. @@ -186,7 +182,9 @@ -- 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/HStore/Implementation.hs b/src/Database/PostgreSQL/Simple/HStore/Implementation.hs --- a/src/Database/PostgreSQL/Simple/HStore/Implementation.hs +++ b/src/Database/PostgreSQL/Simple/HStore/Implementation.hs @@ -22,9 +22,6 @@ import qualified Data.ByteString.Builder as BU import Data.ByteString.Internal (c2w, w2c) import qualified Data.ByteString.Lazy as BL -#if !MIN_VERSION_bytestring(0,10,0) -import qualified Data.ByteString.Lazy.Internal as BL (foldrChunks) -#endif import Data.Map(Map) import qualified Data.Map as Map import Data.Text(Text) @@ -69,9 +66,6 @@ instance Monoid HStoreBuilder where mempty = Empty -#if !(MIN_VERSION_base(4,11,0)) - mappend = (<>) -#endif class ToHStoreText a where toHStoreText :: a -> HStoreText diff --git a/src/Database/PostgreSQL/Simple/Internal.hs b/src/Database/PostgreSQL/Simple/Internal.hs --- 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 #-} ------------------------------------------------------------------------------ -- | @@ -34,7 +36,6 @@ import qualified Data.IntMap as IntMap import Data.IORef import Data.Maybe(fromMaybe) -import Data.Monoid import Data.String import qualified Data.Text as T import qualified Data.Text.Encoding as TE @@ -82,6 +83,25 @@ 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 @@ -93,8 +113,11 @@ 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. data QueryError = QueryError { @@ -102,7 +125,9 @@ , 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 @@ -113,7 +138,9 @@ , fmtParams :: [ByteString] } deriving (Eq, Show, Typeable) -instance Exception FormatError +instance Exception FormatError where + toException = postgresqlExceptionToException + fromException = postgresqlExceptionFromException data ConnectInfo = ConnectInfo { connectHost :: String @@ -490,9 +517,6 @@ Errors _ -> (oka <|>) <$> runConversion mb conn instance Monad Conversion where -#if !(MIN_VERSION_base(4,8,0)) - return = pure -#endif m >>= f = Conversion $ \conn -> do oka <- runConversion m conn case oka of diff --git a/src/Database/PostgreSQL/Simple/Internal/PQResultUtils.hs b/src/Database/PostgreSQL/Simple/Internal/PQResultUtils.hs --- a/src/Database/PostgreSQL/Simple/Internal/PQResultUtils.hs +++ b/src/Database/PostgreSQL/Simple/Internal/PQResultUtils.hs @@ -76,12 +76,8 @@ PQ.CommandOk -> queryErr "query resulted in a command response (did you mean to use `execute` or forget a RETURNING?)" PQ.CopyOut -> queryErr "query: COPY TO is not supported" PQ.CopyIn -> queryErr "query: COPY FROM is not supported" -#if MIN_VERSION_postgresql_libpq(0,9,3) PQ.CopyBoth -> queryErr "query: COPY BOTH is not supported" -#endif -#if MIN_VERSION_postgresql_libpq(0,9,2) PQ.SingleTuple -> queryErr "query: single-row mode is not supported" -#endif PQ.BadResponse -> throwResultError "query" result status PQ.NonfatalError -> throwResultError "query" result status PQ.FatalError -> throwResultError "query" result status diff --git a/src/Database/PostgreSQL/Simple/Notification.hs b/src/Database/PostgreSQL/Simple/Notification.hs --- a/src/Database/PostgreSQL/Simple/Notification.hs +++ b/src/Database/PostgreSQL/Simple/Notification.hs @@ -47,8 +47,6 @@ #if defined(mingw32_HOST_OS) import Control.Concurrent ( threadDelay ) -#elif !MIN_VERSION_base(4,7,0) -import Control.Concurrent ( threadWaitRead ) #else import GHC.Conc ( atomically ) import Control.Concurrent ( threadWaitReadSTM ) @@ -94,21 +92,6 @@ -- with async exceptions, whereas threadDelay can. Just _fd -> do return (threadDelay 1000000 >> loop) -#elif !MIN_VERSION_base(4,7,0) - -- Technically there's a race condition that is usually benign. - -- If the connection is closed or reset after we drop the - -- lock, and then the fd index is reallocated to a new - -- descriptor before we call threadWaitRead, then - -- we could end up waiting on the wrong descriptor. - -- - -- Now, if the descriptor becomes readable promptly, then - -- it's no big deal as we'll wake up and notice the change - -- on the next iteration of the loop. But if are very - -- unlucky, then we could end up waiting a long time. - Just fd -> do - return $ do - threadWaitRead fd `catch` (throwIO . setIOErrorLocation) - loop #else -- This case fixes the race condition above. By registering -- our interest in the descriptor before we drop the lock, diff --git a/src/Database/PostgreSQL/Simple/Ok.hs b/src/Database/PostgreSQL/Simple/Ok.hs --- a/src/Database/PostgreSQL/Simple/Ok.hs +++ b/src/Database/PostgreSQL/Simple/Ok.hs @@ -72,10 +72,6 @@ mplus = (<|>) instance Monad Ok where -#if !(MIN_VERSION_base(4,8,0)) - return = pure -#endif - Errors es >>= _ = Errors es Ok a >>= f = f a diff --git a/src/Database/PostgreSQL/Simple/ToField.hs b/src/Database/PostgreSQL/Simple/ToField.hs --- a/src/Database/PostgreSQL/Simple/ToField.hs +++ b/src/Database/PostgreSQL/Simple/ToField.hs @@ -59,11 +59,7 @@ import qualified Database.PostgreSQL.LibPQ as PQ import Database.PostgreSQL.Simple.Time import Data.Scientific (Scientific) -#if MIN_VERSION_scientific(0,3,0) import Data.Text.Lazy.Builder.Scientific (scientificBuilder) -#else -import Data.Scientific (scientificBuilder) -#endif import Foreign.C.Types (CUInt(..)) -- | How to render an element when substituting it into a query. diff --git a/src/Database/PostgreSQL/Simple/Types.hs b/src/Database/PostgreSQL/Simple/Types.hs --- a/src/Database/PostgreSQL/Simple/Types.hs +++ b/src/Database/PostgreSQL/Simple/Types.hs @@ -50,10 +50,6 @@ data Null = Null deriving (Read, Show, Typeable) -instance Eq Null where - _ == _ = False - _ /= _ = False - -- | A placeholder for the PostgreSQL @DEFAULT@ value. data Default = Default deriving (Read, Show, Typeable) @@ -97,9 +93,6 @@ instance Monoid Query where mempty = Query B.empty -#if !(MIN_VERSION_base(4,11,0)) - mappend = (<>) -#endif -- | Wrap a list of values for use in an @IN@ clause. Replaces a -- single \"@?@\" character with a parenthesized list of rendered diff --git a/test/Exception.hs b/test/Exception.hs new file mode 100644 --- /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 --- a/test/Main.hs +++ b/test/Main.hs @@ -55,6 +55,7 @@ import Serializable import Time import Interval +import Exception (testExceptions) tests :: TestEnv -> TestTree tests env = testGroup "tests" @@ -84,6 +85,7 @@ , testCase "2-ary generic" . testGeneric2 , testCase "3-ary generic" . testGeneric3 , testCase "Timeout" . testTimeout + , testCase "Exceptions" . testExceptions ] testBytea :: TestEnv -> TestTree