diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,18 @@ +For the full changelog, see + + +### Version 0.5.2.0 (2016-05-25) + * Significantly improved the error reporting from + `Copy.putCopyData`, thanks to Ben Gamari. + + * Moved the test suite to use `tasty`, with a big thanks + to Ben Gamari. + + * Added `FromField.optionalField`, and updated the documentation + of `FromField.fromJSONField`, as inspired by an email conversation + with Ian Wagner. + + * Updated all links in the haddocks to use https, and added a link + to the documentation of `connectPostgreSQL`. + + * Added a truncated changelog to the source distribution. diff --git a/CONTRIBUTORS b/CONTRIBUTORS --- a/CONTRIBUTORS +++ b/CONTRIBUTORS @@ -30,3 +30,4 @@ Alexey Khudyakov Timo von Holtz Amit Levy +Ben Gamari diff --git a/postgresql-simple.cabal b/postgresql-simple.cabal --- a/postgresql-simple.cabal +++ b/postgresql-simple.cabal @@ -1,5 +1,5 @@ Name: postgresql-simple -Version: 0.5.1.3 +Version: 0.5.2.0 Synopsis: Mid-Level PostgreSQL client library Description: Mid-Level PostgreSQL client library, forked from mysql-simple. @@ -16,6 +16,7 @@ extra-source-files: CONTRIBUTORS + CHANGELOG.md Library hs-source-dirs: src @@ -87,7 +88,7 @@ source-repository this type: git location: http://github.com/lpsmith/postgresql-simple - tag: v0.5.1.3 + tag: v0.5.2.0 test-suite test type: exitcode-stdio-1.0 @@ -115,6 +116,10 @@ , bytestring , containers , cryptohash + , filepath + , tasty + , tasty-hunit + , tasty-golden , HUnit , postgresql-simple , text 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 @@ -9,7 +9,7 @@ -- Stability: experimental -- -- mid-level support for COPY IN and COPY OUT. See --- for +-- for -- more information. -- -- To use this binding, first call 'copy' with an appropriate @@ -224,7 +224,9 @@ consumeResults pqconn let rowCount = P.string "COPY " *> (P.decimal <* P.endOfInput) case P.parseOnly rowCount cmdStat of - Left _ -> fail errCmdStatusFmt + Left _ -> do mmsg <- PQ.errorMessage pqconn + fail $ errCmdStatusFmt + ++ maybe "" (\msg -> "\nConnection error: "++B.unpack msg) mmsg Right n -> return $! n where errCmdStatus = B.unpack funcName ++ ": failed to fetch command 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 @@ -124,7 +124,7 @@ ------------------------------------------------------------------------ -- Error predicates -- --- http://www.postgresql.org/docs/current/static/errcodes-appendix.html +-- https://www.postgresql.org/docs/9.5/static/errcodes-appendix.html isSerializationError :: SqlError -> Bool isSerializationError = isSqlState "40001" 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 @@ -107,6 +107,7 @@ , PQ.Format(..) , pgArrayFieldParser + , optionalField , fromJSONField ) where @@ -268,10 +269,21 @@ -- compatible with type @a@. Note that the type is not checked if -- the value is null, although it is inadvisable to rely on this -- behavior. -instance (FromField a) => FromField (Maybe a) where - fromField _ Nothing = pure Nothing - fromField f bs = Just <$> fromField f bs +instance FromField a => FromField (Maybe a) where + fromField = optionalField fromField +-- | For dealing with SQL @null@ values outside of the 'FromField' class. +-- Alternatively, one could use 'Control.Applicative.optional', but that +-- also turns type and conversion errors into 'Nothing', whereas this is +-- more specific and turns only @null@ values into 'Nothing'. + +optionalField :: FieldParser a -> FieldParser (Maybe a) +optionalField p f mv = + case mv of + Nothing -> pure Nothing + Just _ -> Just <$> p f mv +{-# INLINE optionalField #-} + -- | compatible with any data type, but the value must be null instance FromField Null where fromField _ Nothing = pure Null @@ -559,6 +571,16 @@ -- -- The 'Typeable' constraint is required to show more informative -- error messages when parsing fails. +-- +-- Note that @fromJSONField :: FieldParser ('Maybe' Foo)@ will return +-- @'Nothing'@ on the json @null@ value, and return an exception on SQL @null@ +-- value. Alternatively, one could write @'optionalField' fromJSONField@ +-- that will return @Nothing@ on SQL @null@, and otherwise will call +-- @fromJSONField :: FieldParser Foo@ and then return @'Just'@ the +-- result value, or return its exception. If one would +-- like to return @Nothing@ on both the SQL @null@ and json @null@ values, +-- one way to do it would be to write +-- @\\f mv -> 'Control.Monad.join' '<$>' optionalField fromJSONField f mv@ fromJSONField :: (JSON.FromJSON a, Typeable a) => FieldParser a fromJSONField f mbBs = do value <- fromField f mbBs @@ -566,7 +588,6 @@ JSON.Error err -> returnError ConversionFailed f $ "JSON decoding error: " ++ err JSON.Success x -> pure x - -- | Compatible with the same set of types as @a@. Note that -- modifying the 'IORef' does not have any effects outside diff --git a/src/Database/PostgreSQL/Simple/HStore.hs b/src/Database/PostgreSQL/Simple/HStore.hs --- a/src/Database/PostgreSQL/Simple/HStore.hs +++ b/src/Database/PostgreSQL/Simple/HStore.hs @@ -8,14 +8,14 @@ -- -- Parsers and printers for hstore, a extended type bundled with -- PostgreSQL providing finite maps from text strings to text strings. --- See for more +-- See for more -- information. -- -- Note that in order to use this type, a database superuser must -- install it by running a sql script in the share directory. This -- can be done on PostgreSQL 9.1 and later with the command -- @CREATE EXTENSION hstore@. See --- for more +-- for more -- information. -- ------------------------------------------------------------------------------ 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 @@ -154,10 +154,11 @@ connect = connectPostgreSQL . postgreSQLConnectionString -- | Attempt to make a connection based on a libpq connection string. --- See +-- See -- for more information. Also note that environment variables also affect -- parameters not provided, parameters provided as the empty string, and a --- few other things; see +-- few other things; see +-- -- for details. Here is an example with some of the most commonly used -- parameters: -- @@ -188,7 +189,7 @@ -- Omitting @password@ will default to an appropriate password found -- in the @pgpass@ file, or no password at all if a matching line is -- not found. See --- for +-- for -- more information regarding this file. -- -- As all parameters are optional and the defaults are sensible, the @@ -206,18 +207,20 @@ -- or production machines, or you will need to use a @pgpass@ file -- with the @password@ or @md5@ authentication methods. -- --- See +-- See -- for more information regarding the authentication process. -- -- SSL/TLS will typically "just work" if your postgresql server supports or -- requires it. However, note that libpq is trivially vulnerable to a MITM --- attack without setting additional SSL parameters in the connection string. --- In particular, @sslmode@ needs to be set to @require@, @verify-ca@, or +-- attack without setting additional SSL connection parameters. In +-- particular, @sslmode@ needs to be set to @require@, @verify-ca@, or -- @verify-full@ in order to perform certificate validation. When @sslmode@ -- is @require@, then you will also need to specify a @sslrootcert@ file, -- otherwise no validation of the server's identity will be performed. -- Client authentication via certificates is also possible via the --- @sslcert@ and @sslkey@ parameters. +-- @sslcert@ and @sslkey@ parameters. See +-- +-- for detailed information regarding libpq and SSL. connectPostgreSQL :: ByteString -> IO Connection connectPostgreSQL connstr = do diff --git a/src/Database/PostgreSQL/Simple/LargeObjects.hs b/src/Database/PostgreSQL/Simple/LargeObjects.hs --- a/src/Database/PostgreSQL/Simple/LargeObjects.hs +++ b/src/Database/PostgreSQL/Simple/LargeObjects.hs @@ -7,7 +7,7 @@ -- Maintainer : leon@melding-monads.com -- -- Support for PostgreSQL's Large Objects; see --- for more +-- for more -- information. -- -- Note that Large Object File Descriptors are only valid within a single 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 @@ -14,7 +14,7 @@ -- -- Support for receiving asynchronous notifications via PostgreSQL's -- Listen/Notify mechanism. See --- for more +-- for more -- information. -- -- Note that on Windows, @getNotification@ currently uses a polling loop @@ -25,7 +25,7 @@ -- Notifications do not create any extra work for the backend, and are -- likely cheaper on the client side as well. -- --- +-- -- ----------------------------------------------------------------------------- diff --git a/src/Database/PostgreSQL/Simple/Time.hs b/src/Database/PostgreSQL/Simple/Time.hs --- a/src/Database/PostgreSQL/Simple/Time.hs +++ b/src/Database/PostgreSQL/Simple/Time.hs @@ -11,7 +11,7 @@ Also, this module also contains commentary regarding postgresql's timestamp types, civil timekeeping in general, and how it relates to postgresql-simple. You can read more about PostgreSQL's date and time types -at , +at , and the IANA time zone database at . Stack Overflow also has some excellent commentary on time, if it is a diff --git a/src/Database/PostgreSQL/Simple/Transaction.hs b/src/Database/PostgreSQL/Simple/Transaction.hs --- a/src/Database/PostgreSQL/Simple/Transaction.hs +++ b/src/Database/PostgreSQL/Simple/Transaction.hs @@ -45,7 +45,7 @@ -- | Of the four isolation levels defined by the SQL standard, -- these are the three levels distinguished by PostgreSQL as of version 9.0. --- See +-- See -- for more information. Note that prior to PostgreSQL 9.0, 'RepeatableRead' -- was equivalent to 'Serializable'. @@ -203,7 +203,7 @@ -- be used inside of a transaction, and provides a sort of -- \"nested transaction\". -- --- See +-- See withSavepoint :: Connection -> IO a -> IO a withSavepoint conn body = mask $ \restore -> do 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 @@ -131,11 +131,11 @@ -- 1. Use postgresql-simple's 'Values' type instead, which can handle the -- empty case correctly. Note however that while specifying the -- postgresql type @"int4"@ is mandatory in the empty case, specifying --- the haskell type @[Only Int]@ would not normally be needed in +-- the haskell type @Values (Only Int)@ would not normally be needed in -- realistic use cases. -- -- > query c "select * from whatever where id not in ?" --- > (Only (Values "int4") ([] :: [Only Int])) +-- > (Only (Values ["int4"] [] :: Values (Only Int))) -- -- -- 2. Use sql's @COALESCE@ operator to turn a logical @null@ into the correct @@ -143,10 +143,18 @@ -- case: -- -- > query c "select * from whatever where coalesce(id NOT in ?, TRUE)" --- > (Only (In ([] :: [Int]))) +-- > (Only (In [] :: In [Int])) -- -- > query c "select * from whatever where coalesce(id IN ?, FALSE)" --- > (Only (In ([] :: [Int]))) +-- > (Only (In [] :: In [Int])) +-- +-- Note that at as of PostgreSQL 9.4, the query planner cannot see inside +-- the @COALESCE@ operator, so if you have an index on @id@ then you +-- probably don't want to write the last example with @COALESCE@, which +-- would result in a table scan. There are further caveats if @id@ can +-- be null or you want null treated sensibly as a component of @IN@ or +-- @NOT IN@. + newtype In a = In a deriving (Eq, Ord, Read, Show, Typeable, Functor) @@ -209,8 +217,9 @@ newtype Savepoint = Savepoint Query deriving (Eq, Ord, Show, Read, Typeable) --- | Represents a @VALUES@ table literal, usable as an alternative --- to @executeMany@ and @returning@. The main advantage is that +-- | Represents a @VALUES@ table literal, usable as an alternative to +-- 'Database.PostgreSQL.Simple.executeMany' and +-- 'Database.PostgreSQL.Simple.returning'. The main advantage is that -- you can parametrize more than just a single @VALUES@ expression. -- For example, here's a query to insert a thing into one table -- and some attributes of that thing into another, returning the @@ -223,7 +232,7 @@ -- > ), new_attributes AS ( -- > INSERT INTO thing_attributes -- > SELECT new_thing.id, attrs.* --- > FROM new_thing JOIN ? attrs +-- > FROM new_thing JOIN ? attrs ON TRUE -- > ) SELECT * FROM new_thing -- > |] ("foo", Values [ "int4", "text" ] -- > [ ( 1 , "hello" ) @@ -249,7 +258,8 @@ -- is turned into a properly quoted identifier, the type name is case -- sensitive and must be as it appears in the @pg_type@ table. Thus, -- you must write @timestamptz@ instead of @timestamp with time zone@, --- @int4@ instead of @integer@, @_int8@ instead of @bigint[]@, etcetera. +-- @int4@ instead of @integer@ or @serial@, @_int8@ instead of @bigint[]@, +-- etcetera. -- -- You may omit the type names, however, if you do so the list -- of values must be non-empty, and postgresql must be able to infer @@ -258,7 +268,7 @@ -- without issuing the query. In the second case, the postgres server -- will return an error which will be turned into a @SqlError@ exception. -- --- See for +-- See for -- more information. data Values a = Values [QualifiedIdentifier] [a] deriving (Eq, Ord, Show, Read, Typeable) diff --git a/test/Common.hs b/test/Common.hs --- a/test/Common.hs +++ b/test/Common.hs @@ -1,6 +1,6 @@ module Common ( module Database.PostgreSQL.Simple, - module Test.HUnit, + module Test.Tasty.HUnit, TestEnv(..), md5, ) where @@ -8,7 +8,7 @@ import Data.ByteString (ByteString) import Data.Text (Text) import Database.PostgreSQL.Simple -import Test.HUnit +import Test.Tasty.HUnit import qualified Crypto.Hash.MD5 as MD5 import qualified Data.ByteString.Base16 as Base16 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -8,51 +8,58 @@ import Database.PostgreSQL.Simple.HStore import Database.PostgreSQL.Simple.Copy import qualified Database.PostgreSQL.Simple.Transaction as ST + import Control.Applicative import Control.Exception as E import Control.Monad -import Data.ByteString (ByteString) +import Data.Char +import Data.List (sort) import Data.IORef import Data.Typeable +import GHC.Generics (Generic) + +import Data.Aeson +import Data.ByteString (ByteString) import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy.Char8 as BL import Data.Map (Map) -import Data.List (sort) import qualified Data.Map as Map import Data.Text(Text) import qualified Data.Text.Encoding as T -import System.Exit (exitFailure) -import System.IO import qualified Data.Vector as V -import Data.Aeson -import GHC.Generics (Generic) +import System.FilePath +import Test.Tasty +import Test.Tasty.Golden import Notify import Serializable import Time -tests :: [TestEnv -> Test] -tests = - [ TestLabel "Bytea" . testBytea - , TestLabel "ExecuteMany" . testExecuteMany - , TestLabel "Fold" . testFold - , TestLabel "Notify" . testNotify - , TestLabel "Serializable" . testSerializable - , TestLabel "Time" . testTime - , TestLabel "Array" . testArray - , TestLabel "HStore" . testHStore - , TestLabel "JSON" . testJSON - , TestLabel "Savepoint" . testSavepoint - , TestLabel "Unicode" . testUnicode - , TestLabel "Values" . testValues - , TestLabel "Copy" . testCopy - , TestLabel "Double" . testDouble - , TestLabel "1-ary generic" . testGeneric1 - , TestLabel "2-ary generic" . testGeneric2 - , TestLabel "3-ary generic" . testGeneric3 +tests :: TestEnv -> TestTree +tests env = testGroup "tests" + $ map ($ env) + [ testBytea + , testCase "ExecuteMany" . testExecuteMany + , testCase "Fold" . testFold + , testCase "Notify" . testNotify + , testCase "Serializable" . testSerializable + , testCase "Time" . testTime + , testCase "Array" . testArray + , testCase "HStore" . testHStore + , testCase "JSON" . testJSON + , testCase "Savepoint" . testSavepoint + , testCase "Unicode" . testUnicode + , testCase "Values" . testValues + , testCase "Copy" . testCopy + , testCopyFailures + , testCase "Double" . testDouble + , testCase "1-ary generic" . testGeneric1 + , testCase "2-ary generic" . testGeneric2 + , testCase "3-ary generic" . testGeneric3 ] -testBytea :: TestEnv -> Test -testBytea TestEnv{..} = TestList +testBytea :: TestEnv -> TestTree +testBytea TestEnv{..} = testGroup "Bytea" [ testStr "empty" [] , testStr "\"hello\"" $ map (fromIntegral . fromEnum) ("hello" :: String) , testStr "ascending" [0..255] @@ -61,7 +68,7 @@ , testStr "descending, doubled up" $ doubleUp [255,254..0] ] where - testStr label bytes = TestLabel label $ TestCase $ do + testStr label bytes = testCase label $ do let bs = B.pack bytes [Only h] <- query conn "SELECT md5(?::bytea)" [Binary bs] @@ -72,8 +79,8 @@ doubleUp = concatMap (\x -> [x, x]) -testExecuteMany :: TestEnv -> Test -testExecuteMany TestEnv{..} = TestCase $ do +testExecuteMany :: TestEnv -> Assertion +testExecuteMany TestEnv{..} = do execute_ conn "CREATE TEMPORARY TABLE tmp_executeMany (i INT, t TEXT, b BYTEA)" let rows :: [(Int, String, Binary ByteString)] @@ -90,8 +97,8 @@ return () -testFold :: TestEnv -> Test -testFold TestEnv{..} = TestCase $ do +testFold :: TestEnv -> Assertion +testFold TestEnv{..} = do xs <- fold_ conn "SELECT generate_series(1,10000)" [] $ \xs (Only x) -> return (x:xs) reverse xs @?= ([1..10000] :: [Int]) @@ -160,8 +167,8 @@ ++ show (typeOf resultType) ++ " -> " ++ show val) -testArray :: TestEnv -> Test -testArray TestEnv{..} = TestCase $ do +testArray :: TestEnv -> Assertion +testArray TestEnv{..} = do xs <- query_ conn "SELECT '{1,2,3,4}'::_int4" xs @?= [Only (V.fromList [1,2,3,4 :: Int])] xs <- query_ conn "SELECT '{{1,2},{3,4}}'::_int4" @@ -170,8 +177,8 @@ queryFailure conn "SELECT '{1,2,3,4}'::_int4" (undefined :: V.Vector Bool) queryFailure conn "SELECT '{{1,2},{3,4}}'::_int4" (undefined :: V.Vector Int) -testHStore :: TestEnv -> Test -testHStore TestEnv{..} = TestCase $ do +testHStore :: TestEnv -> Assertion +testHStore TestEnv{..} = do execute_ conn "CREATE EXTENSION IF NOT EXISTS hstore" roundTrip [] roundTrip [("foo","bar"),("bar","baz"),("baz","hello")] @@ -183,8 +190,8 @@ m' <- query conn "SELECT ?::hstore" m [m] @?= m' -testJSON :: TestEnv -> Test -testJSON TestEnv{..} = TestCase $ do +testJSON :: TestEnv -> Assertion +testJSON 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) @@ -198,8 +205,8 @@ js' <- query conn "SELECT ?::json" js [js] @?= js' -testSavepoint :: TestEnv -> Test -testSavepoint TestEnv{..} = TestCase $ do +testSavepoint :: TestEnv -> Assertion +testSavepoint TestEnv{..} = do True <- expectError ST.isNoActiveTransactionError $ withSavepoint conn $ return () @@ -259,8 +266,8 @@ return () -testUnicode :: TestEnv -> Test -testUnicode TestEnv{..} = TestCase $ do +testUnicode :: TestEnv -> Assertion +testUnicode TestEnv{..} = do let q = Query . T.encodeUtf8 -- Handle encoding ourselves to ensure -- the table gets created correctly. let messages = map Only ["привет","мир"] :: [Only Text] @@ -269,8 +276,8 @@ messages' <- query_ conn "SELECT сообщение FROM ру́сский" sort messages @?= sort messages' -testValues :: TestEnv -> Test -testValues TestEnv{..} = TestCase $ do +testValues :: TestEnv -> Assertion +testValues TestEnv{..} = do execute_ conn "CREATE TEMPORARY TABLE values_test (x int, y text)" test (Values ["int4","text"] []) test (Values ["int4","text"] [(1,"hello")]) @@ -287,8 +294,8 @@ sort vals @?= sort vals' -testCopy :: TestEnv -> Test -testCopy TestEnv{..} = TestCase $ do +testCopy :: TestEnv -> Assertion +testCopy TestEnv{..} = do execute_ conn "CREATE TEMPORARY TABLE copy_test (x int, y text)" copy_ conn "COPY copy_test FROM STDIN (FORMAT CSV)" mapM_ (putCopyData conn) copyRows @@ -315,8 +322,53 @@ CopyOutDone _ -> return rows CopyOutRow row -> loop (row:rows) -testDouble :: TestEnv -> Test -testDouble TestEnv{..} = TestCase $ do +testCopyFailures :: TestEnv -> TestTree +testCopyFailures env = testGroup "Copy failures" + $ map ($ env) + [ testCopyUniqueConstraintError + , testCopyMalformedError + ] + +goldenTest :: TestName -> IO BL.ByteString -> TestTree +goldenTest testName = + goldenVsString testName (resultsDir fileName<.>"expected") + where + resultsDir = "test" "results" + fileName = map normalize testName + normalize c | not (isAlpha c) = '-' + | otherwise = c + +-- | Test that we provide a sensible error message on failure +testCopyUniqueConstraintError :: TestEnv -> TestTree +testCopyUniqueConstraintError TestEnv{..} = + goldenTest "unique constraint violation" + $ handle (\(SomeException exc) -> return $ BL.pack $ show exc) $ do + execute_ conn "CREATE TEMPORARY TABLE copy_unique_constraint_error_test (x int PRIMARY KEY, y text)" + copy_ conn "COPY copy_unique_constraint_error_test FROM STDIN (FORMAT CSV)" + mapM_ (putCopyData conn) copyRows + _n <- putCopyEnd conn + return BL.empty + where + copyRows = ["1,foo\n" + ,"2,bar\n" + ,"1,baz\n"] + +testCopyMalformedError :: TestEnv -> TestTree +testCopyMalformedError TestEnv{..} = + goldenTest "malformed input" + $ handle (\(SomeException exc) -> return $ BL.pack $ show exc) $ do + execute_ conn "CREATE TEMPORARY TABLE copy_malformed_input_error_test (x int PRIMARY KEY, y text)" + copy_ conn "COPY copy_unique_constraint_error_test FROM STDIN (FORMAT CSV)" + mapM_ (putCopyData conn) copyRows + _n <- putCopyEnd conn + return BL.empty + where + copyRows = ["1,foo\n" + ,"2,bar\n" + ,"z,baz\n"] + +testDouble :: TestEnv -> Assertion +testDouble TestEnv{..} = do [Only (x :: Double)] <- query_ conn "SELECT 'NaN'::float8" assertBool "expected NaN" (isNaN x) [Only (x :: Double)] <- query_ conn "SELECT 'Infinity'::float8" @@ -325,24 +377,24 @@ x @?= (-1 / 0) -testGeneric1 :: TestEnv -> Test -testGeneric1 TestEnv{..} = TestCase $ do +testGeneric1 :: TestEnv -> Assertion +testGeneric1 TestEnv{..} = do roundTrip conn (Gen1 123) where roundTrip conn x0 = do r <- query conn "SELECT ?::int" (x0 :: Gen1) r @?= [x0] -testGeneric2 :: TestEnv -> Test -testGeneric2 TestEnv{..} = TestCase $ do +testGeneric2 :: TestEnv -> Assertion +testGeneric2 TestEnv{..} = do roundTrip conn (Gen2 123 "asdf") where roundTrip conn x0 = do r <- query conn "SELECT ?::int, ?::text" x0 r @?= [x0] -testGeneric3 :: TestEnv -> Test -testGeneric3 TestEnv{..} = TestCase $ do +testGeneric3 :: TestEnv -> Assertion +testGeneric3 TestEnv{..} = do roundTrip conn (Gen3 123 "asdf" True) where roundTrip conn x0 = do @@ -401,8 +453,4 @@ withConn = bracket testConnect close main :: IO () -main = do - mapM_ (`hSetBuffering` LineBuffering) [stdout, stderr] - Counts{cases, tried, errors, failures} <- - withTestEnv $ \env -> runTestTT $ TestList $ map ($ env) tests - when (cases /= tried || errors /= 0 || failures /= 0) $ exitFailure +main = withTestEnv $ defaultMain . tests diff --git a/test/Notify.hs b/test/Notify.hs --- a/test/Notify.hs +++ b/test/Notify.hs @@ -14,9 +14,8 @@ -- TODO: Test with payload, but only for PostgreSQL >= 9.0 -- (when that feature was introduced). -testNotify :: TestEnv -> Test +testNotify :: TestEnv -> Assertion testNotify TestEnv{..} = - TestCase $ withConn $ \conn2 -> do execute_ conn "LISTEN foo" execute_ conn "LISTEN bar" diff --git a/test/Serializable.hs b/test/Serializable.hs --- a/test/Serializable.hs +++ b/test/Serializable.hs @@ -23,9 +23,8 @@ 1 <- execute conn "UPDATE testSerializableCounter SET n=?" (Only n) return () -testSerializable :: TestEnv -> Test +testSerializable :: TestEnv -> Assertion testSerializable TestEnv{..} = - TestCase $ withConn $ \conn2 -> do initCounter conn diff --git a/test/Time.hs b/test/Time.hs --- a/test/Time.hs +++ b/test/Time.hs @@ -43,8 +43,8 @@ numTests :: Int numTests = 200 -testTime :: TestEnv -> Test -testTime env@TestEnv{..} = TestCase $ do +testTime :: TestEnv -> Assertion +testTime env@TestEnv{..} = do initializeTable env execute_ conn "SET timezone TO 'UTC'" checkRoundTrips env "1860-01-01 00:00:00+00"