@@ -3,10 +3,19 @@
33{-# LANGUAGE DeriveDataTypeable #-}
44{-# LANGUAGE DoAndIfThenElse #-}
55{-# LANGUAGE ScopedTypeVariables #-}
6+#if __GLASGOW_HASKELL__ >= 806
7+{-# LANGUAGE DerivingStrategies #-}
8+{-# LANGUAGE DerivingVia #-}
9+{-# LANGUAGE DeriveAnyClass #-}
10+#endif
11+module Main (main) where
12+
613import Common
714import Database.PostgreSQL.Simple.Copy
15+import Database.PostgreSQL.Simple.ToField (ToField)
816import Database.PostgreSQL.Simple.FromField (FromField)
917import Database.PostgreSQL.Simple.HStore
18+import Database.PostgreSQL.Simple.Newtypes
1019import Database.PostgreSQL.Simple.Internal (breakOnSingleQuestionMark)
1120import Database.PostgreSQL.Simple.Types(Query(..),Values(..), PGArray(..))
1221import qualified Database.PostgreSQL.Simple.Transaction as ST
@@ -15,6 +24,7 @@ import Control.Applicative
1524import Control.Exception as E
1625import Control.Monad
1726import Data.Char
27+import Data.Foldable (toList)
1828import Data.List (concat, sort)
1929import Data.IORef
2030import Data.Monoid ((<>))
@@ -36,7 +46,7 @@ import qualified Data.Text.Encoding as T
3646import qualified Data.Vector as V
3747import System.FilePath
3848import System.Timeout(timeout)
39−import Data.Time(getCurrentTime, diffUTCTime)
49+import Data.Time.Compat (getCurrentTime, diffUTCTime)
4050import System.Environment (getEnvironment)
4151
4252import Test.Tasty
@@ -44,6 +54,8 @@ import Test.Tasty.Golden
4454import Notify
4555import Serializable
4656import Time
57+import Interval
58+import Exception (testExceptions)
4759
4860tests :: TestEnv -> TestTree
4961tests env = testGroup "tests"
@@ -54,11 +66,14 @@ tests env = testGroup "tests"
5466 , testCase "Notify" . testNotify
5567 , testCase "Serializable" . testSerializable
5668 , testCase "Time" . testTime
69+ , testCase "Interval" . testInterval
5770 , testCase "Array" . testArray
5871 , testCase "Array of nullables" . testNullableArray
5972 , testCase "HStore" . testHStore
6073 , testCase "citext" . testCIText
6174 , testCase "JSON" . testJSON
75+ , testCase "Aeson newtype" . testAeson
76+ , testCase "DerivingVia" . testDerivingVia
6277 , testCase "Question mark escape" . testQM
6378 , testCase "Savepoint" . testSavepoint
6479 , testCase "Unicode" . testUnicode
@@ -70,6 +85,7 @@ tests env = testGroup "tests"
7085 , testCase "2-ary generic" . testGeneric2
7186 , testCase "3-ary generic" . testGeneric3
7287 , testCase "Timeout" . testTimeout
88+ , testCase "Exceptions" . testExceptions
7389 ]
7490
7591testBytea :: TestEnv -> TestTree
@@ -123,7 +139,7 @@ testFold TestEnv{..} = do
123139 xs <- readIORef ref
124140 writeIORef ref $! (a,b):xs
125141 xs <- readIORef ref
126− reverse xs @?= [(a,b) | a <- [1..100], b <- [1..50]]
142+ reverse xs @?= [(a,b) | b <- [1..50], a <- [1..100]]
127143
128144 -- Make sure fold propagates our exception.
129145 ref <- newIORef []
@@ -240,6 +256,40 @@ testJSON TestEnv{..} = do
240256 js' <- query conn "SELECT ?::json" js
241257 [js] @?= js'
242258
259+testAeson :: TestEnv -> Assertion
260+testAeson TestEnv{..} = do
261+ roundTrip (Map.fromList [] :: Map Text Text)
262+ roundTrip (Map.fromList [("foo","bar"),("bar","baz"),("baz","hello")] :: Map Text Text)
263+ roundTrip (Map.fromList [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")] :: Map Text Text)
264+ roundTrip (V.fromList [1,2,3,4,5::Int])
265+ roundTrip ("foo" :: Text)
266+ roundTrip (42 :: Int)
267+ where
268+ roundTrip :: (Eq a, Show a, Typeable a, ToJSON a, FromJSON a)=> a -> Assertion
269+ roundTrip x = do
270+ y <- query conn "SELECT ?::json" (Only (Aeson x))
271+ [Only (Aeson x)] @?= y
272+
273+testDerivingVia :: TestEnv -> Assertion
274+testDerivingVia TestEnv{..} = do
275+#if __GLASGOW_HASKELL__ <806
276+ return ()
277+#else
278+ roundTrip $ DerivingVia1 42 "Meaning of Life"
279+ where
280+ roundTrip :: (Eq a, Show a, Typeable a, ToField a, FromField a)=> a -> Assertion
281+ roundTrip x = do
282+ y <- query conn "SELECT ?::json" (Only x)
283+ [Only x] @?= y
284+
285+data DerivingVia1 = DerivingVia1 Int String
286+ deriving stock (Eq, Show, Generic)
287+ deriving anyclass (FromJSON, ToJSON)
288+ deriving (ToField, FromField) via Aeson DerivingVia1
289+
290+#endif
291+
292+
243293testQM :: TestEnv -> Assertion
244294testQM TestEnv{..} = do
245295 -- Just test on a single string
@@ -397,6 +447,14 @@ testCopy TestEnv{..} = do
397447 -- so that we can issue more queries:
398448 [Only (x::Int)] <- query_ conn "SELECT 2 + 2"
399449 x @?= 4
450+ -- foldCopyData
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))
455+ []
456+ sort acc @?= sort copyRows
457+ count @?= 2
400458 where
401459 copyRows = ["1,foo\n"
402460 ,"2,bar\n"]
@@ -416,12 +474,13 @@ testCopyFailures env = testGroup "Copy failures"
416474
417475goldenTest :: TestName -> IO BL.ByteString -> TestTree
418476goldenTest testName =
419− goldenVsString testName (resultsDir </> fileName<.>"expected")
477+ goldenVsStringDiff testName diff (resultsDir </> fileName<.>"expected")
420478 where
421479 resultsDir = "test" </> "results"
422480 fileName = map normalize testName
423481 normalize c | not (isAlpha c) = '-'
424482 | otherwise = c
483+ diff ref new = ["diff", "-u", ref, new]
425484
426485-- | Test that we provide a sensible error message on failure
427486testCopyUniqueConstraintError :: TestEnv -> TestTree
@@ -550,7 +609,11 @@ isFormatError i FormatError{..}
550609-- that 'testConnect' connects to the same database every time it is called.
551610withTestEnv :: ByteString -> (TestEnv -> IO a) -> IO a
552611withTestEnv connstr cb =
553− 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'"
616+
554617 cb TestEnv
555618 { conn = conn
556619 , withConn = withConn
@@ -559,13 +622,27 @@ withTestEnv connstr cb =
559622 withConn = bracket (connectPostgreSQL connstr) close
560623
561624main :: IO ()
562−main = do
625+main = withConnstring $ \connstring -> do
626+ withTestEnv connstring (defaultMain . tests)
627+
628+withConnstring :: (BS8.ByteString -> IO ()) -> IO ()
629+withConnstring kont = do
563630 env <- getEnvironment
564631 case lookup "DATABASE_CONNSTRING" env of
565− Nothing -> putStrLn "Set DATABASE_CONNSTRING environment variable"
566− Just s -> withTestEnv (BS8.pack (special s)) (defaultMain . tests)
567− where
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"
636+ where
568637 -- https://www.appveyor.com/docs/services-databases/
569638 special "appveyor" = "dbname='TestDb' user='postgres' password='Password12!'"
570639 special "travis" = ""
571640 special s = s
641+
642+ gha = unwords
643+ [ "dbname='postgres'"
644+ , "user='postgres'"
645+ , "password='postgres'"
646+ , "host='postgres'"
647+ , "port=5432"
648+ ]