ce97656 · typeable/postgresql-simple

20import qualified Data.Map as Map

21import Data.Text(Text)

22import qualified Data.Text.Encoding as T

23−import System.Exit (exitFailure)

24−import System.IO

25import qualified Data.Vector as V

23import qualified Data.Vector as V

26import Data.Aeson

24import Data.Aeson

27import GHC.Generics (Generic)

25import GHC.Generics (Generic)

28

26

27+import Test.Tasty

29import Notify

28import Notify

30import Serializable

29import Serializable

31import Time

30import Time

32

31

33−tests :: [TestEnv -> Test]

32+tests :: TestEnv -> TestTree

34−tests =

33+tests env = testGroup "tests"

34+ $ map ($ env)

35− [ TestLabel "Bytea" . testBytea

35+ [ testBytea

36− , TestLabel "ExecuteMany" . testExecuteMany

36+ , testCase "ExecuteMany" . testExecuteMany

37− , TestLabel "Fold" . testFold

37+ , testCase "Fold" . testFold

38− , TestLabel "Notify" . testNotify

38+ , testCase "Notify" . testNotify

39− , TestLabel "Serializable" . testSerializable

39+ , testCase "Serializable" . testSerializable

40− , TestLabel "Time" . testTime

40+ , testCase "Time" . testTime

41− , TestLabel "Array" . testArray

41+ , testCase "Array" . testArray

42− , TestLabel "HStore" . testHStore

42+ , testCase "HStore" . testHStore

43− , TestLabel "JSON" . testJSON

43+ , testCase "JSON" . testJSON

44− , TestLabel "Savepoint" . testSavepoint

44+ , testCase "Savepoint" . testSavepoint

45− , TestLabel "Unicode" . testUnicode

45+ , testCase "Unicode" . testUnicode

46− , TestLabel "Values" . testValues

46+ , testCase "Values" . testValues

47− , TestLabel "Copy" . testCopy

47+ , testCase "Copy" . testCopy

48− , TestLabel "Double" . testDouble

48+ , testCase "Double" . testDouble

49− , TestLabel "1-ary generic" . testGeneric1

49+ , testCase "1-ary generic" . testGeneric1

50− , TestLabel "2-ary generic" . testGeneric2

50+ , testCase "2-ary generic" . testGeneric2

51− , TestLabel "3-ary generic" . testGeneric3

51+ , testCase "3-ary generic" . testGeneric3

52 ]

53

54−testBytea :: TestEnv -> Test

54+testBytea :: TestEnv -> TestTree

55−testBytea TestEnv{..} = TestList

55+testBytea TestEnv{..} = testGroup "Bytea"

56 [ testStr "empty" []

57 , testStr "\"hello\"" $ map (fromIntegral . fromEnum) ("hello" :: String)

58 , testStr "ascending" [0..255]

61 , testStr "descending, doubled up" $ doubleUp [255,254..0]

62 ]

63 where

64− testStr label bytes = TestLabel label $ TestCase $ do

64+ testStr label bytes = testCase label $ do

65 let bs = B.pack bytes

66

67 [Only h] <- query conn "SELECT md5(?::bytea)" [Binary bs]

72

73 doubleUp = concatMap (\x -> [x, x])

74

75−testExecuteMany :: TestEnv -> Test

75+testExecuteMany :: TestEnv -> Assertion

76−testExecuteMany TestEnv{..} = TestCase $ do

76+testExecuteMany TestEnv{..} = do

77 execute_ conn "CREATE TEMPORARY TABLE tmp_executeMany (i INT, t TEXT, b BYTEA)"

78

79 let rows :: [(Int, String, Binary ByteString)]

90

91 return ()

92

93−testFold :: TestEnv -> Test

93+testFold :: TestEnv -> Assertion

94−testFold TestEnv{..} = TestCase $ do

94+testFold TestEnv{..} = do

95 xs <- fold_ conn "SELECT generate_series(1,10000)"

96 [] $ \xs (Only x) -> return (x:xs)

97 reverse xs @?= ([1..10000] :: [Int])

160 ++ show (typeOf resultType)

161 ++ " -> " ++ show val)

162

163−testArray :: TestEnv -> Test

163+testArray :: TestEnv -> Assertion

164−testArray TestEnv{..} = TestCase $ do

164+testArray TestEnv{..} = do

165 xs <- query_ conn "SELECT '{1,2,3,4}'::_int4"

166 xs @?= [Only (V.fromList [1,2,3,4 :: Int])]

167 xs <- query_ conn "SELECT '{{1,2},{3,4}}'::_int4"

170 queryFailure conn "SELECT '{1,2,3,4}'::_int4" (undefined :: V.Vector Bool)

171 queryFailure conn "SELECT '{{1,2},{3,4}}'::_int4" (undefined :: V.Vector Int)

172

173−testHStore :: TestEnv -> Test

173+testHStore :: TestEnv -> Assertion

