@@ -3,39 +3,25 @@
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−
136import Common
14−import Database.PostgreSQL.Simple.Copy
15−import Database.PostgreSQL.Simple.ToField (ToField)
167import Database.PostgreSQL.Simple.FromField (FromField)
8+import Database.PostgreSQL.Simple.Types(Query(..),Values(..))
179import Database.PostgreSQL.Simple.HStore
18−import Database.PostgreSQL.Simple.Newtypes
19−import Database.PostgreSQL.Simple.Internal (breakOnSingleQuestionMark)
20−import Database.PostgreSQL.Simple.Types(Query(..),Values(..), PGArray(..))
10+import Database.PostgreSQL.Simple.Copy
2111import qualified Database.PostgreSQL.Simple.Transaction as ST
2212
2313import Control.Applicative
2414import Control.Exception as E
2515import Control.Monad
2616import Data.Char
27−import Data.Foldable (toList)
28−import Data.List (concat, sort)
17+import Data.List (sort)
2918import Data.IORef
30−import Data.Monoid ((<>))
31−import Data.String (fromString)
3219import Data.Typeable
3320import GHC.Generics (Generic)
3421
3522import Data.Aeson
3623import Data.ByteString (ByteString)
3724import qualified Data.ByteString as B
38−import qualified Data.ByteString.Char8 as BS8
3925import qualified Data.ByteString.Lazy.Char8 as BL
4026import Data.CaseInsensitive (CI)
4127import qualified Data.CaseInsensitive as CI
@@ -46,46 +32,38 @@ import qualified Data.Text.Encoding as T
4632import qualified Data.Vector as V
4733import System.FilePath
4834import System.Timeout(timeout)
49−import Data.Time.Compat (getCurrentTime, diffUTCTime)
50−import System.Environment (getEnvironment)
35+import Data.Time(getCurrentTime, diffUTCTime)
5136
5237import Test.Tasty
5338import Test.Tasty.Golden
5439import Notify
5540import Serializable
5641import Time
57−import Interval
58−import Exception (testExceptions)
5942
6043tests :: TestEnv -> TestTree
6144tests env = testGroup "tests"
6245 $ map ($ env)
6346 [ testBytea
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
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
8261 , testCopyFailures
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
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
8967 ]
9068
9169testBytea :: TestEnv -> TestTree
@@ -139,7 +117,7 @@ testFold TestEnv{..} = do
139117 xs <- readIORef ref
140118 writeIORef ref $! (a,b):xs
141119 xs <- readIORef ref
142− reverse xs @?= [(a,b) | b <- [1..50], a <- [1..100]]
120+ reverse xs @?= [(a,b) | a <- [1..100], b <- [1..50]]
143121
144122 -- Make sure fold propagates our exception.
145123 ref <- newIORef []
@@ -256,90 +234,6 @@ testJSON TestEnv{..} = do
256234 js' <- query conn "SELECT ?::json" js
257235 [js] @?= js'
258236
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−
343237testSavepoint :: TestEnv -> Assertion
344238testSavepoint TestEnv{..} = do
345239 True <- expectError ST.isNoActiveTransactionError $
@@ -447,14 +341,6 @@ testCopy TestEnv{..} = do
447341 -- so that we can issue more queries:
448342 [Only (x::Int)] <- query_ conn "SELECT 2 + 2"
449343 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
458344 where
459345 copyRows = ["1,foo\n"
460346 ,"2,bar\n"]
@@ -474,13 +360,12 @@ testCopyFailures env = testGroup "Copy failures"
474360
475361goldenTest :: TestName -> IO BL.ByteString -> TestTree
476362goldenTest testName =
477− goldenVsStringDiff testName diff (resultsDir </> fileName<.>"expected")
363+ goldenVsString testName (resultsDir </> fileName<.>"expected")
478364 where
479365 resultsDir = "test" </> "results"
480366 fileName = map normalize testName
481367 normalize c | not (isAlpha c) = '-'
482368 | otherwise = c
483− diff ref new = ["diff", "-u", ref, new]
484369
485370-- | Test that we provide a sensible error message on failure
486371testCopyUniqueConstraintError :: TestEnv -> TestTree
@@ -593,56 +478,24 @@ isUniqueViolation SqlError{..} = sqlState == "23505"
593478isSyntaxError :: SqlError -> Bool
594479isSyntaxError SqlError{..} = sqlState == "42601"
595480
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− ]
604481------------------------------------------------------------------------
605482
606483-- | Action for connecting to the database that will be used for testing.
607484--
608485-- Note that some tests, such as Notify, use multiple connections, and assume
609486-- that 'testConnect' connects to the same database every time it is called.
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'"
487+testConnect :: IO Connection
488+testConnect = connectPostgreSQL ""
616489
490+withTestEnv :: (TestEnv -> IO a) -> IO a
491+withTestEnv cb =
492+ withConn $ \conn ->
617493 cb TestEnv
618494 { conn = conn
619495 , withConn = withConn
620496 }
621497 where
622− withConn = bracket (connectPostgreSQL connstr) close
498+ withConn = bracket testConnect close
623499
624500main :: IO ()
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− ]
501+main = withTestEnv $ defaultMain . tests