git.iko.soy/typeable/postgresql-simple
on 63a00b2 help sign in
typeable/postgresql-simple/test/Main.hs
271 lines 9.6 kB history raw
1{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE DoAndIfThenElse #-}
3{-# LANGUAGE ScopedTypeVariables #-}
4import Common
5import Database.PostgreSQL.Simple.FromField (FromField)
6import Database.PostgreSQL.Simple.HStore
7import qualified Database.PostgreSQL.Simple.Transaction as ST
8import Control.Applicative
9import Control.Exception as E
10import Control.Monad
11import Data.ByteString (ByteString)
12import Data.IORef
13import Data.Typeable
14import qualified Data.ByteString as B
15import qualified Data.Map as Map
16import Data.Text(Text)
17import System.Exit (exitFailure)
18import System.IO
19import qualified Data.Vector as V
21import Notify
22import Serializable
23import Time
25tests :: [TestEnv -> Test]
26tests =
27 [ TestLabel "Bytea" . testBytea
28 , TestLabel "ExecuteMany" . testExecuteMany
29 , TestLabel "Fold" . testFold
30 , TestLabel "Notify" . testNotify
31 , TestLabel "Serializable" . testSerializable
32 , TestLabel "Time" . testTime
33 , TestLabel "Array" . testArray
34 , TestLabel "HStore" . testHStore
35 , TestLabel "Savepoint" . testSavepoint
36 ]
38testBytea :: TestEnv -> Test
39testBytea TestEnv{..} = TestList
40 [ testStr "empty" []
41 , testStr "\"hello\"" $ map (fromIntegral . fromEnum) ("hello" :: String)
42 , testStr "ascending" [0..255]
43 , testStr "descending" [255,254..0]
44 , testStr "ascending, doubled up" $ doubleUp [0..255]
45 , testStr "descending, doubled up" $ doubleUp [255,254..0]
46 ]
47 where
48 testStr label bytes = TestLabel label $ TestCase $ do
49 let bs = B.pack bytes
51 [Only h] <- query conn "SELECT md5(?::bytea)" [Binary bs]
52 assertBool "Haskell -> SQL conversion altered the string" $ md5 bs == h
54 [Only (Binary r)] <- query conn "SELECT ?::bytea" [Binary bs]
55 assertBool "SQL -> Haskell conversion altered the string" $ bs == r
57 doubleUp = concatMap (\x -> [x, x])
59testExecuteMany :: TestEnv -> Test
60testExecuteMany TestEnv{..} = TestCase $ do
61 execute_ conn "CREATE TEMPORARY TABLE tmp_executeMany (i INT, t TEXT, b BYTEA)"
63 let rows :: [(Int, String, Binary ByteString)]
64 rows = [ (1, "hello", Binary "bye")
65 , (2, "world", Binary "\0\r\t\n")
66 , (3, "?", Binary "")
67 ]
69 count <- executeMany conn "INSERT INTO tmp_executeMany VALUES (?, ?, ?)" rows
70 count @?= fromIntegral (length rows)
72 rows' <- query_ conn "SELECT * FROM tmp_executeMany"
73 rows' @?= rows
75 return ()
77testFold :: TestEnv -> Test
78testFold TestEnv{..} = TestCase $ do
79 xs <- fold_ conn "SELECT generate_series(1,10000)"
80 [] $ \xs (Only x) -> return (x:xs)
81 reverse xs @?= ([1..10000] :: [Int])
83 ref <- newIORef []
84 forEach conn "SELECT * FROM generate_series(1,?) a, generate_series(1,?) b"
85 (100 :: Int, 50 :: Int) $ \(a :: Int, b :: Int) -> do
86 xs <- readIORef ref
87 writeIORef ref $! (a,b):xs
88 xs <- readIORef ref
89 reverse xs @?= [(a,b) | a <- [1..100], b <- [1..50]]
91 -- Make sure fold propagates our exception.
92 ref <- newIORef []
93 True <- expectError (== TestException) $
94 forEach_ conn "SELECT generate_series(1,10)" $ \(Only a) ->
95 if a == 5 then do
96 -- Cause a SQL error to trip up CLOSE.
97 True <- expectError isSyntaxError $
98 execute_ conn "asdf"
99 True <- expectError ST.isFailedTransactionError $
100 (query_ conn "SELECT 1" :: IO [(Only Int)])
101 throwIO TestException
102 else do
103 xs <- readIORef ref
104 writeIORef ref $! (a :: Int) : xs
105 xs <- readIORef ref
106 reverse xs @?= [1..4]
108 withTransaction conn $ replicateM_ 2 $ do
109 xs <- fold_ conn "VALUES (1), (2), (3), (4), (5)"
110 [] $ \xs (Only x) -> return (x:xs)
111 reverse xs @?= ([1..5] :: [Int])
113 ref <- newIORef []
114 forEach_ conn "SELECT generate_series(1,101)" $ \(Only a) ->
115 forEach_ conn "SELECT generate_series(1,55)" $ \(Only b) -> do
116 xs <- readIORef ref
117 writeIORef ref $! (a :: Int, b :: Int) : xs
118 xs <- readIORef ref
119 reverse xs @?= [(a,b) | a <- [1..101], b <- [1..55]]
121 xs <- fold_ conn "SELECT 1 WHERE FALSE"
122 [] $ \xs (Only x) -> return (x:xs)
123 xs @?= ([] :: [Int])
125 -- TODO: add more complete tests, e.g.:
126 --
127 -- * Fold in a transaction
128 --
129 -- * Fold in a transaction after a previous fold has been performed
130 --
131 -- * Nested fold
133 return ()
135queryFailure :: forall a. (FromField a, Typeable a, Show a)
136 => Connection -> Query -> a -> Assertion
137queryFailure conn q resultType = do
138 x :: Either SomeException [Only a] <- E.try $ query_ conn q
139 case x of
140 Left _ -> return ()
141 Right val -> assertFailure ("Did not fail as expected: "
142 ++ show q
143 ++ " :: "
144 ++ show (typeOf resultType)
145 ++ " -> " ++ show val)
147testArray :: TestEnv -> Test
148testArray TestEnv{..} = TestCase $ do
149 xs <- query_ conn "SELECT '{1,2,3,4}'::_int4"
150 xs @?= [Only (V.fromList [1,2,3,4 :: Int])]
151 xs <- query_ conn "SELECT '{{1,2},{3,4}}'::_int4"
152 xs @?= [Only (V.fromList [V.fromList [1,2],
153 V.fromList [3,4 :: Int]])]
154 queryFailure conn "SELECT '{1,2,3,4}'::_int4" (undefined :: V.Vector Bool)
155 queryFailure conn "SELECT '{{1,2},{3,4}}'::_int4" (undefined :: V.Vector Int)
157testHStore :: TestEnv -> Test
158testHStore TestEnv{..} = TestCase $ do
159 roundTrip []
160 roundTrip [("foo","bar"),("bar","baz"),("baz","hello")]
161 roundTrip [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")]
162 where
163 roundTrip :: [(Text,Text)] -> Assertion
164 roundTrip xs = do
165 let m = Only (HStoreMap (Map.fromList xs))
166 m' <- query conn "SELECT ?::hstore" m
167 [m] @?= m'
169testSavepoint :: TestEnv -> Test
170testSavepoint TestEnv{..} = TestCase $ do
171 True <- expectError ST.isNoActiveTransactionError $
172 withSavepoint conn $ return ()
174 let getRows :: IO [Int]
175 getRows = map fromOnly <$> query_ conn "SELECT a FROM tmp_savepoint ORDER BY a"
176 withTransaction conn $ do
177 execute_ conn "CREATE TEMPORARY TABLE tmp_savepoint (a INT UNIQUE)"
178 execute_ conn "INSERT INTO tmp_savepoint VALUES (1)"
179 [1] <- getRows
181 withSavepoint conn $ do
182 execute_ conn "INSERT INTO tmp_savepoint VALUES (2)"
183 [1,2] <- getRows
184 return ()
185 [1,2] <- getRows
187 withSavepoint conn $ do
188 execute_ conn "INSERT INTO tmp_savepoint VALUES (3)"
189 [1,2,3] <- getRows
190 True <- expectError isUniqueViolation $
191 execute_ conn "INSERT INTO tmp_savepoint VALUES (2)"
192 True <- expectError ST.isFailedTransactionError getRows
194 -- Body returning successfully after handling error,
195 -- but 'withSavepoint' will roll back without complaining.
196 return ()
197 -- Rolling back clears the error condition.
198 [1,2] <- getRows
200 -- 'withSavepoint' will roll back after an exception, even if the
201 -- exception wasn't SQL-related.
202 True <- expectError (== TestException) $
203 withSavepoint conn $ do
204 execute_ conn "INSERT INTO tmp_savepoint VALUES (3)"
205 [1,2,3] <- getRows
206 throwIO TestException
207 [1,2] <- getRows
209 -- Nested savepoint can be rolled back while the
210 -- outer effects are retained.
211 withSavepoint conn $ do
212 execute_ conn "INSERT INTO tmp_savepoint VALUES (3)"
213 True <- expectError isUniqueViolation $
214 withSavepoint conn $ do
215 execute_ conn "INSERT INTO tmp_savepoint VALUES (4)"
216 [1,2,3,4] <- getRows
217 execute_ conn "INSERT INTO tmp_savepoint VALUES (4)"
218 [1,2,3] <- getRows
219 return ()
220 [1,2,3] <- getRows
222 return ()
224 -- Transaction committed successfully, even though there were errors
225 -- (but we rolled them back).
226 [1,2,3] <- getRows
228 return ()
230data TestException
231 = TestException
232 deriving (Eq, Show, Typeable)
234instance Exception TestException
236expectError :: Exception e => (e -> Bool) -> IO a -> IO Bool
237expectError p io =
238 (io >> return False) `E.catch` \ex ->
239 if p ex then return True else throwIO ex
241isUniqueViolation :: SqlError -> Bool
242isUniqueViolation SqlError{..} = sqlState == "23505"
244isSyntaxError :: SqlError -> Bool
245isSyntaxError SqlError{..} = sqlState == "42601"
247------------------------------------------------------------------------
249-- | Action for connecting to the database that will be used for testing.
250--
251-- Note that some tests, such as Notify, use multiple connections, and assume
252-- that 'testConnect' connects to the same database every time it is called.
253testConnect :: IO Connection
254testConnect = connectPostgreSQL ""
256withTestEnv :: (TestEnv -> IO a) -> IO a
257withTestEnv cb =
258 withConn $ \conn ->
259 cb TestEnv
260 { conn = conn
261 , withConn = withConn
262 }
263 where
264 withConn = bracket testConnect close
266main :: IO ()
267main = do
268 mapM_ (`hSetBuffering` LineBuffering) [stdout, stderr]
269 Counts{cases, tried, errors, failures} <-
270 withTestEnv $ \env -> runTestTT $ TestList $ map ($ env) tests
271 when (cases /= tried || errors /= 0 || failures /= 0) $ exitFailure