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