174−testHStore TestEnv{..} = TestCase $ do

174+testHStore TestEnv{..} = do

175 execute_ conn "CREATE EXTENSION IF NOT EXISTS hstore"

176 roundTrip []

177 roundTrip [("foo","bar"),("bar","baz"),("baz","hello")]

183 m' <- query conn "SELECT ?::hstore" m

184 [m] @?= m'

185

186−testJSON :: TestEnv -> Test

186+testJSON :: TestEnv -> Assertion

187−testJSON TestEnv{..} = TestCase $ do

187+testJSON TestEnv{..} = do

188 roundTrip (Map.fromList [] :: Map Text Text)

189 roundTrip (Map.fromList [("foo","bar"),("bar","baz"),("baz","hello")] :: Map Text Text)

190 roundTrip (Map.fromList [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")] :: Map Text Text)

198 js' <- query conn "SELECT ?::json" js

199 [js] @?= js'

200

201−testSavepoint :: TestEnv -> Test

201+testSavepoint :: TestEnv -> Assertion

202−testSavepoint TestEnv{..} = TestCase $ do

202+testSavepoint TestEnv{..} = do

203 True <- expectError ST.isNoActiveTransactionError $

204 withSavepoint conn $ return ()

205

259

260 return ()

261

262−testUnicode :: TestEnv -> Test

262+testUnicode :: TestEnv -> Assertion

263−testUnicode TestEnv{..} = TestCase $ do

263+testUnicode TestEnv{..} = do

264 let q = Query . T.encodeUtf8 -- Handle encoding ourselves to ensure

265 -- the table gets created correctly.

266 let messages = map Only ["привет","мир"] :: [Only Text]

269 messages' <- query_ conn "SELECT сообщение FROM ру́сский"

270 sort messages @?= sort messages'

271

272−testValues :: TestEnv -> Test

272+testValues :: TestEnv -> Assertion

273−testValues TestEnv{..} = TestCase $ do

273+testValues TestEnv{..} = do

274 execute_ conn "CREATE TEMPORARY TABLE values_test (x int, y text)"

275 test (Values ["int4","text"] [])

276 test (Values ["int4","text"] [(1,"hello")])

287 sort vals @?= sort vals'

288

289

290−testCopy :: TestEnv -> Test

290+testCopy :: TestEnv -> Assertion

291−testCopy TestEnv{..} = TestCase $ do

291+testCopy TestEnv{..} = do

292 execute_ conn "CREATE TEMPORARY TABLE copy_test (x int, y text)"

293 copy_ conn "COPY copy_test FROM STDIN (FORMAT CSV)"

294 mapM_ (putCopyData conn) copyRows

315 CopyOutDone _ -> return rows

316 CopyOutRow row -> loop (row:rows)

317

318−testDouble :: TestEnv -> Test

318+testDouble :: TestEnv -> Assertion

319−testDouble TestEnv{..} = TestCase $ do

319+testDouble TestEnv{..} = do

320 [Only (x :: Double)] <- query_ conn "SELECT 'NaN'::float8"

321 assertBool "expected NaN" (isNaN x)

322 [Only (x :: Double)] <- query_ conn "SELECT 'Infinity'::float8"

325 x @?= (-1 / 0)

326

327

328−testGeneric1 :: TestEnv -> Test

328+testGeneric1 :: TestEnv -> Assertion

329−testGeneric1 TestEnv{..} = TestCase $ do

329+testGeneric1 TestEnv{..} = do

330 roundTrip conn (Gen1 123)

331 where

332 roundTrip conn x0 = do

333 r <- query conn "SELECT ?::int" (x0 :: Gen1)

334 r @?= [x0]

335

336−testGeneric2 :: TestEnv -> Test

336+testGeneric2 :: TestEnv -> Assertion

337−testGeneric2 TestEnv{..} = TestCase $ do

337+testGeneric2 TestEnv{..} = do

338 roundTrip conn (Gen2 123 "asdf")

339 where

340 roundTrip conn x0 = do

341 r <- query conn "SELECT ?::int, ?::text" x0

342 r @?= [x0]

343

344−testGeneric3 :: TestEnv -> Test

344+testGeneric3 :: TestEnv -> Assertion

345−testGeneric3 TestEnv{..} = TestCase $ do

345+testGeneric3 TestEnv{..} = do

346 roundTrip conn (Gen3 123 "asdf" True)

347 where

348 roundTrip conn x0 = do

401 withConn = bracket testConnect close

402

403main :: IO ()

404−main = do

405− mapM_ (`hSetBuffering` LineBuffering) [stdout, stderr]

406− Counts{cases, tried, errors, failures} <-

407− withTestEnv $ \env -> runTestTT $ TestList $ map ($ env) tests

404+main = withTestEnv $ defaultMain . tests

408− when (cases /= tried || errors /= 0 || failures /= 0) $ exitFailure