postgresql-simple 0.6.2 → 0.6.3
raw patch · 10 files changed
+344/−175 lines, 10 filesdep ~bytestringdep ~time
Dependency ranges changed: bytestring, time
Files
- CHANGES.md +22/−0
- postgresql-simple.cabal +134/−135
- src/Database/PostgreSQL/Simple.hs +1/−1
- src/Database/PostgreSQL/Simple/FromField.hs +44/−18
- src/Database/PostgreSQL/Simple/Newtypes.hs +49/−0
- src/Database/PostgreSQL/Simple/SqlQQ.hs +1/−1
- src/Database/PostgreSQL/Simple/ToField.hs +11/−0
- src/Database/PostgreSQL/Simple/Transaction.hs +16/−12
- test/Inspection.hs +6/−1
- test/Main.hs +60/−7
CHANGES.md view
@@ -1,3 +1,25 @@+### Version 0.6.3 (2020-11-15)++ * Add `fromFieldJSONByteString`+ Thanks to tomjaguarpaw for the implementation+ https://github.com/haskellari/postgresql-simple/pull/47+ * Add `attoFieldParser`+ Thanks to Victor Nawothnig for the implementation+ https://github.com/haskellari/postgresql-simple/pull/45+ * Add `Identity` and `Const` instance+ Thanks to Cary Robbins for the implementation+ https://github.com/haskellari/postgresql-simple/pull/46+ * Add `withTransactionModeRetry'`, a variant of `withTransactionModeRetry`+ for all exception types.+ Thanks to Elliot Cameron for the implementation+ https://github.com/haskellari/postgresql-simple/pull/42+ * Fix spurious aborts when retrying transactions+ Thanks to Elliot Cameron for the implementation+ https://github.com/haskellari/postgresql-simple/pull/34+ * Add `Database.PostgreSQL.Simple.Newtypes` module+ with `Aeson` newtype.+ https://github.com/haskellari/postgresql-simple/pull/55+ ### Version 0.6.2 (2019-04-26) * Define `MonadFail Ok`.
postgresql-simple.cabal view
@@ -1,194 +1,193 @@-Cabal-version: 1.12-Name: postgresql-simple-Version: 0.6.2+cabal-version: 1.12+name: postgresql-simple+version: 0.6.3+synopsis: Mid-Level PostgreSQL client library+description:+ Mid-Level PostgreSQL client library, forked from mysql-simple. -Synopsis: Mid-Level PostgreSQL client library-Description:- Mid-Level PostgreSQL client library, forked from mysql-simple.-License: BSD3-License-file: LICENSE-Author: Bryan O'Sullivan, Leon P Smith-Maintainer: Oleg Grenrus <oleg.grenrus@iki.fi>-Copyright: (c) 2011 MailRank, Inc.- (c) 2011-2018 Leon P Smith- (c) 2018-2019 Oleg Grenrus-Category: Database-Build-type: Simple+license: BSD3+license-file: LICENSE+author: Bryan O'Sullivan, Leon P Smith+maintainer: Oleg Grenrus <oleg.grenrus@iki.fi>+copyright:+ (c) 2011 MailRank, Inc.+ (c) 2011-2018 Leon P Smith+ (c) 2018-2020 Oleg Grenrus +category: Database+build-type: Simple extra-source-files:- CONTRIBUTORS CHANGES.md+ CONTRIBUTORS test/results/malformed-input.expected 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- || == 8.8.1--Library- default-language: Haskell2010- hs-source-dirs: src- Exposed-modules:- Database.PostgreSQL.Simple- Database.PostgreSQL.Simple.Arrays- Database.PostgreSQL.Simple.Copy- Database.PostgreSQL.Simple.Cursor- Database.PostgreSQL.Simple.FromField- Database.PostgreSQL.Simple.FromRow- Database.PostgreSQL.Simple.LargeObjects- Database.PostgreSQL.Simple.HStore- Database.PostgreSQL.Simple.HStore.Internal- Database.PostgreSQL.Simple.Notification- Database.PostgreSQL.Simple.Ok- Database.PostgreSQL.Simple.Range- Database.PostgreSQL.Simple.SqlQQ- Database.PostgreSQL.Simple.Time- Database.PostgreSQL.Simple.Time.Internal- Database.PostgreSQL.Simple.ToField- Database.PostgreSQL.Simple.ToRow- Database.PostgreSQL.Simple.Transaction- Database.PostgreSQL.Simple.TypeInfo- Database.PostgreSQL.Simple.TypeInfo.Macro- Database.PostgreSQL.Simple.TypeInfo.Static- Database.PostgreSQL.Simple.Types- Database.PostgreSQL.Simple.Errors- Database.PostgreSQL.Simple.Vector- Database.PostgreSQL.Simple.Vector.Unboxed+ GHC ==7.6.3+ || ==7.8.4+ || ==7.10.3+ || ==8.0.2+ || ==8.2.2+ || ==8.4.4+ || ==8.6.5+ || ==8.8.4+ || ==8.10.2 --- Other-modules:- Database.PostgreSQL.Simple.Internal+library+ default-language: Haskell2010+ hs-source-dirs: src+ exposed-modules:+ Database.PostgreSQL.Simple+ Database.PostgreSQL.Simple.Arrays+ Database.PostgreSQL.Simple.Copy+ Database.PostgreSQL.Simple.Cursor+ Database.PostgreSQL.Simple.Errors+ Database.PostgreSQL.Simple.FromField+ Database.PostgreSQL.Simple.FromRow+ Database.PostgreSQL.Simple.HStore+ Database.PostgreSQL.Simple.HStore.Internal+ Database.PostgreSQL.Simple.Internal+ Database.PostgreSQL.Simple.LargeObjects+ Database.PostgreSQL.Simple.Newtypes+ Database.PostgreSQL.Simple.Notification+ Database.PostgreSQL.Simple.Ok+ Database.PostgreSQL.Simple.Range+ Database.PostgreSQL.Simple.SqlQQ+ Database.PostgreSQL.Simple.Time+ Database.PostgreSQL.Simple.Time.Internal+ Database.PostgreSQL.Simple.ToField+ Database.PostgreSQL.Simple.ToRow+ Database.PostgreSQL.Simple.Transaction+ Database.PostgreSQL.Simple.TypeInfo+ Database.PostgreSQL.Simple.TypeInfo.Macro+ Database.PostgreSQL.Simple.TypeInfo.Static+ Database.PostgreSQL.Simple.Types+ Database.PostgreSQL.Simple.Vector+ Database.PostgreSQL.Simple.Vector.Unboxed - Other-modules:- Database.PostgreSQL.Simple.Compat- Database.PostgreSQL.Simple.HStore.Implementation- Database.PostgreSQL.Simple.Internal.PQResultUtils- Database.PostgreSQL.Simple.Time.Implementation- Database.PostgreSQL.Simple.Time.Internal.Parser- Database.PostgreSQL.Simple.Time.Internal.Printer- Database.PostgreSQL.Simple.TypeInfo.Types+ -- Other-modules:+ other-modules:+ Database.PostgreSQL.Simple.Compat+ Database.PostgreSQL.Simple.HStore.Implementation+ Database.PostgreSQL.Simple.Internal.PQResultUtils+ Database.PostgreSQL.Simple.Time.Implementation+ Database.PostgreSQL.Simple.Time.Internal.Parser+ Database.PostgreSQL.Simple.Time.Internal.Printer+ Database.PostgreSQL.Simple.TypeInfo.Types -- GHC bundled libs- Build-depends:- base >=4.6.0.0 && <4.13- , bytestring >=0.10.0.0 && <0.11- , containers >=0.5.0.0 && <0.7- , time >=1.4.0.1 && <1.9- , transformers >=0.3.0.0 && <0.6- , template-haskell >=2.8.0.0 && <2.15- , text >=1.2.3.0 && <1.3+ build-depends:+ base >=4.6.0.0 && <4.15+ , bytestring >=0.10.0.0 && <0.12+ , containers >=0.5.0.0 && <0.7+ , template-haskell >=2.8.0.0 && <2.17+ , text >=1.2.3.0 && <1.3+ , time >=1.4.0.1 && <1.12+ , transformers >=0.3.0.0 && <0.6 -- Other dependencies- Build-depends:- aeson >=1.4.1.0 && <1.5- , attoparsec >=0.13.2.2 && <0.14- , bytestring-builder >=0.10.8.1.0 && <0.11- , case-insensitive >=1.2.0.11 && <1.3- , hashable >=1.2.7.0 && <1.3- , Only >=0.1 && <0.1.1- , postgresql-libpq >=0.9.4.2 && < 0.10- , uuid-types >=1.0.3 && <1.1- , scientific >=0.3.6.2 && <0.4- , vector >=0.12.0.1 && <0.13+ build-depends:+ aeson >=1.4.1.0 && <1.6+ , attoparsec >=0.13.2.2 && <0.14+ , bytestring-builder >=0.10.8.1.0 && <0.11+ , case-insensitive >=1.2.0.11 && <1.3+ , hashable >=1.2.7.0 && <1.4+ , Only >=0.1 && <0.1.1+ , postgresql-libpq >=0.9.4.2 && <0.10+ , scientific >=0.3.6.2 && <0.4+ , uuid-types >=1.0.3 && <1.1+ , vector >=0.12.0.1 && <0.13 - if !impl(ghc >= 8.0)- Build-depends:- fail >=4.9.0.0 && <4.10,- semigroups >=0.18.5 && <0.19+ if !impl(ghc >=8.0)+ build-depends:+ fail >=4.9.0.0 && <4.10+ , semigroups >=0.18.5 && <0.20 - if !impl(ghc >= 7.6)- Build-depends:- ghc-prim+ if !impl(ghc >=7.6)+ build-depends: ghc-prim default-extensions:+ BangPatterns DoAndIfThenElse OverloadedStrings- BangPatterns- ViewPatterns TypeOperators+ ViewPatterns - ghc-options: -Wall -fno-warn-name-shadowing+ ghc-options: -Wall -fno-warn-name-shadowing source-repository head type: git- location: http://github.com/phadej/postgresql-simple+ location: http://github.com/haskellari/postgresql-simple source-repository this type: git- location: http://github.com/phadej/postgresql-simple- tag: v0.6+ location: http://github.com/haskellari/postgresql-simple+ tag: v0.6.3 test-suite inspection- if !impl(ghc >= 8.0)+ if !impl(ghc >=8.0) buildable: False default-language: Haskell2010- type: exitcode-stdio-1.0- hs-source-dirs: test- main-is: Inspection.hs+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Inspection.hs build-depends: base , inspection-testing >=0.4.1.1 && <0.5- , postgresql-simple , postgresql-libpq+ , postgresql-simple , tasty , tasty-hunit test-suite test- default-language: Haskell2010- type: exitcode-stdio-1.0-- hs-source-dirs: test- main-is: Main.hs+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs other-modules: Common Notify Serializable Time - ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind-+ ghc-options: -threaded+ ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind default-extensions: NamedFieldPuns OverloadedStrings+ PatternGuards Rank2Types RecordWildCards- PatternGuards ScopedTypeVariables - build-depends: base- , aeson- , base16-bytestring- , bytestring- , containers- , cryptohash-md5 >= 0.11.100.1 && <0.12- , filepath- , tasty- , tasty-hunit- , tasty-golden- , HUnit- , postgresql-simple- , text- , time- , vector- , case-insensitive+ build-depends:+ aeson+ , base+ , base16-bytestring+ , bytestring+ , case-insensitive+ , containers+ , cryptohash-md5 >=0.11.100.1 && <0.12+ , filepath+ , HUnit+ , postgresql-simple+ , tasty+ , tasty-golden+ , tasty-hunit+ , text+ , time+ , vector - if !impl(ghc >= 7.6)- build-depends:- ghc-prim+ if !impl(ghc >=7.6)+ build-depends: ghc-prim benchmark select default-language: Haskell2010 type: exitcode-stdio-1.0-- hs-source-dirs: bench- main-is: Select.hs-- build-depends: base- , postgresql-simple- , vector+ hs-source-dirs: bench+ main-is: Select.hs+ build-depends:+ base+ , postgresql-simple+ , vector
src/Database/PostgreSQL/Simple.hs view
@@ -338,7 +338,7 @@ -- @ -- executeMany c [sql| -- UPDATE sometable--- SET sometable.y = upd.y+-- SET y = upd.y -- FROM (VALUES (?,?)) as upd(x,y) -- WHERE sometable.x = upd.x -- |] [(1, \"hello\"),(2, \"world\")]
src/Database/PostgreSQL/Simple/FromField.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} {-# LANGUAGE PatternGuards, ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE PolyKinds #-} {- | Module: Database.PostgreSQL.Simple.FromField@@ -106,14 +107,16 @@ , PQ.Oid(..) , PQ.Format(..) , pgArrayFieldParser+ , attoFieldParser , optionalField , fromJSONField+ , fromFieldJSONByteString ) where #include "MachDeps.h" -import Control.Applicative ( (<|>), (<$>), pure, (*>), (<*) )+import Control.Applicative ( Const(Const), (<|>), (<$>), pure, (*>), (<*) ) import Control.Concurrent.MVar (MVar, newMVar) import Control.Exception (Exception) import qualified Data.Aeson as JSON@@ -122,6 +125,7 @@ import Data.Attoparsec.ByteString.Char8 hiding (Result) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B+import Data.Functor.Identity (Identity(Identity)) import Data.Int (Int16, Int32, Int64) import Data.IORef (IORef, newIORef) import Data.Ratio (Ratio)@@ -244,9 +248,11 @@ then Nothing else Just x --- | If the column has a table associated with it, this returns the number--- off the associated table column. Numbering starts from 0. Analogous--- to libpq's @PQftablecol@.+-- | If the column has a table associated with it, this returns the+-- number of the associated table column. Table columns have+-- nonzero numbers. Zero is returned if the specified column is not+-- a simple reference to a table column, or when using pre-3.0+-- protocol. Analogous to libpq's @PQftablecol@. tableColumn :: Field -> Int tableColumn Field{..} = fromCol (unsafeDupablePerformIO (PQ.ftablecol result column))@@ -265,6 +271,12 @@ | typeOid f /= TI.voidOid = returnError Incompatible f "" | otherwise = pure () +instance (FromField a) => FromField (Const a b) where+ fromField f bs = Const <$> fromField f bs++instance (FromField a) => FromField (Identity a) where+ fromField f bs = Identity <$> fromField f bs+ -- | For dealing with null values. Compatible with any postgresql type -- compatible with type @a@. Note that the type is not checked if -- the value is null, although it is inadvisable to rely on this@@ -311,11 +323,11 @@ -- | int2 instance FromField Int16 where- fromField = atto ok16 $ signed decimal+ fromField = attoFieldParser ok16 $ signed decimal -- | int2, int4 instance FromField Int32 where- fromField = atto ok32 $ signed decimal+ fromField = attoFieldParser ok32 $ signed decimal #if WORD_SIZE_IN_BITS < 64 -- | int2, int4, and if compiled as 64-bit code, int8 as well.@@ -325,36 +337,36 @@ -- This library was compiled as 64-bit code. #endif instance FromField Int where- fromField = atto okInt $ signed decimal+ fromField = attoFieldParser okInt $ signed decimal -- | int2, int4, int8 instance FromField Int64 where- fromField = atto ok64 $ signed decimal+ fromField = attoFieldParser ok64 $ signed decimal -- | int2, int4, int8 instance FromField Integer where- fromField = atto ok64 $ signed decimal+ fromField = attoFieldParser ok64 $ signed decimal -- | int2, float4 (Uses attoparsec's 'double' routine, for -- better accuracy convert to 'Scientific' or 'Rational' first) instance FromField Float where- fromField = atto ok (realToFrac <$> pg_double)+ fromField = attoFieldParser ok (realToFrac <$> pg_double) where ok = eq TI.float4Oid \/ eq TI.int2Oid -- | int2, int4, float4, float8 (Uses attoparsec's 'double' routine, for -- better accuracy convert to 'Scientific' or 'Rational' first) instance FromField Double where- fromField = atto ok pg_double+ fromField = attoFieldParser ok pg_double where ok = eq TI.float4Oid \/ eq TI.float8Oid \/ eq TI.int2Oid \/ eq TI.int4Oid -- | int2, int4, int8, float4, float8, numeric instance FromField (Ratio Integer) where- fromField = atto ok pg_rational+ fromField = attoFieldParser ok pg_rational where ok = eq TI.float4Oid \/ eq TI.float8Oid \/ eq TI.int2Oid \/ eq TI.int4Oid \/ eq TI.int8Oid \/ eq TI.numericOid -- | int2, int4, int8, float4, float8, numeric instance FromField Scientific where- fromField = atto ok rational+ fromField = attoFieldParser ok rational where ok = eq TI.float4Oid \/ eq TI.float8Oid \/ eq TI.int2Oid \/ eq TI.int4Oid \/ eq TI.int8Oid \/ eq TI.numericOid unBinary :: Binary t -> t@@ -382,7 +394,7 @@ -- | oid instance FromField PQ.Oid where- fromField f dat = PQ.Oid <$> atto (== TI.oidOid) decimal f dat+ fromField f dat = PQ.Oid <$> attoFieldParser (== TI.oidOid) decimal f dat -- | bytea, name, text, \"char\", bpchar, varchar, unknown instance FromField LB.ByteString where@@ -558,6 +570,8 @@ Right val -> pure val -- | Return the JSON ByteString directly+--+-- @since 0.6.3 fromFieldJSONByteString :: Field -> Maybe ByteString -> Conversion ByteString fromFieldJSONByteString f mbs = if typeOid f /= TI.jsonOid && typeOid f /= TI.jsonbOid@@ -659,10 +673,22 @@ (show (typeOf (undefined :: a))) msg -atto :: forall a. (Typeable a)- => Compat -> Parser a -> Field -> Maybe ByteString- -> Conversion a-atto types p0 f dat = doFromField f types (go p0) dat+-- | Construct a field parser from an attoparsec parser. An 'Incompatible' error is thrown if the+-- PostgreSQL oid does not match the specified predicate.+--+-- @+-- instance FromField Int16 where+-- fromField = attoFieldParser ok16 (signed decimal)+-- @+--+-- @since 0.6.3+attoFieldParser :: forall a. (Typeable a)+ => (PQ.Oid -> Bool)+ -- ^ Predicate for whether the postgresql type oid is compatible with this parser+ -> Parser a+ -- ^ An attoparsec parser.+ -> FieldParser a+attoFieldParser types p0 f dat = doFromField f types (go p0) dat where go :: Parser a -> ByteString -> Conversion a go p s =
+ src/Database/PostgreSQL/Simple/Newtypes.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveDataTypeable #-}+-- | Module with newtypes suitable to usage with @DerivingVia@ or standalone.+--+-- The newtypes are named after packages they wrap.+module Database.PostgreSQL.Simple.Newtypes (+ Aeson (..), getAeson,+) where++import Data.Typeable (Typeable)+import Database.PostgreSQL.Simple.ToField (ToField (..))+import Database.PostgreSQL.Simple.FromField (FromField (..), fromJSONField)++import qualified Data.Aeson as Aeson++-------------------------------------------------------------------------------+-- aeson+-------------------------------------------------------------------------------++-- | A newtype wrapper with 'ToField' and 'FromField' instances+-- based on 'Aeson.ToJSON' and 'Aeson.FromJSON' type classes from @aeson@.+--+-- Example using @DerivingVia@:+--+-- @+-- data Foo = Foo Int String+-- deriving stock (Eq, Show, Generic) -- GHC built int+-- deriving anyclass ('Aeson.FromJSON', 'Aeson.ToJSON') -- Derived using GHC Generics+-- deriving ('ToField', 'FromField') via 'Aeson' Foo -- DerivingVia+-- @+--+-- Example using 'Aeson' newtype directly, for more ad-hoc queries+--+-- @+-- execute conn "INSERT INTO tbl (fld) VALUES (?)" (Only ('Aeson' x))+-- @+-- +-- @since 0.6.3+newtype Aeson a = Aeson a+ deriving (Eq, Show, Read, Typeable, Functor)++getAeson :: Aeson a -> a+getAeson (Aeson a) = a++instance Aeson.ToJSON a => ToField (Aeson a) where+ toField = toField . Aeson.encode . getAeson++instance (Aeson.FromJSON a, Typeable a) => FromField (Aeson a) where+ fromField f bs = fmap Aeson (fromJSONField f bs)
src/Database/PostgreSQL/Simple/SqlQQ.hs view
@@ -35,7 +35,7 @@ -- > (beginTime,endTime,string) -- -- This quasiquoter returns a literal string expression of type 'Query',--- and attempts to mimimize whitespace; otherwise the above query would+-- and attempts to minimize whitespace; otherwise the above query would -- consist of approximately half whitespace when sent to the database -- backend. It also recognizes and strips out standard sql comments "--". --
src/Database/PostgreSQL/Simple/ToField.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-} {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}+{-# LANGUAGE PolyKinds #-} ------------------------------------------------------------------------------ -- |@@ -22,6 +23,7 @@ , inQuotes ) where +import Control.Applicative (Const(Const)) import qualified Data.Aeson as JSON import Data.ByteString (ByteString) import Data.ByteString.Builder@@ -30,6 +32,7 @@ , wordDec, word8Dec, word16Dec, word32Dec, word64Dec , floatDec, doubleDec )+import Data.Functor.Identity (Identity(Identity)) import Data.Int (Int8, Int16, Int32, Int64) import Data.List (intersperse) import Data.Monoid (mappend)@@ -99,6 +102,14 @@ instance ToField Action where toField a = a {-# INLINE toField #-}++instance (ToField a) => ToField (Const a b) where+ toField (Const a) = toField a+ {-# INLINE toField #-}++instance (ToField a) => ToField (Identity a) where+ toField (Identity a) = toField a+ {-# INLINE toField #-} instance (ToField a) => ToField (Maybe a) where toField Nothing = renderNull
src/Database/PostgreSQL/Simple/Transaction.hs view
@@ -17,6 +17,7 @@ , withTransactionLevel , withTransactionMode , withTransactionModeRetry+ , withTransactionModeRetry' , withTransactionSerializable , TransactionMode(..) , IsolationLevel(..)@@ -146,31 +147,34 @@ commit conn return r +-- | 'withTransactionModeRetry'' but with the exception type pinned to 'SqlError'.+withTransactionModeRetry :: TransactionMode -> (SqlError -> Bool) -> Connection -> IO a -> IO a+withTransactionModeRetry = withTransactionModeRetry'+ -- | Like 'withTransactionMode', but also takes a custom callback to--- determine if a transaction should be retried if an 'SqlError' occurs.--- If the callback returns True, then the transaction will be retried.--- If the callback returns False, or an exception other than an 'SqlError'+-- determine if a transaction should be retried if an exception occurs.+-- If the callback returns 'True', then the transaction will be retried.+-- If the callback returns 'False', or an exception other than an @e@ -- occurs then the transaction will be rolled back and the exception rethrown. -- -- This is used to implement 'withTransactionSerializable'.-withTransactionModeRetry :: TransactionMode -> (SqlError -> Bool) -> Connection -> IO a -> IO a-withTransactionModeRetry mode shouldRetry conn act =+withTransactionModeRetry' :: forall a e. E.Exception e => TransactionMode -> (e -> Bool) -> Connection -> IO a -> IO a+withTransactionModeRetry' mode shouldRetry conn act = mask $ \restore -> retryLoop $ E.try $ do- a <- restore act+ a <- restore act `E.onException` rollback_ conn commit conn return a where- retryLoop :: IO (Either E.SomeException a) -> IO a+ retryLoop :: IO (Either e a) -> IO a retryLoop act' = do beginMode mode conn r <- act' case r of- Left e -> do- rollback_ conn- case fmap shouldRetry (E.fromException e) of- Just True -> retryLoop act'- _ -> E.throwIO e+ Left e ->+ case shouldRetry e of+ True -> retryLoop act'+ False -> E.throwIO e Right a -> return a
test/Inspection.hs view
@@ -53,7 +53,12 @@ -- byteaOid isn't inlined? , testCase "inlineTypoid" $- assertFailure' $(inspectTest $ 'lhs02 ==- 'rhs02)+#if __GLASGOW_HASKELL__ >= 808+ assertSuccess+#else+ assertFailure'+#endif+ $(inspectTest $ 'lhs02 ==- 'rhs02) ] assertSuccess :: Result -> IO ()
test/Main.hs view
@@ -3,10 +3,19 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE ScopedTypeVariables #-}+#if __GLASGOW_HASKELL__ >= 806+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE DeriveAnyClass #-}+#endif+module Main (main) where+ import Common import Database.PostgreSQL.Simple.Copy+import Database.PostgreSQL.Simple.ToField (ToField) import Database.PostgreSQL.Simple.FromField (FromField) import Database.PostgreSQL.Simple.HStore+import Database.PostgreSQL.Simple.Newtypes import Database.PostgreSQL.Simple.Internal (breakOnSingleQuestionMark) import Database.PostgreSQL.Simple.Types(Query(..),Values(..), PGArray(..)) import qualified Database.PostgreSQL.Simple.Transaction as ST@@ -25,6 +34,7 @@ import Data.Aeson import Data.ByteString (ByteString) import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy.Char8 as BL import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI@@ -36,6 +46,7 @@ import System.FilePath import System.Timeout(timeout) import Data.Time(getCurrentTime, diffUTCTime)+import System.Environment (getEnvironment) import Test.Tasty import Test.Tasty.Golden@@ -57,6 +68,8 @@ , testCase "HStore" . testHStore , testCase "citext" . testCIText , testCase "JSON" . testJSON+ , testCase "Aeson newtype" . testAeson+ , testCase "DerivingVia" . testDerivingVia , testCase "Question mark escape" . testQM , testCase "Savepoint" . testSavepoint , testCase "Unicode" . testUnicode@@ -238,6 +251,40 @@ js' <- query conn "SELECT ?::json" js [js] @?= js' +testAeson :: TestEnv -> Assertion+testAeson TestEnv{..} = do+ roundTrip (Map.fromList [] :: Map Text Text)+ roundTrip (Map.fromList [("foo","bar"),("bar","baz"),("baz","hello")] :: Map Text Text)+ roundTrip (Map.fromList [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")] :: Map Text Text)+ roundTrip (V.fromList [1,2,3,4,5::Int])+ roundTrip ("foo" :: Text)+ roundTrip (42 :: Int)+ where+ roundTrip :: (Eq a, Show a, Typeable a, ToJSON a, FromJSON a)=> a -> Assertion+ roundTrip x = do+ y <- query conn "SELECT ?::json" (Only (Aeson x))+ [Only (Aeson x)] @?= y++testDerivingVia :: TestEnv -> Assertion+testDerivingVia TestEnv{..} = do+#if __GLASGOW_HASKELL__ <806+ return ()+#else+ roundTrip $ DerivingVia1 42 "Meaning of Life"+ where+ roundTrip :: (Eq a, Show a, Typeable a, ToField a, FromField a)=> a -> Assertion+ roundTrip x = do+ y <- query conn "SELECT ?::json" (Only x)+ [Only x] @?= y++data DerivingVia1 = DerivingVia1 Int String+ deriving stock (Eq, Show, Generic)+ deriving anyclass (FromJSON, ToJSON)+ deriving (ToField, FromField) via Aeson DerivingVia1++#endif++ testQM :: TestEnv -> Assertion testQM TestEnv{..} = do -- Just test on a single string@@ -546,18 +593,24 @@ -- -- Note that some tests, such as Notify, use multiple connections, and assume -- that 'testConnect' connects to the same database every time it is called.-testConnect :: IO Connection-testConnect = connectPostgreSQL ""--withTestEnv :: (TestEnv -> IO a) -> IO a-withTestEnv cb =+withTestEnv :: ByteString -> (TestEnv -> IO a) -> IO a+withTestEnv connstr cb = withConn $ \conn -> cb TestEnv { conn = conn , withConn = withConn } where- withConn = bracket testConnect close+ withConn = bracket (connectPostgreSQL connstr) close main :: IO ()-main = withTestEnv $ defaultMain . tests+main = do+ env <- getEnvironment+ case lookup "DATABASE_CONNSTRING" env of+ Nothing -> putStrLn "Set DATABASE_CONNSTRING environment variable"+ Just s -> withTestEnv (BS8.pack (special s)) (defaultMain . tests)+ where+ -- https://www.appveyor.com/docs/services-databases/+ special "appveyor" = "dbname='TestDb' user='postgres' password='Password12!'"+ special "travis" = ""+ special s = s