git.iko.soy/typeable/postgresql-simple
on ee417bd help sign in
typeable/postgresql-simple/test/Main.hs
364 lines 13 kB history raw
1{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE DoAndIfThenElse #-}
3{-# LANGUAGE ScopedTypeVariables #-}
4import Common
5import Database.PostgreSQL.Simple.FromField (FromField)
6import Database.PostgreSQL.Simple.Types(Query(..),Values(..))
7import Database.PostgreSQL.Simple.HStore
8import Database.PostgreSQL.Simple.Copy
9import qualified Database.PostgreSQL.Simple.Transaction as ST
10import Control.Applicative
11import Control.Exception as E
12import Control.Monad
13import Data.ByteString (ByteString)
14import Data.IORef
15import Data.Typeable
16import qualified Data.ByteString as B
17import Data.Map (Map)
18import Data.List (sort)
19import qualified Data.Map as Map
20import Data.Text(Text)
21import qualified Data.Text.Encoding as T
22import System.Exit (exitFailure)
23import System.IO
24import qualified Data.Vector as V
25import Data.Aeson
27import Notify
28import Serializable
29import Time
31tests :: [TestEnv -> Test]
32tests =
33 [ TestLabel "Bytea" . testBytea
34 , TestLabel "ExecuteMany" . testExecuteMany
35 , TestLabel "Fold" . testFold
36 , TestLabel "Notify" . testNotify
37 , TestLabel "Serializable" . testSerializable
38 , TestLabel "Time" . testTime
39 , TestLabel "Array" . testArray
40 , TestLabel "HStore" . testHStore
41 , TestLabel "JSON" . testJSON
42 , TestLabel "Savepoint" . testSavepoint
43 , TestLabel "Unicode" . testUnicode
44 , TestLabel "Values" . testValues
45 , TestLabel "Copy" . testCopy
46 , TestLabel "Double" . testDouble
47 ]
49testBytea :: TestEnv -> Test
50testBytea TestEnv{..} = TestList
51 [ testStr "empty" []
52 , testStr "\"hello\"" $ map (fromIntegral . fromEnum) ("hello" :: String)
53 , testStr "ascending" [0..255]
54 , testStr "descending" [255,254..0]
55 , testStr "ascending, doubled up" $ doubleUp [0..255]
56 , testStr "descending, doubled up" $ doubleUp [255,254..0]
57 ]
58 where
59 testStr label bytes = TestLabel label $ TestCase $ do
60 let bs = B.pack bytes
62 [Only h] <- query conn "SELECT md5(?::bytea)" [Binary bs]
63 assertBool "Haskell -> SQL conversion altered the string" $ md5 bs == h
65 [Only (Binary r)] <- query conn "SELECT ?::bytea" [Binary bs]
66 assertBool "SQL -> Haskell conversion altered the string" $ bs == r
68 doubleUp = concatMap (\x -> [x, x])
70testExecuteMany :: TestEnv -> Test
71testExecuteMany TestEnv{..} = TestCase $ do
72 execute_ conn "CREATE TEMPORARY TABLE tmp_executeMany (i INT, t TEXT, b BYTEA)"
74 let rows :: [(Int, String, Binary ByteString)]
75 rows = [ (1, "hello", Binary "bye")
76 , (2, "world", Binary "\0\r\t\n")
77 , (3, "?", Binary "")
78 ]
80 count <- executeMany conn "INSERT INTO tmp_executeMany VALUES (?, ?, ?)" rows
81 count @?= fromIntegral (length rows)
83 rows' <- query_ conn "SELECT * FROM tmp_executeMany"
84 rows' @?= rows
86 return ()
88testFold :: TestEnv -> Test
89testFold TestEnv{..} = TestCase $ do
90 xs <- fold_ conn "SELECT generate_series(1,10000)"
91 [] $ \xs (Only x) -> return (x:xs)
92 reverse xs @?= ([1..10000] :: [Int])
94 ref <- newIORef []
95 forEach conn "SELECT * FROM generate_series(1,?) a, generate_series(1,?) b"
96 (100 :: Int, 50 :: Int) $ \(a :: Int, b :: Int) -> do
97 xs <- readIORef ref
98 writeIORef ref $! (a,b):xs
99 xs <- readIORef ref
100 reverse xs @?= [(a,b) | a <- [1..100], b <- [1..50]]
102 -- Make sure fold propagates our exception.
103 ref <- newIORef []
104 True <- expectError (== TestException) $
105 forEach_ conn "SELECT generate_series(1,10)" $ \(Only a) ->
106 if a == 5 then do
107 -- Cause a SQL error to trip up CLOSE.
108 True <- expectError isSyntaxError $
109 execute_ conn "asdf"
110 True <- expectError ST.isFailedTransactionError $
111 (query_ conn "SELECT 1" :: IO [(Only Int)])
112 throwIO TestException
113 else do
114 xs <- readIORef ref
115 writeIORef ref $! (a :: Int) : xs
116 xs <- readIORef ref
117 reverse xs @?= [1..4]
119 withTransaction conn $ replicateM_ 2 $ do
120 xs <- fold_ conn "VALUES (1), (2), (3), (4), (5)"
121 [] $ \xs (Only x) -> return (x:xs)
122 reverse xs @?= ([1..5] :: [Int])
124 ref <- newIORef []
125 forEach_ conn "SELECT generate_series(1,101)" $ \(Only a) ->
126 forEach_ conn "SELECT generate_series(1,55)" $ \(Only b) -> do
127 xs <- readIORef ref
128 writeIORef ref $! (a :: Int, b :: Int) : xs
129 xs <- readIORef ref
130 reverse xs @?= [(a,b) | a <- [1..101], b <- [1..55]]
132 xs <- fold_ conn "SELECT 1 WHERE FALSE"
133 [] $ \xs (Only x) -> return (x:xs)
134 xs @?= ([] :: [Int])
136 -- TODO: add more complete tests, e.g.:
137 --
138 -- * Fold in a transaction
139 --
140 -- * Fold in a transaction after a previous fold has been performed
141 --
142 -- * Nested fold
144 return ()
146queryFailure :: forall a. (FromField a, Typeable a, Show a)
147 => Connection -> Query -> a -> Assertion
148queryFailure conn q resultType = do
149 x :: Either SomeException [Only a] <- E.try $ query_ conn q
150 case x of
151 Left _ -> return ()
152 Right val -> assertFailure ("Did not fail as expected: "
153 ++ show q
154 ++ " :: "
155 ++ show (typeOf resultType)
156 ++ " -> " ++ show val)
158testArray :: TestEnv -> Test
159testArray TestEnv{..} = TestCase $ do
160 xs <- query_ conn "SELECT '{1,2,3,4}'::_int4"
161 xs @?= [Only (V.fromList [1,2,3,4 :: Int])]
162 xs <- query_ conn "SELECT '{{1,2},{3,4}}'::_int4"
163 xs @?= [Only (V.fromList [V.fromList [1,2],
164 V.fromList [3,4 :: Int]])]
165 queryFailure conn "SELECT '{1,2,3,4}'::_int4" (undefined :: V.Vector Bool)
166 queryFailure conn "SELECT '{{1,2},{3,4}}'::_int4" (undefined :: V.Vector Int)
168testHStore :: TestEnv -> Test
169testHStore TestEnv{..} = TestCase $ do
170 execute_ conn "CREATE EXTENSION IF NOT EXISTS hstore"
171 roundTrip []
172 roundTrip [("foo","bar"),("bar","baz"),("baz","hello")]
173 roundTrip [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")]
174 where
175 roundTrip :: [(Text,Text)] -> Assertion
176 roundTrip xs = do
177 let m = Only (HStoreMap (Map.fromList xs))
178 m' <- query conn "SELECT ?::hstore" m
179 [m] @?= m'
181testJSON :: TestEnv -> Test
182testJSON TestEnv{..} = TestCase $ do
183 roundTrip (Map.fromList [] :: Map Text Text)
184 roundTrip (Map.fromList [("foo","bar"),("bar","baz"),("baz","hello")] :: Map Text Text)
185 roundTrip (Map.fromList [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")] :: Map Text Text)
186 roundTrip (V.fromList [1,2,3,4,5::Int])
187 roundTrip ("foo" :: Text)
188 roundTrip (42 :: Int)
189 where
190 roundTrip :: ToJSON a => a -> Assertion
191 roundTrip a = do
192 let js = Only (toJSON a)
193 js' <- query conn "SELECT ?::json" js
194 [js] @?= js'
196testSavepoint :: TestEnv -> Test
197testSavepoint TestEnv{..} = TestCase $ do
198 True <- expectError ST.isNoActiveTransactionError $
199 withSavepoint conn $ return ()
201 let getRows :: IO [Int]
202 getRows = map fromOnly <$> query_ conn "SELECT a FROM tmp_savepoint ORDER BY a"
203 withTransaction conn $ do
204 execute_ conn "CREATE TEMPORARY TABLE tmp_savepoint (a INT UNIQUE)"
205 execute_ conn "INSERT INTO tmp_savepoint VALUES (1)"
206 [1] <- getRows
208 withSavepoint conn $ do
209 execute_ conn "INSERT INTO tmp_savepoint VALUES (2)"
210 [1,2] <- getRows
211 return ()
212 [1,2] <- getRows
214 withSavepoint conn $ do
215 execute_ conn "INSERT INTO tmp_savepoint VALUES (3)"
216 [1,2,3] <- getRows
217 True <- expectError isUniqueViolation $
218 execute_ conn "INSERT INTO tmp_savepoint VALUES (2)"
219 True <- expectError ST.isFailedTransactionError getRows
221 -- Body returning successfully after handling error,
222 -- but 'withSavepoint' will roll back without complaining.
223 return ()
224 -- Rolling back clears the error condition.
225 [1,2] <- getRows
227 -- 'withSavepoint' will roll back after an exception, even if the
228 -- exception wasn't SQL-related.
229 True <- expectError (== TestException) $
230 withSavepoint conn $ do
231 execute_ conn "INSERT INTO tmp_savepoint VALUES (3)"
232 [1,2,3] <- getRows
233 throwIO TestException
234 [1,2] <- getRows
236 -- Nested savepoint can be rolled back while the
237 -- outer effects are retained.
238 withSavepoint conn $ do
239 execute_ conn "INSERT INTO tmp_savepoint VALUES (3)"
240 True <- expectError isUniqueViolation $
241 withSavepoint conn $ do
242 execute_ conn "INSERT INTO tmp_savepoint VALUES (4)"
243 [1,2,3,4] <- getRows
244 execute_ conn "INSERT INTO tmp_savepoint VALUES (4)"
245 [1,2,3] <- getRows
246 return ()
247 [1,2,3] <- getRows
249 return ()
251 -- Transaction committed successfully, even though there were errors
252 -- (but we rolled them back).
253 [1,2,3] <- getRows
255 return ()
257testUnicode :: TestEnv -> Test
258testUnicode TestEnv{..} = TestCase $ do
259 let q = Query . T.encodeUtf8 -- Handle encoding ourselves to ensure
260 -- the table gets created correctly.
261 let messages = map Only ["привет","мир"] :: [Only Text]
262 execute_ conn (q "CREATE TEMPORARY TABLE ру́сский (сообщение TEXT)")
263 executeMany conn "INSERT INTO ру́сский (сообщение) VALUES (?)" messages
264 messages' <- query_ conn "SELECT сообщение FROM ру́сский"
265 sort messages @?= sort messages'
267testValues :: TestEnv -> Test
268testValues TestEnv{..} = TestCase $ do
269 execute_ conn "CREATE TEMPORARY TABLE values_test (x int, y text)"
270 test (Values ["int4","text"] [])
271 test (Values ["int4","text"] [(1,"hello")])
272 test (Values ["int4","text"] [(1,"hello"),(2,"world")])
273 test (Values ["int4","text"] [(1,"hello"),(2,"world"),(3,"goodbye")])
274 test (Values [] [(1,"hello")])
275 test (Values [] [(1,"hello"),(2,"world")])
276 test (Values [] [(1,"hello"),(2,"world"),(3,"goodbye")])
277 where
278 test :: Values (Int, Text) -> Assertion
279 test table@(Values _ vals) = do
280 execute conn "INSERT INTO values_test ?" (Only table)
281 vals' <- query_ conn "DELETE FROM values_test RETURNING *"
282 sort vals @?= sort vals'
285testCopy :: TestEnv -> Test
286testCopy TestEnv{..} = TestCase $ do
287 execute_ conn "CREATE TEMPORARY TABLE copy_test (x int, y text)"
288 copy_ conn "COPY copy_test FROM STDIN (FORMAT CSV)"
289 mapM_ (putCopyData conn) copyRows
290 putCopyEnd conn
291 copy_ conn "COPY copy_test FROM STDIN (FORMAT CSV)"
292 mapM_ (putCopyData conn) abortRows
293 putCopyError conn "aborted"
294 -- Hmm, does postgres always produce \n as an end-of-line here, or
295 -- are there cases where it will use a \r\n as well?
296 copy_ conn "COPY copy_test TO STDOUT (FORMAT CSV)"
297 rows <- loop []
298 sort rows @?= sort copyRows
299 -- Now, let's just verify that the connection state is back to ready,
300 -- so that we can issue more queries:
301 [Only (x::Int)] <- query_ conn "SELECT 2 + 2"
302 x @?= 4
303 where
304 copyRows = ["1,foo\n"
305 ,"2,bar\n"]
306 abortRows = ["3,baz\n"]
307 loop rows = do
308 mrow <- getCopyData conn
309 case mrow of
310 CopyOutDone _ -> return rows
311 CopyOutRow row -> loop (row:rows)
313testDouble :: TestEnv -> Test
314testDouble TestEnv{..} = TestCase $ do
315 [Only (x :: Double)] <- query_ conn "SELECT 'NaN'::float8"
316 assertBool "expected NaN" (isNaN x)
317 [Only (x :: Double)] <- query_ conn "SELECT 'Infinity'::float8"
318 x @?= (1 / 0)
319 [Only (x :: Double)] <- query_ conn "SELECT '-Infinity'::float8"
320 x @?= (-1 / 0)
323data TestException
324 = TestException
325 deriving (Eq, Show, Typeable)
327instance Exception TestException
329expectError :: Exception e => (e -> Bool) -> IO a -> IO Bool
330expectError p io =
331 (io >> return False) `E.catch` \ex ->
332 if p ex then return True else throwIO ex
334isUniqueViolation :: SqlError -> Bool
335isUniqueViolation SqlError{..} = sqlState == "23505"
337isSyntaxError :: SqlError -> Bool
338isSyntaxError SqlError{..} = sqlState == "42601"
340------------------------------------------------------------------------
342-- | Action for connecting to the database that will be used for testing.
343--
344-- Note that some tests, such as Notify, use multiple connections, and assume
345-- that 'testConnect' connects to the same database every time it is called.
346testConnect :: IO Connection
347testConnect = connectPostgreSQL ""
349withTestEnv :: (TestEnv -> IO a) -> IO a
350withTestEnv cb =
351 withConn $ \conn ->
352 cb TestEnv
353 { conn = conn
354 , withConn = withConn
355 }
356 where
357 withConn = bracket testConnect close
359main :: IO ()
360main = do
361 mapM_ (`hSetBuffering` LineBuffering) [stdout, stderr]
362 Counts{cases, tried, errors, failures} <-
363 withTestEnv $ \env -> runTestTT $ TestList $ map ($ env) tests
364 when (cases /= tried || errors /= 0 || failures /= 0) $ exitFailure