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