@@ -3,25 +3,39 @@
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
14+import Database.PostgreSQL.Simple.Copy
15+import Database.PostgreSQL.Simple.ToField (ToField)
716import Database.PostgreSQL.Simple.FromField (FromField)
8−import Database.PostgreSQL.Simple.Types(Query(..),Values(..))
917import Database.PostgreSQL.Simple.HStore
10−import Database.PostgreSQL.Simple.Copy
18+import Database.PostgreSQL.Simple.Newtypes
19+import Database.PostgreSQL.Simple.Internal (breakOnSingleQuestionMark)
20+import Database.PostgreSQL.Simple.Types(Query(..),Values(..), PGArray(..))
1121import qualified Database.PostgreSQL.Simple.Transaction as ST
1222
1323import Control.Applicative
1424import Control.Exception as E
1525import Control.Monad
1626import Data.Char
17−import Data.List (sort)
27+import Data.Foldable (toList)
28+import Data.List (concat, sort)
1829import Data.IORef
30+import Data.Monoid ((<>))
31+import Data.String (fromString)
1932import Data.Typeable
2033import GHC.Generics (Generic)
2134
2235import Data.Aeson
2336import Data.ByteString (ByteString)
2437import qualified Data.ByteString as B
38+import qualified Data.ByteString.Char8 as BS8
2539import qualified Data.ByteString.Lazy.Char8 as BL
2640import Data.CaseInsensitive (CI)
2741import qualified Data.CaseInsensitive as CI
@@ -32,38 +46,46 @@ import qualified Data.Text.Encoding as T
3246import qualified Data.Vector as V
3347import System.FilePath
3448import System.Timeout(timeout)
35−import Data.Time(getCurrentTime, diffUTCTime)
49+import Data.Time.Compat (getCurrentTime, diffUTCTime)
50+import System.Environment (getEnvironment)
3651
3752import Test.Tasty
3853import Test.Tasty.Golden
3954import Notify
4055import Serializable
4156import Time
57+import Interval
58+import Exception (testExceptions)
4259
4360tests :: TestEnv -> TestTree
4461tests env = testGroup "tests"
4562 $ map ($ env)
4663 [ testBytea
47− , testCase "ExecuteMany" . testExecuteMany
48− , testCase "Fold" . testFold
49− , testCase "Notify" . testNotify
50− , testCase "Serializable" . testSerializable
51− , testCase "Time" . testTime
52− , testCase "Array" . testArray
53− , testCase "Array of nullables" . testNullableArray
54− , testCase "HStore" . testHStore
55− , testCase "citext" . testCIText
56− , testCase "JSON" . testJSON
57− , testCase "Savepoint" . testSavepoint
58− , testCase "Unicode" . testUnicode
59− , testCase "Values" . testValues
60− , testCase "Copy" . testCopy
64+ , testCase "ExecuteMany" . testExecuteMany
65+ , testCase "Fold" . testFold
66+ , testCase "Notify" . testNotify
67+ , testCase "Serializable" . testSerializable
68+ , testCase "Time" . testTime
69+ , testCase "Interval" . testInterval
70+ , testCase "Array" . testArray
71+ , testCase "Array of nullables" . testNullableArray
72+ , testCase "HStore" . testHStore
73+ , testCase "citext" . testCIText
74+ , testCase "JSON" . testJSON
75+ , testCase "Aeson newtype" . testAeson
76+ , testCase "DerivingVia" . testDerivingVia
77+ , testCase "Question mark escape" . testQM
78+ , testCase "Savepoint" . testSavepoint
79+ , testCase "Unicode" . testUnicode
80+ , testCase "Values" . testValues
81+ , testCase "Copy" . testCopy
6182 , testCopyFailures
62− , testCase "Double" . testDouble
63− , testCase "1-ary generic" . testGeneric1
64− , testCase "2-ary generic" . testGeneric2
65− , testCase "3-ary generic" . testGeneric3
66− , testCase "Timeout" . testTimeout
83+ , testCase "Double" . testDouble
84+ , testCase "1-ary generic" . testGeneric1
85+ , testCase "2-ary generic" . testGeneric2
86+ , testCase "3-ary generic" . testGeneric3
87+ , testCase "Timeout" . testTimeout
88+ , testCase "Exceptions" . testExceptions
6789 ]
6890
6991testBytea :: TestEnv -> TestTree
@@ -117,7 +139,7 @@ testFold TestEnv{..} = do
117139 xs <- readIORef ref
118140 writeIORef ref $! (a,b):xs
119141 xs <- readIORef ref
120− reverse xs @?= [(a,b) | a <- [1..100], b <- [1..50]]
142+ reverse xs @?= [(a,b) | b <- [1..50], a <- [1..100]]
121143
122144 -- Make sure fold propagates our exception.
123145 ref <- newIORef []
@@ -234,6 +256,90 @@ testJSON TestEnv{..} = do
234256 js' <- query conn "SELECT ?::json" js
235257 [js] @?= js'
236258
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+
293+testQM :: TestEnv -> Assertion
294+testQM TestEnv{..} = do
295+ -- Just test on a single string
296+ let testQuery' b = "testing for ?" <> b <> " and making sure "
297+ testQueryDoubleQM = testQuery' "?"
298+ testQueryRest = "? is substituted"
299+ testQuery = fromString $ testQueryDoubleQM <> testQueryRest
300+ -- expect the entire first part with double QMs replaced with literal '?'
301+ expected = (fromString $ testQuery' "", fromString testQueryRest)
302+ tried = breakOnSingleQuestionMark testQuery
303+ errMsg = concat
304+ [ "Failed to break on single question mark exclusively:\n"
305+ , "expected: ", show expected
306+ , "result: ", show tried
307+ ]
308+ assertBool errMsg $ tried == expected
309+
310+ -- Let's also test the question mark operators in action
311+ -- ? -> Does the string exist as a top-level key within the JSON value?
312+ positiveQuery "SELECT ?::jsonb ?? ?" (testObj, "foo" :: Text)
313+ negativeQuery "SELECT ?::jsonb ?? ?" (testObj, "baz" :: Text)
314+ negativeQuery "SELECT ?::jsonb ?? ?" (toJSON numArray, "1" :: Text)
315+ -- ?| -> Do any of these array strings exist as top-level keys?
316+ positiveQuery "SELECT ?::jsonb ??| ?" (testObj, PGArray ["nope","bar","6" :: Text])
317+ negativeQuery "SELECT ?::jsonb ??| ?" (testObj, PGArray ["nope","6" :: Text])
318+ negativeQuery "SELECT ?::jsonb ??| ?" (toJSON numArray, PGArray ["1","2","6" :: Text])
319+ -- ?& -> Do all of these array strings exist as top-level keys?
320+ positiveQuery "SELECT ?::jsonb ??& ?" (testObj, PGArray ["foo","bar","quux" :: Text])
321+ positiveQuery "SELECT ?::jsonb ??& ?" (testObj, PGArray ["foo","bar" :: Text])
322+ negativeQuery "SELECT ?::jsonb ??& ?" (testObj, PGArray ["foo","bar","baz" :: Text])
323+ negativeQuery "SELECT ?::jsonb ??& ?" (toJSON numArray, PGArray ["1","2","3","4","5" :: Text])
324+ -- Format error for 2 question marks, not 4
325+ True <- expectError (isFormatError 2) $
326+ (query conn "SELECT ?::jsonb ?? ?" $ Only testObj :: IO [Only Bool])
327+ return ()
328+ where positiveQuery :: ToRow a => Query -> a -> Assertion
329+ positiveQuery = boolQuery True
330+ negativeQuery :: ToRow a => Query -> a -> Assertion
331+ negativeQuery = boolQuery False
332+ numArray :: [Int]
333+ numArray = [1,2,3,4,5]
334+ boolQuery :: ToRow a => Bool -> Query -> a -> Assertion
335+ boolQuery b t x = do
336+ a <- query conn t x
337+ [Only b] @?= a
338+ testObj = toJSON (Map.fromList [("foo",toJSON (1 :: Int))
339+ ,("bar",String "baz")
340+ ,("quux",toJSON [1 :: Int,2,3,4,5])] :: Map Text Value
341+ )
342+
237343testSavepoint :: TestEnv -> Assertion
238344testSavepoint TestEnv{..} = do
239345 True <- expectError ST.isNoActiveTransactionError $
@@ -341,6 +447,14 @@ testCopy TestEnv{..} = do
341447 -- so that we can issue more queries:
342448 [Only (x::Int)] <- query_ conn "SELECT 2 + 2"
343449 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
344458 where
345459 copyRows = ["1,foo\n"
346460 ,"2,bar\n"]
@@ -360,12 +474,13 @@ testCopyFailures env = testGroup "Copy failures"
360474
361475goldenTest :: TestName -> IO BL.ByteString -> TestTree
362476goldenTest testName =
363− goldenVsString testName (resultsDir </> fileName<.>"expected")
477+ goldenVsStringDiff testName diff (resultsDir </> fileName<.>"expected")
364478 where
365479 resultsDir = "test" </> "results"
366480 fileName = map normalize testName
367481 normalize c | not (isAlpha c) = '-'
368482 | otherwise = c
483+ diff ref new = ["diff", "-u", ref, new]
369484
370485-- | Test that we provide a sensible error message on failure
371486testCopyUniqueConstraintError :: TestEnv -> TestTree
@@ -478,24 +593,56 @@ isUniqueViolation SqlError{..} = sqlState == "23505"
478593isSyntaxError :: SqlError -> Bool
479594isSyntaxError SqlError{..} = sqlState == "42601"
480595
596+isFormatError :: Int -> FormatError -> Bool
597+isFormatError i FormatError{..}
598+ | null fmtMessage = False
599+ | otherwise = fmtMessage == concat [ show i
600+ , " single '?' characters, but "
601+ , show (length fmtParams)
602+ , " parameters"
603+ ]
481604------------------------------------------------------------------------
482605
483606-- | Action for connecting to the database that will be used for testing.
484607--
485608-- Note that some tests, such as Notify, use multiple connections, and assume
486609-- that 'testConnect' connects to the same database every time it is called.
487−testConnect :: IO Connection
488−testConnect = connectPostgreSQL ""
610+withTestEnv :: ByteString -> (TestEnv -> IO a) -> IO a
611+withTestEnv connstr cb =
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'"
489616
490−withTestEnv :: (TestEnv -> IO a) -> IO a
491−withTestEnv cb =
492− withConn $ \conn ->
493617 cb TestEnv
494618 { conn = conn
495619 , withConn = withConn
496620 }
497621 where
498− withConn = bracket testConnect close
622+ withConn = bracket (connectPostgreSQL connstr) close
499623
500624main :: IO ()
501−main = withTestEnv $ defaultMain . tests
625+main = withConnstring $ \connstring -> do
626+ withTestEnv connstring (defaultMain . tests)
627+
628+withConnstring :: (BS8.ByteString -> IO ()) -> IO ()
629+withConnstring kont = do
630+ env <- getEnvironment
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)
635+ _ -> putStrLn "Set DATABASE_CONNSTRING environment variable"
636+ where
637+ -- https://www.appveyor.com/docs/services-databases/
638+ special "appveyor" = "dbname='TestDb' user='postgres' password='Password12!'"
639+ special "travis" = ""
640+ special s = s
641+
642+ gha = unwords
643+ [ "dbname='postgres'"
644+ , "user='postgres'"
645+ , "password='postgres'"
646+ , "host='postgres'"
647+ , "port=5432"
648+ ]