@@ -8,51 +8,58 @@ import Database.PostgreSQL.Simple.Types(Query(..),Values(..))
88import Database.PostgreSQL.Simple.HStore
99import Database.PostgreSQL.Simple.Copy
1010import qualified Database.PostgreSQL.Simple.Transaction as ST
11+
1112import Control.Applicative
1213import Control.Exception as E
1314import Control.Monad
14−import Data.ByteString (ByteString)
15+import Data.Char
16+import Data.List (sort)
1517import Data.IORef
1618import Data.Typeable
19+import GHC.Generics (Generic)
20+
21+import Data.Aeson
22+import Data.ByteString (ByteString)
1723import qualified Data.ByteString as B
24+import qualified Data.ByteString.Lazy.Char8 as BL
1825import Data.Map (Map)
19−import Data.List (sort)
2026import qualified Data.Map as Map
2127import Data.Text(Text)
2228import qualified Data.Text.Encoding as T
23−import System.Exit (exitFailure)
24−import System.IO
2529import qualified Data.Vector as V
26−import Data.Aeson
27−import GHC.Generics (Generic)
30+import System.FilePath
2831
32+import Test.Tasty
33+import Test.Tasty.Golden
2934import Notify
3035import Serializable
3136import Time
3237
33−tests :: [TestEnv -> Test]
34−tests =
35− [ TestLabel "Bytea" . testBytea
36− , TestLabel "ExecuteMany" . testExecuteMany
37− , TestLabel "Fold" . testFold
38− , TestLabel "Notify" . testNotify
39− , TestLabel "Serializable" . testSerializable
40− , TestLabel "Time" . testTime
41− , TestLabel "Array" . testArray
42− , TestLabel "HStore" . testHStore
43− , TestLabel "JSON" . testJSON
44− , TestLabel "Savepoint" . testSavepoint
45− , TestLabel "Unicode" . testUnicode
46− , TestLabel "Values" . testValues
47− , TestLabel "Copy" . testCopy
48− , TestLabel "Double" . testDouble
49− , TestLabel "1-ary generic" . testGeneric1
50− , TestLabel "2-ary generic" . testGeneric2
51− , TestLabel "3-ary generic" . testGeneric3
38+tests :: TestEnv -> TestTree
39+tests env = testGroup "tests"
40+ $ map ($ env)
41+ [ testBytea
42+ , testCase "ExecuteMany" . testExecuteMany
43+ , testCase "Fold" . testFold
44+ , testCase "Notify" . testNotify
45+ , testCase "Serializable" . testSerializable
46+ , testCase "Time" . testTime
47+ , testCase "Array" . testArray
48+ , testCase "HStore" . testHStore
49+ , testCase "JSON" . testJSON
50+ , testCase "Savepoint" . testSavepoint
51+ , testCase "Unicode" . testUnicode
52+ , testCase "Values" . testValues
53+ , testCase "Copy" . testCopy
54+ , testCopyFailures
55+ , testCase "Double" . testDouble
56+ , testCase "1-ary generic" . testGeneric1
57+ , testCase "2-ary generic" . testGeneric2
58+ , testCase "3-ary generic" . testGeneric3
5259 ]
5360
54−testBytea :: TestEnv -> Test
55−testBytea TestEnv{..} = TestList
61+testBytea :: TestEnv -> TestTree
62+testBytea TestEnv{..} = testGroup "Bytea"
5663 [ testStr "empty" []
5764 , testStr "\"hello\"" $ map (fromIntegral . fromEnum) ("hello" :: String)
5865 , testStr "ascending" [0..255]
@@ -61,7 +68,7 @@ testBytea TestEnv{..} = TestList
6168 , testStr "descending, doubled up" $ doubleUp [255,254..0]
6269 ]
6370 where
64− testStr label bytes = TestLabel label $ TestCase $ do
71+ testStr label bytes = testCase label $ do
6572 let bs = B.pack bytes
6673
6774 [Only h] <- query conn "SELECT md5(?::bytea)" [Binary bs]
@@ -72,8 +79,8 @@ testBytea TestEnv{..} = TestList
7279
7380 doubleUp = concatMap (\x -> [x, x])
7481
75−testExecuteMany :: TestEnv -> Test
76−testExecuteMany TestEnv{..} = TestCase $ do
82+testExecuteMany :: TestEnv -> Assertion
83+testExecuteMany TestEnv{..} = do
7784 execute_ conn "CREATE TEMPORARY TABLE tmp_executeMany (i INT, t TEXT, b BYTEA)"
7885
7986 let rows :: [(Int, String, Binary ByteString)]
@@ -90,8 +97,8 @@ testExecuteMany TestEnv{..} = TestCase $ do
9097
9198 return ()
9299
93−testFold :: TestEnv -> Test
94−testFold TestEnv{..} = TestCase $ do
100+testFold :: TestEnv -> Assertion
101+testFold TestEnv{..} = do
95102 xs <- fold_ conn "SELECT generate_series(1,10000)"
96103 [] $ \xs (Only x) -> return (x:xs)
97104 reverse xs @?= ([1..10000] :: [Int])
@@ -160,8 +167,8 @@ queryFailure conn q resultType = do
160167 ++ show (typeOf resultType)
161168 ++ " -> " ++ show val)
162169
163−testArray :: TestEnv -> Test
164−testArray TestEnv{..} = TestCase $ do
170+testArray :: TestEnv -> Assertion
171+testArray TestEnv{..} = do
165172 xs <- query_ conn "SELECT '{1,2,3,4}'::_int4"
166173 xs @?= [Only (V.fromList [1,2,3,4 :: Int])]
167174 xs <- query_ conn "SELECT '{{1,2},{3,4}}'::_int4"
@@ -170,8 +177,8 @@ testArray TestEnv{..} = TestCase $ do
170177 queryFailure conn "SELECT '{1,2,3,4}'::_int4" (undefined :: V.Vector Bool)
171178 queryFailure conn "SELECT '{{1,2},{3,4}}'::_int4" (undefined :: V.Vector Int)
172179
173−testHStore :: TestEnv -> Test
174−testHStore TestEnv{..} = TestCase $ do
180+testHStore :: TestEnv -> Assertion
181+testHStore TestEnv{..} = do
175182 execute_ conn "CREATE EXTENSION IF NOT EXISTS hstore"
176183 roundTrip []
177184 roundTrip [("foo","bar"),("bar","baz"),("baz","hello")]
@@ -183,8 +190,8 @@ testHStore TestEnv{..} = TestCase $ do
183190 m' <- query conn "SELECT ?::hstore" m
184191 [m] @?= m'
185192
186−testJSON :: TestEnv -> Test
187−testJSON TestEnv{..} = TestCase $ do
193+testJSON :: TestEnv -> Assertion
194+testJSON TestEnv{..} = do
188195 roundTrip (Map.fromList [] :: Map Text Text)
189196 roundTrip (Map.fromList [("foo","bar"),("bar","baz"),("baz","hello")] :: Map Text Text)
190197 roundTrip (Map.fromList [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")] :: Map Text Text)
@@ -198,8 +205,8 @@ testJSON TestEnv{..} = TestCase $ do
198205 js' <- query conn "SELECT ?::json" js
199206 [js] @?= js'
200207
201−testSavepoint :: TestEnv -> Test
202−testSavepoint TestEnv{..} = TestCase $ do
208+testSavepoint :: TestEnv -> Assertion
209+testSavepoint TestEnv{..} = do
203210 True <- expectError ST.isNoActiveTransactionError $
204211 withSavepoint conn $ return ()
205212
@@ -259,8 +266,8 @@ testSavepoint TestEnv{..} = TestCase $ do
259266
260267 return ()
261268
262−testUnicode :: TestEnv -> Test
263−testUnicode TestEnv{..} = TestCase $ do
269+testUnicode :: TestEnv -> Assertion
270+testUnicode TestEnv{..} = do
264271 let q = Query . T.encodeUtf8 -- Handle encoding ourselves to ensure
265272 -- the table gets created correctly.
266273 let messages = map Only ["привет","мир"] :: [Only Text]
@@ -269,8 +276,8 @@ testUnicode TestEnv{..} = TestCase $ do
269276 messages' <- query_ conn "SELECT сообщение FROM ру́сский"
270277 sort messages @?= sort messages'
271278
272−testValues :: TestEnv -> Test
273−testValues TestEnv{..} = TestCase $ do
279+testValues :: TestEnv -> Assertion
280+testValues TestEnv{..} = do
274281 execute_ conn "CREATE TEMPORARY TABLE values_test (x int, y text)"
275282 test (Values ["int4","text"] [])
276283 test (Values ["int4","text"] [(1,"hello")])
@@ -287,8 +294,8 @@ testValues TestEnv{..} = TestCase $ do
287294 sort vals @?= sort vals'
288295
289296
290−testCopy :: TestEnv -> Test
291−testCopy TestEnv{..} = TestCase $ do
297+testCopy :: TestEnv -> Assertion
298+testCopy TestEnv{..} = do
292299 execute_ conn "CREATE TEMPORARY TABLE copy_test (x int, y text)"
293300 copy_ conn "COPY copy_test FROM STDIN (FORMAT CSV)"
294301 mapM_ (putCopyData conn) copyRows
@@ -315,8 +322,53 @@ testCopy TestEnv{..} = TestCase $ do
315322 CopyOutDone _ -> return rows
316323 CopyOutRow row -> loop (row:rows)
317324
318−testDouble :: TestEnv -> Test
319−testDouble TestEnv{..} = TestCase $ do
325+testCopyFailures :: TestEnv -> TestTree
326+testCopyFailures env = testGroup "Copy failures"
327+ $ map ($ env)
328+ [ testCopyUniqueConstraintError
329+ , testCopyMalformedError
330+ ]
331+
332+goldenTest :: TestName -> IO BL.ByteString -> TestTree
333+goldenTest testName =
334+ goldenVsString testName (resultsDir </> fileName<.>"expected")
335+ where
336+ resultsDir = "test" </> "results"
337+ fileName = map normalize testName
338+ normalize c | not (isAlpha c) = '-'
339+ | otherwise = c
340+
341+-- | Test that we provide a sensible error message on failure
342+testCopyUniqueConstraintError :: TestEnv -> TestTree
343+testCopyUniqueConstraintError TestEnv{..} =
344+ goldenTest "unique constraint violation"
345+ $ handle (\(SomeException exc) -> return $ BL.pack $ show exc) $ do
346+ execute_ conn "CREATE TEMPORARY TABLE copy_unique_constraint_error_test (x int PRIMARY KEY, y text)"
347+ copy_ conn "COPY copy_unique_constraint_error_test FROM STDIN (FORMAT CSV)"
348+ mapM_ (putCopyData conn) copyRows
349+ _n <- putCopyEnd conn
350+ return BL.empty
351+ where
352+ copyRows = ["1,foo\n"
353+ ,"2,bar\n"
354+ ,"1,baz\n"]
355+
356+testCopyMalformedError :: TestEnv -> TestTree
357+testCopyMalformedError TestEnv{..} =
358+ goldenTest "malformed input"
359+ $ handle (\(SomeException exc) -> return $ BL.pack $ show exc) $ do
360+ execute_ conn "CREATE TEMPORARY TABLE copy_malformed_input_error_test (x int PRIMARY KEY, y text)"
361+ copy_ conn "COPY copy_unique_constraint_error_test FROM STDIN (FORMAT CSV)"
362+ mapM_ (putCopyData conn) copyRows
363+ _n <- putCopyEnd conn
364+ return BL.empty
365+ where
366+ copyRows = ["1,foo\n"
367+ ,"2,bar\n"
368+ ,"z,baz\n"]
369+
370+testDouble :: TestEnv -> Assertion
371+testDouble TestEnv{..} = do
320372 [Only (x :: Double)] <- query_ conn "SELECT 'NaN'::float8"
321373 assertBool "expected NaN" (isNaN x)
322374 [Only (x :: Double)] <- query_ conn "SELECT 'Infinity'::float8"
@@ -325,24 +377,24 @@ testDouble TestEnv{..} = TestCase $ do
325377 x @?= (-1 / 0)
326378
327379
328−testGeneric1 :: TestEnv -> Test
329−testGeneric1 TestEnv{..} = TestCase $ do
380+testGeneric1 :: TestEnv -> Assertion
381+testGeneric1 TestEnv{..} = do
330382 roundTrip conn (Gen1 123)
331383 where
332384 roundTrip conn x0 = do
333385 r <- query conn "SELECT ?::int" (x0 :: Gen1)
334386 r @?= [x0]
335387
336−testGeneric2 :: TestEnv -> Test
337−testGeneric2 TestEnv{..} = TestCase $ do
388+testGeneric2 :: TestEnv -> Assertion
389+testGeneric2 TestEnv{..} = do
338390 roundTrip conn (Gen2 123 "asdf")
339391 where
340392 roundTrip conn x0 = do
341393 r <- query conn "SELECT ?::int, ?::text" x0
342394 r @?= [x0]
343395
344−testGeneric3 :: TestEnv -> Test
345−testGeneric3 TestEnv{..} = TestCase $ do
396+testGeneric3 :: TestEnv -> Assertion
397+testGeneric3 TestEnv{..} = do
346398 roundTrip conn (Gen3 123 "asdf" True)
347399 where
348400 roundTrip conn x0 = do
@@ -401,8 +453,4 @@ withTestEnv cb =
401453 withConn = bracket testConnect close
402454
403455main :: IO ()
404−main = do
405− mapM_ (`hSetBuffering` LineBuffering) [stdout, stderr]
406− Counts{cases, tried, errors, failures} <-
407− withTestEnv $ \env -> runTestTT $ TestList $ map ($ env) tests
408− when (cases /= tried || errors /= 0 || failures /= 0) $ exitFailure
456+main = withTestEnv $ defaultMain . tests