@@ -24,6 +24,7 @@ import Control.Applicative
24import Control.Exception as E
24import Control.Exception as E
25import Control.Monad
25import Control.Monad
26import Data.Char
26import Data.Char
27+import Data.Foldable (toList)
27import Data.List (concat, sort)
28import Data.List (concat, sort)
28import Data.IORef
29import Data.IORef
29import Data.Monoid ((<>))
30import Data.Monoid ((<>))
@@ -45,7 +46,7 @@ import qualified Data.Text.Encoding as T
45import qualified Data.Vector as V
46import qualified Data.Vector as V
46import System.FilePath
47import System.FilePath
47import System.Timeout(timeout)
48import System.Timeout(timeout)
48−import Data.Time(getCurrentTime, diffUTCTime)
49+import Data.Time.Compat (getCurrentTime, diffUTCTime)
49import System.Environment (getEnvironment)
50import System.Environment (getEnvironment)
51import Test.Tasty
52import Test.Tasty
@@ -53,6 +54,8 @@ import Test.Tasty.Golden
53import Notify
54import Notify
54import Serializable
55import Serializable
55import Time
56import Time
58+import Exception (testExceptions)
57tests :: TestEnv -> TestTree
60tests :: TestEnv -> TestTree
58tests env = testGroup "tests"
61tests env = testGroup "tests"
@@ -63,6 +66,7 @@ tests env = testGroup "tests"
63 , testCase "Notify" . testNotify
66 , testCase "Notify" . testNotify
64 , testCase "Serializable" . testSerializable
67 , testCase "Serializable" . testSerializable
65 , testCase "Time" . testTime
68 , testCase "Time" . testTime
69+ , testCase "Interval" . testInterval
66 , testCase "Array" . testArray
70 , testCase "Array" . testArray
67 , testCase "Array of nullables" . testNullableArray
71 , testCase "Array of nullables" . testNullableArray
68 , testCase "HStore" . testHStore
72 , testCase "HStore" . testHStore
@@ -81,6 +85,7 @@ tests env = testGroup "tests"
81 , testCase "2-ary generic" . testGeneric2
85 , testCase "2-ary generic" . testGeneric2
82 , testCase "3-ary generic" . testGeneric3
86 , testCase "3-ary generic" . testGeneric3
83 , testCase "Timeout" . testTimeout
87 , testCase "Timeout" . testTimeout
88+ , testCase "Exceptions" . testExceptions
86testBytea :: TestEnv -> TestTree
91testBytea :: TestEnv -> TestTree
@@ -134,7 +139,7 @@ testFold TestEnv{..} = do
134 xs <- readIORef ref
139 xs <- readIORef ref
135 writeIORef ref $! (a,b):xs
140 writeIORef ref $! (a,b):xs
136 xs <- readIORef ref
141 xs <- readIORef ref
137− reverse xs @?= [(a,b) | a <- [1..100], b <- [1..50]]
142+ reverse xs @?= [(a,b) | b <- [1..50], a <- [1..100]]
139 -- Make sure fold propagates our exception.
144 -- Make sure fold propagates our exception.
140 ref <- newIORef []
145 ref <- newIORef []
@@ -442,6 +447,14 @@ testCopy TestEnv{..} = do
442 -- so that we can issue more queries:
447 -- so that we can issue more queries:
443 [Only (x::Int)] <- query_ conn "SELECT 2 + 2"
448 [Only (x::Int)] <- query_ conn "SELECT 2 + 2"
451+ copy_ conn "COPY copy_test TO STDOUT (FORMAT CSV)"
452+ (acc, count) <- foldCopyData conn
453+ (\acc row -> return (row:acc))
454+ (\acc count -> return (acc, count))
456+ sort acc @?= sort copyRows
446 copyRows = ["1,foo\n"
459 copyRows = ["1,foo\n"
447 ,"2,bar\n"]
460 ,"2,bar\n"]
@@ -461,12 +474,13 @@ testCopyFailures env = testGroup "Copy failures"
462goldenTest :: TestName -> IO BL.ByteString -> TestTree
475goldenTest :: TestName -> IO BL.ByteString -> TestTree
463goldenTest testName =
476goldenTest testName =
464− goldenVsString testName (resultsDir </> fileName<.>"expected")
477+ goldenVsStringDiff testName diff (resultsDir </> fileName<.>"expected")
466 resultsDir = "test" </> "results"
479 resultsDir = "test" </> "results"
467 fileName = map normalize testName
480 fileName = map normalize testName
468 normalize c | not (isAlpha c) = '-'
481 normalize c | not (isAlpha c) = '-'
469 | otherwise = c
482 | otherwise = c
483+ diff ref new = ["diff", "-u", ref, new]
471-- | Test that we provide a sensible error message on failure
485-- | Test that we provide a sensible error message on failure
472testCopyUniqueConstraintError :: TestEnv -> TestTree
486testCopyUniqueConstraintError :: TestEnv -> TestTree
@@ -595,7 +609,11 @@ isFormatError i FormatError{..}
595-- that 'testConnect' connects to the same database every time it is called.
609-- that 'testConnect' connects to the same database every time it is called.
596withTestEnv :: ByteString -> (TestEnv -> IO a) -> IO a
610withTestEnv :: ByteString -> (TestEnv -> IO a) -> IO a
597withTestEnv connstr cb =
611withTestEnv connstr cb =
598− withConn $ \conn ->
612+ withConn $ \conn -> do
613+ -- currently required for interval to work.
614+ -- we also test that this doesn't interfere with anything else
615+ execute_ conn "SET intervalstyle TO 'iso_8601'"
599 cb TestEnv
617 cb TestEnv
600 { conn = conn
618 { conn = conn
601 , withConn = withConn
619 , withConn = withConn
@@ -604,13 +622,27 @@ withTestEnv connstr cb =
604 withConn = bracket (connectPostgreSQL connstr) close
622 withConn = bracket (connectPostgreSQL connstr) close
606main :: IO ()
624main :: IO ()
607−main = do
625+main = withConnstring $ \connstring -> do
626+ withTestEnv connstring (defaultMain . tests)
628+withConnstring :: (BS8.ByteString -> IO ()) -> IO ()
629+withConnstring kont = do
608 env <- getEnvironment
630 env <- getEnvironment
609 case lookup "DATABASE_CONNSTRING" env of
631 case lookup "DATABASE_CONNSTRING" env of
632+ Just s -> kont (BS8.pack (special s))
633+ Nothing -> case lookup "GITHUB_ACTIONS" env of
634+ Just "true" -> kont (BS8.pack gha)
610− Nothing -> putStrLn "Set DATABASE_CONNSTRING environment variable"
635+ _ -> putStrLn "Set DATABASE_CONNSTRING environment variable"
611− Just s -> withTestEnv (BS8.pack (special s)) (defaultMain . tests)
613 -- https://www.appveyor.com/docs/services-databases/
637 -- https://www.appveyor.com/docs/services-databases/
614 special "appveyor" = "dbname='TestDb' user='postgres' password='Password12!'"
638 special "appveyor" = "dbname='TestDb' user='postgres' password='Password12!'"
615 special "travis" = ""
639 special "travis" = ""
616 special s = s
640 special s = s
643+ [ "dbname='postgres'"
645+ , "password='postgres'"