git.iko.soy/typeable/postgresql-simple
on dfbf5d9 help sign in
typeable/postgresql-simple/test/Main.hs
501 lines 18 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DeriveGeneric #-}
3{-# LANGUAGE DeriveDataTypeable #-}
4{-# LANGUAGE DoAndIfThenElse #-}
5{-# LANGUAGE ScopedTypeVariables #-}
6import Common
7import Database.PostgreSQL.Simple.FromField (FromField)
8import Database.PostgreSQL.Simple.Types(Query(..),Values(..))
9import Database.PostgreSQL.Simple.HStore
10import Database.PostgreSQL.Simple.Copy
11import qualified Database.PostgreSQL.Simple.Transaction as ST
13import Control.Applicative
14import Control.Exception as E
15import Control.Monad
16import Data.Char
17import Data.List (sort)
18import Data.IORef
19import Data.Typeable
20import GHC.Generics (Generic)
22import Data.Aeson
23import Data.ByteString (ByteString)
24import qualified Data.ByteString as B
25import qualified Data.ByteString.Lazy.Char8 as BL
26import Data.CaseInsensitive (CI)
27import qualified Data.CaseInsensitive as CI
28import Data.Map (Map)
29import qualified Data.Map as Map
30import Data.Text(Text)
31import qualified Data.Text.Encoding as T
32import qualified Data.Vector as V
33import System.FilePath
34import System.Timeout(timeout)
35import Data.Time(getCurrentTime, diffUTCTime)
37import Test.Tasty
38import Test.Tasty.Golden
39import Notify
40import Serializable
41import Time
43tests :: TestEnv -> TestTree
44tests env = testGroup "tests"
45 $ map ($ env)
46 [ 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
61 , 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
67 ]
69testBytea :: TestEnv -> TestTree
70testBytea TestEnv{..} = testGroup "Bytea"
71 [ testStr "empty" []
72 , testStr "\"hello\"" $ map (fromIntegral . fromEnum) ("hello" :: String)
73 , testStr "ascending" [0..255]
74 , testStr "descending" [255,254..0]
75 , testStr "ascending, doubled up" $ doubleUp [0..255]
76 , testStr "descending, doubled up" $ doubleUp [255,254..0]
77 ]
78 where
79 testStr label bytes = testCase label $ do
80 let bs = B.pack bytes
82 [Only h] <- query conn "SELECT md5(?::bytea)" [Binary bs]
83 assertBool "Haskell -> SQL conversion altered the string" $ md5 bs == h
85 [Only (Binary r)] <- query conn "SELECT ?::bytea" [Binary bs]
86 assertBool "SQL -> Haskell conversion altered the string" $ bs == r
88 doubleUp = concatMap (\x -> [x, x])
90testExecuteMany :: TestEnv -> Assertion
91testExecuteMany TestEnv{..} = do
92 execute_ conn "CREATE TEMPORARY TABLE tmp_executeMany (i INT, t TEXT, b BYTEA)"
94 let rows :: [(Int, String, Binary ByteString)]
95 rows = [ (1, "hello", Binary "bye")
96 , (2, "world", Binary "\0\r\t\n")
97 , (3, "?", Binary "")
98 ]
100 count <- executeMany conn "INSERT INTO tmp_executeMany VALUES (?, ?, ?)" rows
101 count @?= fromIntegral (length rows)
103 rows' <- query_ conn "SELECT * FROM tmp_executeMany"
104 rows' @?= rows
106 return ()
108testFold :: TestEnv -> Assertion
109testFold TestEnv{..} = do
110 xs <- fold_ conn "SELECT generate_series(1,10000)"
111 [] $ \xs (Only x) -> return (x:xs)
112 reverse xs @?= ([1..10000] :: [Int])
114 ref <- newIORef []
115 forEach conn "SELECT * FROM generate_series(1,?) a, generate_series(1,?) b"
116 (100 :: Int, 50 :: Int) $ \(a :: Int, b :: Int) -> do
117 xs <- readIORef ref
118 writeIORef ref $! (a,b):xs
119 xs <- readIORef ref
120 reverse xs @?= [(a,b) | a <- [1..100], b <- [1..50]]
122 -- Make sure fold propagates our exception.
123 ref <- newIORef []
124 True <- expectError (== TestException) $
125 forEach_ conn "SELECT generate_series(1,10)" $ \(Only a) ->
126 if a == 5 then do
127 -- Cause a SQL error to trip up CLOSE.
128 True <- expectError isSyntaxError $
129 execute_ conn "asdf"
130 True <- expectError ST.isFailedTransactionError $
131 (query_ conn "SELECT 1" :: IO [(Only Int)])
132 throwIO TestException
133 else do
134 xs <- readIORef ref
135 writeIORef ref $! (a :: Int) : xs
136 xs <- readIORef ref
137 reverse xs @?= [1..4]
139 withTransaction conn $ replicateM_ 2 $ do
140 xs <- fold_ conn "VALUES (1), (2), (3), (4), (5)"
141 [] $ \xs (Only x) -> return (x:xs)
142 reverse xs @?= ([1..5] :: [Int])
144 ref <- newIORef []
145 forEach_ conn "SELECT generate_series(1,101)" $ \(Only a) ->
146 forEach_ conn "SELECT generate_series(1,55)" $ \(Only b) -> do
147 xs <- readIORef ref
148 writeIORef ref $! (a :: Int, b :: Int) : xs
149 xs <- readIORef ref
150 reverse xs @?= [(a,b) | a <- [1..101], b <- [1..55]]
152 xs <- fold_ conn "SELECT 1 WHERE FALSE"
153 [] $ \xs (Only x) -> return (x:xs)
154 xs @?= ([] :: [Int])
156 -- TODO: add more complete tests, e.g.:
157 --
158 -- * Fold in a transaction
159 --
160 -- * Fold in a transaction after a previous fold has been performed
161 --
162 -- * Nested fold
164 return ()
166queryFailure :: forall a. (FromField a, Typeable a, Show a)
167 => Connection -> Query -> a -> Assertion
168queryFailure conn q resultType = do
169 x :: Either SomeException [Only a] <- E.try $ query_ conn q
170 case x of
171 Left _ -> return ()
172 Right val -> assertFailure ("Did not fail as expected: "
173 ++ show q
174 ++ " :: "
175 ++ show (typeOf resultType)
176 ++ " -> " ++ show val)
178testArray :: TestEnv -> Assertion
179testArray TestEnv{..} = do
180 xs <- query_ conn "SELECT '{1,2,3,4}'::_int4"
181 xs @?= [Only (V.fromList [1,2,3,4 :: Int])]
182 xs <- query_ conn "SELECT '{{1,2},{3,4}}'::_int4"
183 xs @?= [Only (V.fromList [V.fromList [1,2],
184 V.fromList [3,4 :: Int]])]
185 queryFailure conn "SELECT '{1,2,3,4}'::_int4" (undefined :: V.Vector Bool)
186 queryFailure conn "SELECT '{{1,2},{3,4}}'::_int4" (undefined :: V.Vector Int)
188testNullableArray :: TestEnv -> Assertion
189testNullableArray TestEnv{..} = do
190 xs <- query_ conn "SELECT '{sometext, \"NULL\"}'::_text"
191 xs @?= [Only (V.fromList ["sometext", "NULL" :: Text])]
192 xs <- query_ conn "SELECT '{sometext, NULL}'::_text"
193 xs @?= [Only (V.fromList [Just "sometext", Nothing :: Maybe Text])]
194 queryFailure conn "SELECT '{sometext, NULL}'::_text" (undefined :: V.Vector Text)
196testHStore :: TestEnv -> Assertion
197testHStore TestEnv{..} = do
198 execute_ conn "CREATE EXTENSION IF NOT EXISTS hstore"
199 roundTrip []
200 roundTrip [("foo","bar"),("bar","baz"),("baz","hello")]
201 roundTrip [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")]
202 where
203 roundTrip :: [(Text,Text)] -> Assertion
204 roundTrip xs = do
205 let m = Only (HStoreMap (Map.fromList xs))
206 m' <- query conn "SELECT ?::hstore" m
207 [m] @?= m'
209testCIText :: TestEnv -> Assertion
210testCIText TestEnv{..} = do
211 execute_ conn "CREATE EXTENSION IF NOT EXISTS citext"
212 roundTrip (CI.mk "")
213 roundTrip (CI.mk "UPPERCASE")
214 roundTrip (CI.mk "lowercase")
215 where
216 roundTrip :: (CI Text) -> Assertion
217 roundTrip cit = do
218 let toPostgres = Only cit
219 fromPostgres <- query conn "SELECT ?::citext" toPostgres
220 [toPostgres] @?= fromPostgres
222testJSON :: TestEnv -> Assertion
223testJSON TestEnv{..} = do
224 roundTrip (Map.fromList [] :: Map Text Text)
225 roundTrip (Map.fromList [("foo","bar"),("bar","baz"),("baz","hello")] :: Map Text Text)
226 roundTrip (Map.fromList [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")] :: Map Text Text)
227 roundTrip (V.fromList [1,2,3,4,5::Int])
228 roundTrip ("foo" :: Text)
229 roundTrip (42 :: Int)
230 where
231 roundTrip :: ToJSON a => a -> Assertion
232 roundTrip a = do
233 let js = Only (toJSON a)
234 js' <- query conn "SELECT ?::json" js
235 [js] @?= js'
237testSavepoint :: TestEnv -> Assertion
238testSavepoint TestEnv{..} = do
239 True <- expectError ST.isNoActiveTransactionError $
240 withSavepoint conn $ return ()
242 let getRows :: IO [Int]
243 getRows = map fromOnly <$> query_ conn "SELECT a FROM tmp_savepoint ORDER BY a"
244 withTransaction conn $ do
245 execute_ conn "CREATE TEMPORARY TABLE tmp_savepoint (a INT UNIQUE)"
246 execute_ conn "INSERT INTO tmp_savepoint VALUES (1)"
247 [1] <- getRows
249 withSavepoint conn $ do
250 execute_ conn "INSERT INTO tmp_savepoint VALUES (2)"
251 [1,2] <- getRows
252 return ()
253 [1,2] <- getRows
255 withSavepoint conn $ do
256 execute_ conn "INSERT INTO tmp_savepoint VALUES (3)"
257 [1,2,3] <- getRows
258 True <- expectError isUniqueViolation $
259 execute_ conn "INSERT INTO tmp_savepoint VALUES (2)"
260 True <- expectError ST.isFailedTransactionError getRows
262 -- Body returning successfully after handling error,
263 -- but 'withSavepoint' will roll back without complaining.
264 return ()
265 -- Rolling back clears the error condition.
266 [1,2] <- getRows
268 -- 'withSavepoint' will roll back after an exception, even if the
269 -- exception wasn't SQL-related.
270 True <- expectError (== TestException) $
271 withSavepoint conn $ do
272 execute_ conn "INSERT INTO tmp_savepoint VALUES (3)"
273 [1,2,3] <- getRows
274 throwIO TestException
275 [1,2] <- getRows
277 -- Nested savepoint can be rolled back while the
278 -- outer effects are retained.
279 withSavepoint conn $ do
280 execute_ conn "INSERT INTO tmp_savepoint VALUES (3)"
281 True <- expectError isUniqueViolation $
282 withSavepoint conn $ do
283 execute_ conn "INSERT INTO tmp_savepoint VALUES (4)"
284 [1,2,3,4] <- getRows
285 execute_ conn "INSERT INTO tmp_savepoint VALUES (4)"
286 [1,2,3] <- getRows
287 return ()
288 [1,2,3] <- getRows
290 return ()
292 -- Transaction committed successfully, even though there were errors
293 -- (but we rolled them back).
294 [1,2,3] <- getRows
296 return ()
298testUnicode :: TestEnv -> Assertion
299testUnicode TestEnv{..} = do
300 let q = Query . T.encodeUtf8 -- Handle encoding ourselves to ensure
301 -- the table gets created correctly.
302 let messages = map Only ["привет","мир"] :: [Only Text]
303 execute_ conn (q "CREATE TEMPORARY TABLE ру́сский (сообщение TEXT)")
304 executeMany conn "INSERT INTO ру́сский (сообщение) VALUES (?)" messages
305 messages' <- query_ conn "SELECT сообщение FROM ру́сский"
306 sort messages @?= sort messages'
308testValues :: TestEnv -> Assertion
309testValues TestEnv{..} = do
310 execute_ conn "CREATE TEMPORARY TABLE values_test (x int, y text)"
311 test (Values ["int4","text"] [])
312 test (Values ["int4","text"] [(1,"hello")])
313 test (Values ["int4","text"] [(1,"hello"),(2,"world")])
314 test (Values ["int4","text"] [(1,"hello"),(2,"world"),(3,"goodbye")])
315 test (Values [] [(1,"hello")])
316 test (Values [] [(1,"hello"),(2,"world")])
317 test (Values [] [(1,"hello"),(2,"world"),(3,"goodbye")])
318 where
319 test :: Values (Int, Text) -> Assertion
320 test table@(Values _ vals) = do
321 execute conn "INSERT INTO values_test ?" (Only table)
322 vals' <- query_ conn "DELETE FROM values_test RETURNING *"
323 sort vals @?= sort vals'
326testCopy :: TestEnv -> Assertion
327testCopy TestEnv{..} = do
328 execute_ conn "CREATE TEMPORARY TABLE copy_test (x int, y text)"
329 copy_ conn "COPY copy_test FROM STDIN (FORMAT CSV)"
330 mapM_ (putCopyData conn) copyRows
331 putCopyEnd conn
332 copy_ conn "COPY copy_test FROM STDIN (FORMAT CSV)"
333 mapM_ (putCopyData conn) abortRows
334 putCopyError conn "aborted"
335 -- Hmm, does postgres always produce \n as an end-of-line here, or
336 -- are there cases where it will use a \r\n as well?
337 copy_ conn "COPY copy_test TO STDOUT (FORMAT CSV)"
338 rows <- loop []
339 sort rows @?= sort copyRows
340 -- Now, let's just verify that the connection state is back to ready,
341 -- so that we can issue more queries:
342 [Only (x::Int)] <- query_ conn "SELECT 2 + 2"
343 x @?= 4
344 where
345 copyRows = ["1,foo\n"
346 ,"2,bar\n"]
347 abortRows = ["3,baz\n"]
348 loop rows = do
349 mrow <- getCopyData conn
350 case mrow of
351 CopyOutDone _ -> return rows
352 CopyOutRow row -> loop (row:rows)
354testCopyFailures :: TestEnv -> TestTree
355testCopyFailures env = testGroup "Copy failures"
356 $ map ($ env)
357 [ testCopyUniqueConstraintError
358 , testCopyMalformedError
359 ]
361goldenTest :: TestName -> IO BL.ByteString -> TestTree
362goldenTest testName =
363 goldenVsString testName (resultsDir </> fileName<.>"expected")
364 where
365 resultsDir = "test" </> "results"
366 fileName = map normalize testName
367 normalize c | not (isAlpha c) = '-'
368 | otherwise = c
370-- | Test that we provide a sensible error message on failure
371testCopyUniqueConstraintError :: TestEnv -> TestTree
372testCopyUniqueConstraintError TestEnv{..} =
373 goldenTest "unique constraint violation"
374 $ handle (\(SomeException exc) -> return $ BL.pack $ show exc) $ do
375 execute_ conn "CREATE TEMPORARY TABLE copy_unique_constraint_error_test (x int PRIMARY KEY, y text)"
376 copy_ conn "COPY copy_unique_constraint_error_test FROM STDIN (FORMAT CSV)"
377 mapM_ (putCopyData conn) copyRows
378 _n <- putCopyEnd conn
379 return BL.empty
380 where
381 copyRows = ["1,foo\n"
382 ,"2,bar\n"
383 ,"1,baz\n"]
385testCopyMalformedError :: TestEnv -> TestTree
386testCopyMalformedError TestEnv{..} =
387 goldenTest "malformed input"
388 $ handle (\(SomeException exc) -> return $ BL.pack $ show exc) $ do
389 execute_ conn "CREATE TEMPORARY TABLE copy_malformed_input_error_test (x int PRIMARY KEY, y text)"
390 copy_ conn "COPY copy_unique_constraint_error_test FROM STDIN (FORMAT CSV)"
391 mapM_ (putCopyData conn) copyRows
392 _n <- putCopyEnd conn
393 return BL.empty
394 where
395 copyRows = ["1,foo\n"
396 ,"2,bar\n"
397 ,"z,baz\n"]
399testTimeout :: TestEnv -> Assertion
400testTimeout TestEnv{..} =
401 withConn $ \c -> do
402 start_t <- getCurrentTime
403 res <- timeout 200000 $ do
404 withTransaction c $ do
405 query_ c "SELECT pg_sleep(1)" :: IO [Only ()]
406 end_t <- getCurrentTime
407 assertBool "Timeout did not occur" (res == Nothing)
408#if !defined(mingw32_HOST_OS)
409-- At the moment, you cannot timely abandon queries with async exceptions on
410-- Windows.
411 let d = end_t `diffUTCTime` start_t
412 assertBool "Timeout didn't work in a timely fashion" (0.1 < d && d < 0.6)
413#endif
415testDouble :: TestEnv -> Assertion
416testDouble TestEnv{..} = do
417 [Only (x :: Double)] <- query_ conn "SELECT 'NaN'::float8"
418 assertBool "expected NaN" (isNaN x)
419 [Only (x :: Double)] <- query_ conn "SELECT 'Infinity'::float8"
420 x @?= (1 / 0)
421 [Only (x :: Double)] <- query_ conn "SELECT '-Infinity'::float8"
422 x @?= (-1 / 0)
425testGeneric1 :: TestEnv -> Assertion
426testGeneric1 TestEnv{..} = do
427 roundTrip conn (Gen1 123)
428 where
429 roundTrip conn x0 = do
430 r <- query conn "SELECT ?::int" (x0 :: Gen1)
431 r @?= [x0]
433testGeneric2 :: TestEnv -> Assertion
434testGeneric2 TestEnv{..} = do
435 roundTrip conn (Gen2 123 "asdf")
436 where
437 roundTrip conn x0 = do
438 r <- query conn "SELECT ?::int, ?::text" x0
439 r @?= [x0]
441testGeneric3 :: TestEnv -> Assertion
442testGeneric3 TestEnv{..} = do
443 roundTrip conn (Gen3 123 "asdf" True)
444 where
445 roundTrip conn x0 = do
446 r <- query conn "SELECT ?::int, ?::text, ?::bool" x0
447 r @?= [x0]
449data Gen1 = Gen1 Int
450 deriving (Show,Eq,Generic)
451instance FromRow Gen1
452instance ToRow Gen1
454data Gen2 = Gen2 Int Text
455 deriving (Show,Eq,Generic)
456instance FromRow Gen2
457instance ToRow Gen2
459data Gen3 = Gen3 Int Text Bool
460 deriving (Show,Eq,Generic)
461instance FromRow Gen3
462instance ToRow Gen3
464data TestException
465 = TestException
466 deriving (Eq, Show, Typeable)
468instance Exception TestException
470expectError :: Exception e => (e -> Bool) -> IO a -> IO Bool
471expectError p io =
472 (io >> return False) `E.catch` \ex ->
473 if p ex then return True else throwIO ex
475isUniqueViolation :: SqlError -> Bool
476isUniqueViolation SqlError{..} = sqlState == "23505"
478isSyntaxError :: SqlError -> Bool
479isSyntaxError SqlError{..} = sqlState == "42601"
481------------------------------------------------------------------------
483-- | Action for connecting to the database that will be used for testing.
484--
485-- Note that some tests, such as Notify, use multiple connections, and assume
486-- that 'testConnect' connects to the same database every time it is called.
487testConnect :: IO Connection
488testConnect = connectPostgreSQL ""
490withTestEnv :: (TestEnv -> IO a) -> IO a
491withTestEnv cb =
492 withConn $ \conn ->
493 cb TestEnv
494 { conn = conn
495 , withConn = withConn
496 }
497 where
498 withConn = bracket testConnect close
500main :: IO ()
501main = withTestEnv $ defaultMain . tests