@@ -1,12 +1,11 @@
1+{-# language BangPatterns #-}
12{-# language BlockArguments #-}
2−{-# language DataKinds #-}
33{-# language DeriveAnyClass #-}
44{-# language DeriveGeneric #-}
55{-# language DerivingStrategies #-}
6−{-# language DisambiguateRecordFields #-}
76{-# language FlexibleContexts #-}
87{-# language FlexibleInstances #-}
9−{-# language GADTs #-}
8+{-# language MonoLocalBinds #-}
109{-# language NamedFieldPuns #-}
1110{-# language OverloadedStrings #-}
1211{-# language RecordWildCards #-}
@@ -14,17 +13,15 @@
1413{-# language StandaloneDeriving #-}
1514{-# language TypeApplications #-}
1615
17−{-# options_ghc -fno-warn-redundant-constraints #-}
18−
1916module Main
2017 ( main
2118 )
2219where
2320
2421-- base
25−import Control.Applicative ( liftA2, liftA3 )
26−import Control.Monad (void)
27−import Control.Monad.IO.Class ( MonadIO, liftIO )
22+import Control.Applicative ( empty, liftA2, liftA3 )
23+import Control.Exception ( bracket, throwIO )
24+import Control.Monad ( (>=>), void )
2825import Data.Bifunctor ( bimap )
2926import Data.Foldable ( for_ )
3027import Data.Int ( Int32, Int64 )
@@ -38,25 +35,27 @@ import GHC.Generics ( Generic )
3835import qualified Data.ByteString.Lazy
3936
4037-- case-insensitive
41−import Data.CaseInsensitive (mk)
38+import Data.CaseInsensitive ( mk )
4239
4340-- containers
41+import Data.Containers.ListUtils ( nubOrdOn )
4442import qualified Data.Map.Strict as Map
4543
4644-- hasql
47−import Hasql.Connection ( Connection, acquire, release )
45+import Hasql.Connection ( Connection, acquire, release )
4846import Hasql.Session ( sql, run )
4947
48+-- hasql-transaction
49+import Hasql.Transaction ( Transaction, condemn, statement )
50+import qualified Hasql.Transaction.Sessions as Hasql
51+
5052-- hedgehog
5153import Hedgehog ( property, (===), forAll, cover, diff, evalM, PropertyT, TestT, test, Gen )
5254import qualified Hedgehog.Gen as Gen
5355import qualified Hedgehog.Range as Range
5456
55−-- lifted-base
56−import Control.Exception.Lifted ( bracket, throwIO, bracket_ )
57−
58−-- monad-control
59−import Control.Monad.Trans.Control ( MonadBaseControl )
57+-- mmorph
58+import Control.Monad.Morph ( hoist )
6059
6160-- rel8
6261import Rel8 ( Result )
@@ -72,12 +71,16 @@ import Test.Tasty
7271import Test.Tasty.Hedgehog ( testProperty )
7372
7473-- text
75−import Data.Text (Text, pack)
74+import Data.Text ( Text, pack, unpack )
7675import qualified Data.Text.Lazy
76+import Data.Text.Encoding ( decodeUtf8 )
7777
7878-- time
7979import Data.Time
8080
81+-- transformers
82+import Control.Monad.Trans.Class ( lift )
83+
8184-- tmp-postgres
8285import qualified Database.Postgres.Temp as TmpPostgres
8386
@@ -113,11 +116,13 @@ tests =
113116 , testCatMaybeTable getTestDatabase
114117 , testCatMaybe getTestDatabase
115118 , testMaybeTable getTestDatabase
119+ , testAggregateMaybeTable getTestDatabase
116120 , testNestedTables getTestDatabase
117121 , testMaybeTableApplicative getTestDatabase
118122 , testLogicalFixities getTestDatabase
119123 , testUpdate getTestDatabase
120124 , testDelete getTestDatabase
125+ , testUpsert getTestDatabase
121126 , testSelectNestedPairs getTestDatabase
122127 , testSelectArray getTestDatabase
123128 , testNestedMaybeTable getTestDatabase
@@ -133,6 +138,7 @@ tests =
133138 flip run conn do
134139 sql "CREATE EXTENSION citext"
135140 sql "CREATE TABLE test_table ( column1 text not null, column2 bool not null )"
141+ sql "CREATE TABLE unique_table ( \"key\" text not null unique, \"value\" text not null )"
136142 sql "CREATE SEQUENCE test_seq"
137143
138144 return db
@@ -140,19 +146,21 @@ tests =
140146 stopTestDatabase = TmpPostgres.stop
141147
142148
149+connect :: TmpPostgres.DB -> IO Connection
150+connect = acquire . TmpPostgres.toConnectionString >=> either (maybe empty (fail . unpack . decodeUtf8)) pure
151+
152+
143153databasePropertyTest
144154 :: TestName
145− -> (((Connection -> TestT IO ()) -> PropertyT IO ()) -> PropertyT IO ())
155+ -> ((TestT Transaction () -> PropertyT IO ()) -> PropertyT IO ())
146156 -> IO TmpPostgres.DB -> TestTree
147157databasePropertyTest testName f getTestDatabase =
148− withResource connect release $ \c ->
158+ withResource (connect =<< getTestDatabase) release $ \c ->
149159 testProperty testName $ property do
150− connection <- liftIO c
151− f \g -> test $ rollingBack connection $ g connection
152−
153− where
154−
155− connect = either (error . show) return =<< acquire . TmpPostgres.toConnectionString =<< getTestDatabase
160+ connection <- lift c
161+ f $ test . hoist \m -> do
162+ e <- run (Hasql.transaction Hasql.Serializable Hasql.Write (m <* condemn)) connection
163+ either throwIO pure e
156164
157165
158166data TestTable f = TestTable
@@ -184,18 +192,17 @@ testSelectTestTable :: IO TmpPostgres.DB -> TestTree
184192testSelectTestTable = databasePropertyTest "Can SELECT TestTable" \transaction -> do
185193 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
186194
187− transaction \connection -> do
188− void do
189− liftIO $ Rel8.insert connection
190− Rel8.Insert
191− { into = testTableSchema
192− , rows = map Rel8.lit rows
193− , onConflict = Rel8.DoNothing
194− , returning = Rel8.NumberOfRowsAffected
195− }
195+ transaction do
196+ selected <- lift do
197+ statement () $ Rel8.insert Rel8.Insert
198+ { into = testTableSchema
199+ , rows = Rel8.values $ map Rel8.lit rows
200+ , onConflict = Rel8.DoNothing
201+ , returning = pure ()
202+ }
196203
197− selected <- liftIO $ Rel8.select connection do
198− Rel8.each testTableSchema
204+ statement () $ Rel8.select do
205+ Rel8.each testTableSchema
199206
200207 sort selected === sort rows
201208
@@ -212,11 +219,12 @@ testWhere_ = databasePropertyTest "WHERE (Rel8.where_)" \transaction -> do
212219
213220 let expected = filter (\t -> testTableColumn2 t == magicBool) rows
214221
215− transaction \connection -> do
216− selected <- liftIO $ Rel8.select connection do
217− t <- Rel8.values $ Rel8.lit <$> rows
218− Rel8.where_ $ testTableColumn2 t Rel8.==. Rel8.lit magicBool
219− return t
222+ transaction do
223+ selected <- lift do
224+ statement () $ Rel8.select do
225+ t <- Rel8.values $ Rel8.lit <$> rows
226+ Rel8.where_ $ testTableColumn2 t Rel8.==. Rel8.lit magicBool
227+ return t
220228
221229 sort selected === sort expected
222230
@@ -229,11 +237,12 @@ testFilter :: IO TmpPostgres.DB -> TestTree
229237testFilter = databasePropertyTest "filter" \transaction -> do
230238 rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable
231239
232− transaction \connection -> do
240+ transaction do
233241 let expected = filter testTableColumn2 rows
234242
235− selected <- liftIO $ Rel8.select connection
236− $ Rel8.filter testTableColumn2 =<< Rel8.values (Rel8.lit <$> rows)
243+ selected <- lift do
244+ statement () $ Rel8.select do
245+ Rel8.filter testTableColumn2 =<< Rel8.values (Rel8.lit <$> rows)
237246
238247 sort selected === sort expected
239248
@@ -248,9 +257,10 @@ testLimit = databasePropertyTest "LIMIT (Rel8.limit)" \transaction -> do
248257
249258 n <- forAll $ Gen.integral (Range.linear 0 10)
250259
251− transaction \connection -> do
252− selected <- liftIO $ Rel8.select connection do
253− Rel8.limit n $ Rel8.values (Rel8.lit <$> rows)
260+ transaction do
261+ selected <- lift do
262+ statement () $ Rel8.select do
263+ Rel8.limit n $ Rel8.values (Rel8.lit <$> rows)
254264
255265 diff (length selected) (<=) (fromIntegral n)
256266
@@ -268,9 +278,10 @@ testUnion = databasePropertyTest "UNION (Rel8.union)" \transaction -> evalM do
268278 left <- forAll $ Gen.list (Range.linear 0 10) genTestTable
269279 right <- forAll $ Gen.list (Range.linear 0 10) genTestTable
270280
271− transaction \connection -> do
272− selected <- liftIO $ Rel8.select connection do
273− Rel8.values (Rel8.lit <$> nub left) `Rel8.union` Rel8.values (Rel8.lit <$> nub right)
281+ transaction do
282+ selected <- lift do
283+ statement () $ Rel8.select do
284+ Rel8.values (Rel8.lit <$> nub left) `Rel8.union` Rel8.values (Rel8.lit <$> nub right)
274285
275286 sort selected === sort (nub (left ++ right))
276287
@@ -279,9 +290,11 @@ testDistinct :: IO TmpPostgres.DB -> TestTree
279290testDistinct = databasePropertyTest "DISTINCT (Rel8.distinct)" \transaction -> do
280291 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
281292
282− transaction \connection -> do
283− selected <- liftIO $ Rel8.select connection $ Rel8.distinct do
284− Rel8.values (Rel8.lit <$> rows)
293+ transaction do
294+ selected <- lift do
295+ statement () $ Rel8.select do
296+ Rel8.distinct do
297+ Rel8.values (Rel8.lit <$> rows)
285298
286299 sort selected === nub (sort rows)
287300
@@ -294,8 +307,10 @@ testExists :: IO TmpPostgres.DB -> TestTree
294307testExists = databasePropertyTest "EXISTS (Rel8.exists)" \transaction -> do
295308 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
296309
297− transaction \connection -> do
298− exists <- liftIO $ Rel8.select connection $ Rel8.exists $ Rel8.values $ Rel8.lit <$> rows
310+ transaction do
311+ exists <- lift do
312+ statement () $ Rel8.select do
313+ Rel8.exists $ Rel8.values $ Rel8.lit <$> rows
299314
300315 case rows of
301316 [] -> exists === [False]
@@ -306,9 +321,10 @@ testOptional :: IO TmpPostgres.DB -> TestTree
306321testOptional = databasePropertyTest "Rel8.optional" \transaction -> do
307322 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
308323
309− transaction \connection -> do
310− selected <- liftIO $ Rel8.select connection do
311− Rel8.optional $ Rel8.values (Rel8.lit <$> rows)
324+ transaction do
325+ selected <- lift do
326+ statement () $ Rel8.select do
327+ Rel8.optional $ Rel8.values (Rel8.lit <$> rows)
312328
313329 case rows of
314330 [] -> selected === [Nothing]
@@ -319,9 +335,10 @@ testAnd :: IO TmpPostgres.DB -> TestTree
319335testAnd = databasePropertyTest "AND (&&.)" \transaction -> do
320336 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool
321337
322− transaction \connection -> do
323− [result] <- liftIO $ Rel8.select connection $ pure $
324− Rel8.lit x Rel8.&&. Rel8.lit y
338+ transaction do
339+ [result] <- lift do
340+ statement () $ Rel8.select do
341+ pure $ Rel8.lit x Rel8.&&. Rel8.lit y
325342
326343 result === (x && y)
327344
@@ -330,9 +347,10 @@ testOr :: IO TmpPostgres.DB -> TestTree
330347testOr = databasePropertyTest "OR (||.)" \transaction -> do
331348 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool
332349
333− transaction \connection -> do
334− [result] <- liftIO $ Rel8.select connection $ pure $
335− Rel8.lit x Rel8.||. Rel8.lit y
350+ transaction do
351+ [result] <- lift do
352+ statement () $ Rel8.select $ pure $
353+ Rel8.lit x Rel8.||. Rel8.lit y
336354
337355 result === (x || y)
338356
@@ -341,9 +359,10 @@ testLogicalFixities :: IO TmpPostgres.DB -> TestTree
341359testLogicalFixities = databasePropertyTest "Logical operator fixities" \transaction -> do
342360 (u, v, w, x) <- forAll $ (,,,) <$> Gen.bool <*> Gen.bool <*> Gen.bool <*> Gen.bool
343361
344− transaction \connection -> do
345− [result] <- liftIO $ Rel8.select connection $ pure $
346− Rel8.lit u Rel8.||. Rel8.lit v Rel8.&&. Rel8.lit w Rel8.==. Rel8.lit x
362+ transaction do
363+ [result] <- lift do
364+ statement () $ Rel8.select do
365+ pure $ Rel8.lit u Rel8.||. Rel8.lit v Rel8.&&. Rel8.lit w Rel8.==. Rel8.lit x
347366
348367 result === (u || v && w == x)
349368
@@ -352,9 +371,10 @@ testNot :: IO TmpPostgres.DB -> TestTree
352371testNot = databasePropertyTest "NOT (not_)" \transaction -> do
353372 x <- forAll Gen.bool
354373
355− transaction \connection -> do
356− [result] <- liftIO $ Rel8.select connection $ pure $
357− Rel8.not_ $ Rel8.lit x
374+ transaction do
375+ [result] <- lift do
376+ statement () $ Rel8.select do
377+ pure $ Rel8.not_ $ Rel8.lit x
358378
359379 result === not x
360380
@@ -363,9 +383,10 @@ testBool :: IO TmpPostgres.DB -> TestTree
363383testBool = databasePropertyTest "ifThenElse_" \transaction -> do
364384 (x, y, z) <- forAll $ liftA3 (,,) Gen.bool Gen.bool Gen.bool
365385
366− transaction \connection -> do
367− [result] <- liftIO $ Rel8.select connection $ pure $
368− Rel8.bool (Rel8.lit z) (Rel8.lit y) (Rel8.lit x)
386+ transaction do
387+ [result] <- lift do
388+ statement () $ Rel8.select do
389+ pure $ Rel8.bool (Rel8.lit z) (Rel8.lit y) (Rel8.lit x)
369390
370391 result === if x then y else z
371392
@@ -377,9 +398,10 @@ testAp = databasePropertyTest "Cartesian product (<*>)" \transaction -> do
377398 (Gen.list (Range.linear 1 10) genTestTable)
378399 (Gen.list (Range.linear 1 10) genTestTable)
379400
380− transaction \connection -> do
381− result <- liftIO $ Rel8.select connection $ do
382− liftA2 (,) (Rel8.values (Rel8.lit <$> rows1)) (Rel8.values (Rel8.lit <$> rows2))
401+ transaction do
402+ result <- lift do
403+ statement () $ Rel8.select do
404+ liftA2 (,) (Rel8.values (Rel8.lit <$> rows1)) (Rel8.values (Rel8.lit <$> rows2))
383405
384406 sort result === sort (liftA2 (,) rows1 rows2)
385407
@@ -408,21 +430,22 @@ testDBType getTestDatabase = testGroup "DBType instances"
408430 where
409431 dbTypeTest :: (Eq a, Show a, Rel8.DBType a) => TestName -> Gen a -> TestTree
410432 dbTypeTest name generator = testGroup name
411− [ databasePropertyTest name (t (==) generator) getTestDatabase
412− , databasePropertyTest ("Maybe " <> name) (t (==) (Gen.maybe generator)) getTestDatabase
433+ [ databasePropertyTest name (t generator) getTestDatabase
434+ , databasePropertyTest ("Maybe " <> name) (t (Gen.maybe generator)) getTestDatabase
413435 ]
414436
415− t :: forall a b. (Show a, Rel8.Sql Rel8.DBType a)
416− => (a -> a -> Bool)
417− -> Gen a
418− -> ((Connection -> TestT IO ()) -> PropertyT IO b)
437+ t :: forall a b. (Eq a, Show a, Rel8.Sql Rel8.DBType a)
438+ => Gen a
439+ -> (TestT Transaction () -> PropertyT IO b)
419440 -> PropertyT IO b
420− t eq generator transaction = do
441+ t generator transaction = do
421442 x <- forAll generator
422443
423− transaction \connection -> do
424− [res] <- liftIO $ Rel8.select connection $ pure (Rel8.litExpr x)
425− diff res eq x
444+ transaction do
445+ [res] <- lift do
446+ statement () $ Rel8.select do
447+ pure (Rel8.litExpr x)
448+ diff res (==) x
426449
427450 genDay :: Gen Day
428451 genDay = do
@@ -464,13 +487,15 @@ testDBEq getTestDatabase = testGroup "DBEq instances"
464487
465488 t :: forall a. (Eq a, Show a, Rel8.Sql Rel8.DBEq a)
466489 => Gen a
467− -> ((Connection -> TestT IO ()) -> PropertyT IO ())
490+ -> (TestT Transaction () -> PropertyT IO ())
468491 -> PropertyT IO ()
469492 t generator transaction = do
470493 (x, y) <- forAll (liftA2 (,) generator generator)
471494
472− transaction \connection -> do
473− [res] <- liftIO $ Rel8.select connection $ pure $ Rel8.litExpr x Rel8.==. Rel8.litExpr y
495+ transaction do
496+ [res] <- lift do
497+ statement () $ Rel8.select do
498+ pure $ Rel8.litExpr x Rel8.==. Rel8.litExpr y
474499 res === (x == y)
475500
476501
@@ -478,9 +503,10 @@ testTableEquality :: IO TmpPostgres.DB -> TestTree
478503testTableEquality = databasePropertyTest "TestTable equality" \transaction -> do
479504 (x, y) <- forAll $ liftA2 (,) genTestTable genTestTable
480505
481− transaction \connection -> do
482− [eq] <- liftIO $ Rel8.select connection do
483− pure $ Rel8.lit x Rel8.==: Rel8.lit y
506+ transaction do
507+ [eq] <- lift do
508+ statement () $ Rel8.select do
509+ pure $ Rel8.lit x Rel8.==: Rel8.lit y
484510
485511 eq === (x == y)
486512
@@ -489,8 +515,10 @@ testFromString :: IO TmpPostgres.DB -> TestTree
489515testFromString = databasePropertyTest "FromString" \transaction -> do
490516 str <- forAll $ Gen.list (Range.linear 0 10) Gen.unicode
491517
492− transaction \connection -> do
493− [result] <- liftIO $ Rel8.select connection $ pure $ fromString str
518+ transaction do
519+ [result] <- lift do
520+ statement () $ Rel8.select do
521+ pure $ fromString str
494522 result === pack str
495523
496524
@@ -498,10 +526,11 @@ testCatMaybeTable :: IO TmpPostgres.DB -> TestTree
498526testCatMaybeTable = databasePropertyTest "catMaybeTable" \transaction -> do
499527 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
500528
501− transaction \connection -> do
502− selected <- liftIO $ Rel8.select connection do
503− testTable <- Rel8.values $ Rel8.lit <$> rows
504− Rel8.catMaybeTable $ Rel8.bool Rel8.nothingTable (pure testTable) (testTableColumn2 testTable)
529+ transaction do
530+ selected <- lift do
531+ statement () $ Rel8.select do
532+ testTable <- Rel8.values $ Rel8.lit <$> rows
533+ Rel8.catMaybeTable $ Rel8.bool Rel8.nothingTable (pure testTable) (testTableColumn2 testTable)
505534
506535 sort selected === sort (filter testTableColumn2 rows)
507536
@@ -510,9 +539,10 @@ testCatMaybe :: IO TmpPostgres.DB -> TestTree
510539testCatMaybe = databasePropertyTest "catMaybe" \transaction -> evalM do
511540 rows <- forAll $ Gen.list (Range.linear 0 10) $ Gen.maybe Gen.bool
512541
513− transaction \connection -> do
514− selected <- evalM $ liftIO $ Rel8.select connection do
515− Rel8.catNull =<< Rel8.values (map Rel8.lit rows)
542+ transaction do
543+ selected <- lift do
544+ statement () $ Rel8.select do
545+ Rel8.catNull =<< Rel8.values (map Rel8.lit rows)
516546
517547 sort selected === sort (catMaybes rows)
518548
@@ -521,15 +551,38 @@ testMaybeTable :: IO TmpPostgres.DB -> TestTree
521551testMaybeTable = databasePropertyTest "maybeTable" \transaction -> evalM do
522552 (rows, def) <- forAll $ liftA2 (,) (Gen.list (Range.linear 0 10) genTestTable) genTestTable
523553
524− transaction \connection -> do
525− selected <- liftIO $ Rel8.select connection $
526− Rel8.maybeTable (Rel8.lit def) id <$> Rel8.optional (Rel8.values (Rel8.lit <$> rows))
554+ transaction do
555+ selected <- lift do
556+ statement () $ Rel8.select do
557+ Rel8.maybeTable (Rel8.lit def) id <$> Rel8.optional (Rel8.values (Rel8.lit <$> rows))
527558
528559 case rows of
529560 [] -> selected === [def]
530561 _ -> sort selected === sort rows
531562
532563
564+testAggregateMaybeTable :: IO TmpPostgres.DB -> TestTree
565+testAggregateMaybeTable = databasePropertyTest "aggregateMaybeTable" \transaction -> evalM do
566+ rows <- forAll $ Gen.list (Range.linear 0 10) (Gen.maybe (Gen.int64 (Range.linear 0 10)))
567+
568+ let
569+ aggregate = go 0 False False
570+ where
571+ go !n nothing _ (Just a : as) = go (n + a) nothing True as
572+ go n _ just (Nothing : as) = go n True just as
573+ go _ False False [] = []
574+ go _ True False [] = [Nothing]
575+ go n False True [] = [Just n]
576+ go n True True [] = [Nothing, Just n]
577+
578+ transaction do
579+ selected <- lift do
580+ statement () $ Rel8.select do
581+ Rel8.aggregate $ Rel8.aggregateMaybeTable Rel8.sum <$> Rel8.values (Rel8.lit <$> rows)
582+
583+ sort selected === aggregate rows
584+
585+
533586data TwoTestTables f =
534587 TwoTestTables
535588 { testTable1 :: TestTable f
@@ -550,9 +603,10 @@ testNestedTables = databasePropertyTest "Nested TestTables" \transaction -> eval
550603 Gen.list (Range.linear 0 10) $
551604 liftA2 TwoTestTables genTestTable genTestTable
552605
553− transaction \connection -> do
554− selected <- liftIO $ Rel8.select connection do
555− Rel8.values (Rel8.lit <$> rows)
606+ transaction do
607+ selected <- lift do
608+ statement () $ Rel8.select do
609+ Rel8.values (Rel8.lit <$> rows)
556610
557611 sort selected === sort rows
558612
@@ -562,11 +616,12 @@ testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction
562616 rows1 <- genRows
563617 rows2 <- genRows
564618
565− transaction \connection -> do
566− selected <- liftIO $ Rel8.select connection do
567− as <- Rel8.optional (Rel8.values (Rel8.lit <$> rows1))
568− bs <- Rel8.optional (Rel8.values (Rel8.lit <$> rows2))
569− pure $ liftA2 (,) as bs
619+ transaction do
620+ selected <- lift do
621+ statement () $ Rel8.select do
622+ as <- Rel8.optional (Rel8.values (Rel8.lit <$> rows1))
623+ bs <- Rel8.optional (Rel8.values (Rel8.lit <$> rows2))
624+ pure $ liftA2 (,) as bs
570625
571626 case (rows1, rows2) of
572627 ([], []) -> selected === [Nothing]
@@ -578,14 +633,6 @@ testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction
578633 genRows = forAll do
579634 Gen.list (Range.linear 0 10) $ liftA2 TestTable (Gen.text (Range.linear 0 10) Gen.unicode) (pure True)
580635
581−rollingBack
582− :: (MonadBaseControl IO m, MonadIO m)
583− => Connection -> m a -> m a
584−rollingBack connection =
585− bracket_
586− (liftIO (run (sql "BEGIN") connection))
587− (liftIO (run (sql "ROLLBACK") connection))
588−
589636
590637genTestTable :: Gen (TestTable Result)
591638genTestTable = do
@@ -598,19 +645,19 @@ testUpdate :: IO TmpPostgres.DB -> TestTree
598645testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do
599646 rows <- forAll $ Gen.map (Range.linear 0 5) $ liftA2 (,) genTestTable genTestTable
600647
601− transaction \connection -> do
602− void $ liftIO $ Rel8.insert connection
603− Rel8.Insert
648+ transaction do
649+ selected <- lift do
650+ statement () $ Rel8.insert Rel8.Insert
604651 { into = testTableSchema
605− , rows = map Rel8.lit $ Map.keys rows
652+ , rows = Rel8.values $ map Rel8.lit $ Map.keys rows
606653 , onConflict = Rel8.DoNothing
607− , returning = Rel8.NumberOfRowsAffected
654+ , returning = pure ()
608655 }
609656
610− void $ liftIO $ Rel8.update connection
611− Rel8.Update
657+ statement () $ Rel8.update Rel8.Update
612658 { target = testTableSchema
613− , set = \r ->
659+ , from = pure ()
660+ , set = \_ r ->
614661 let updates = map (bimap Rel8.lit Rel8.lit) $ Map.toList rows
615662 in
616663 foldl
@@ -624,12 +671,12 @@ testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do
624671 )
625672 r
626673 updates
627− , updateWhere = \_ -> Rel8.lit True
628− , returning = Rel8.NumberOfRowsAffected
674+ , updateWhere = \_ _ -> Rel8.lit True
675+ , returning = pure ()
629676 }
630677
631− selected <- liftIO $ Rel8.select connection do
632− Rel8.each testTableSchema
678+ statement () $ Rel8.select do
679+ Rel8.each testTableSchema
633680
634681 sort selected === sort (Map.elems rows)
635682
@@ -642,29 +689,96 @@ testDelete :: IO TmpPostgres.DB -> TestTree
642689testDelete = databasePropertyTest "Can DELETE TestTable" \transaction -> do
643690 rows <- forAll $ Gen.list (Range.linear 0 5) genTestTable
644691
645− transaction \connection -> do
646− void $ liftIO $ Rel8.insert connection
647− Rel8.Insert
692+ transaction do
693+ (deleted, selected) <- lift do
694+ statement () $ Rel8.insert Rel8.Insert
648695 { into = testTableSchema
649− , rows = map Rel8.lit rows
696+ , rows = Rel8.values $ map Rel8.lit rows
650697 , onConflict = Rel8.DoNothing
651− , returning = Rel8.NumberOfRowsAffected
698+ , returning = pure ()
652699 }
653700
654− deleted <-
655− liftIO $ Rel8.delete connection
656− Rel8.Delete
701+ deleted <- statement () $ Rel8.delete Rel8.Delete
657702 { from = testTableSchema
658− , deleteWhere = testTableColumn2
703+ , using = pure ()
704+ , deleteWhere = const testTableColumn2
659705 , returning = Rel8.Projection id
660706 }
661707
662− selected <- liftIO $ Rel8.select connection do
663− Rel8.each testTableSchema
708+ selected <- statement () $ Rel8.select do
709+ Rel8.each testTableSchema
710+
711+ pure (deleted, selected)
664712
665713 sort (deleted <> selected) === sort rows
666714
667715
716+data UniqueTable f = UniqueTable
717+ { uniqueTableKey :: Rel8.Column f Text
718+ , uniqueTableValue :: Rel8.Column f Text
719+ }
720+ deriving stock Generic
721+ deriving anyclass Rel8.Rel8able
722+
723+
724+deriving stock instance Eq (UniqueTable Result)
725+deriving stock instance Ord (UniqueTable Result)
726+deriving stock instance Show (UniqueTable Result)
727+
728+
729+uniqueTableSchema :: Rel8.TableSchema (UniqueTable Rel8.Name)
730+uniqueTableSchema =
731+ Rel8.TableSchema
732+ { name = "unique_table"
733+ , schema = Nothing
734+ , columns = UniqueTable
735+ { uniqueTableKey = "key"
736+ , uniqueTableValue = "value"
737+ }
738+ }
739+
740+
741+genUniqueTable :: Gen (UniqueTable Result)
742+genUniqueTable = do
743+ uniqueTableKey <- Gen.text (Range.linear 0 5) Gen.alphaNum
744+ uniqueTableValue <- Gen.text (Range.linear 0 5) Gen.alphaNum
745+ pure UniqueTable {..}
746+
747+
748+testUpsert :: IO TmpPostgres.DB -> TestTree
749+testUpsert = databasePropertyTest "Can UPSERT UniqueTable" \transaction -> do
750+ as <- unique $ forAll $ Gen.list (Range.linear 0 20) genUniqueTable
751+ bs <- unique $ forAll $ Gen.list (Range.linear 0 20) genUniqueTable
752+
753+ transaction do
754+ selected <- lift do
755+ statement () $ Rel8.insert Rel8.Insert
756+ { into = uniqueTableSchema
757+ , rows = Rel8.values $ Rel8.lit <$> as
758+ , onConflict = Rel8.DoNothing
759+ , returning = pure ()
760+ }
761+
762+ statement () $ Rel8.insert Rel8.Insert
763+ { into = uniqueTableSchema
764+ , rows = Rel8.values $ Rel8.lit <$> bs
765+ , onConflict = Rel8.DoUpdate Rel8.Upsert
766+ { index = uniqueTableKey
767+ , set = \UniqueTable {uniqueTableValue} old -> old {uniqueTableValue}
768+ , updateWhere = \_ _ -> Rel8.true
769+ }
770+ , returning = pure ()
771+ }
772+
773+ statement () $ Rel8.select do
774+ Rel8.each uniqueTableSchema
775+
776+ fromUniqueTables selected === fromUniqueTables bs <> fromUniqueTables as
777+ where
778+ unique = fmap (nubOrdOn uniqueTableKey)
779+ fromUniqueTables = Map.fromList . map \(UniqueTable key value) -> (key, value)
780+
781+
668782newtype HKNestedPair f = HKNestedPair { pairOne :: (TestTable f, TestTable f) }
669783 deriving stock Generic
670784 deriving anyclass Rel8.Rel8able
@@ -678,9 +792,10 @@ testSelectNestedPairs :: IO TmpPostgres.DB -> TestTree
678792testSelectNestedPairs = databasePropertyTest "Can SELECT nested pairs" \transaction -> do
679793 rows <- forAll $ Gen.list (Range.linear 0 10) $ HKNestedPair <$> liftA2 (,) genTestTable genTestTable
680794
681− transaction \connection -> do
682− selected <- liftIO $ Rel8.select connection do
683− Rel8.values $ map Rel8.lit rows
795+ transaction do
796+ selected <- lift do
797+ statement () $ Rel8.select do
798+ Rel8.values $ map Rel8.lit rows
684799
685800 sort selected === sort rows
686801
@@ -689,18 +804,20 @@ testSelectArray :: IO TmpPostgres.DB -> TestTree
689804testSelectArray = databasePropertyTest "Can SELECT Arrays (with aggregation)" \transaction -> do
690805 rows <- forAll $ Gen.list (Range.linear 1 10) Gen.bool
691806
692− transaction \connection -> do
693− selected <- liftIO $ Rel8.select connection do
694− Rel8.many $ Rel8.values (map Rel8.lit rows)
807+ transaction do
808+ selected <- lift do
809+ statement () $ Rel8.select do
810+ Rel8.many $ Rel8.values (map Rel8.lit rows)
695811
696812 selected === [foldMap pure rows]
697813
698− selected' <- liftIO $ Rel8.select connection $ do
699− a <- Rel8.catListTable =<< do
700− Rel8.many $ Rel8.values (map Rel8.lit rows)
701− b <- Rel8.catListTable =<< do
702− Rel8.many $ Rel8.values (map Rel8.lit rows)
703− pure (a, b)
814+ selected' <- lift do
815+ statement () $ Rel8.select do
816+ a <- Rel8.catListTable =<< do
817+ Rel8.many $ Rel8.values (map Rel8.lit rows)
818+ b <- Rel8.catListTable =<< do
819+ Rel8.many $ Rel8.values (map Rel8.lit rows)
820+ pure (a, b)
704821
705822 selected' === liftA2 (,) rows rows
706823
@@ -722,10 +839,11 @@ testNestedMaybeTable :: IO TmpPostgres.DB -> TestTree
722839testNestedMaybeTable = databasePropertyTest "Can nest MaybeTable within other tables" \transaction -> do
723840 let example = NestedMaybeTable { nmt1 = True, nmt2 = Just (TestTable "Hi" True) }
724841
725− transaction \connection -> do
726− selected <- liftIO $ Rel8.select connection do
727− x <- Rel8.values [Rel8.lit example]
728− pure $ Rel8.maybeTable (Rel8.lit False) (\_ -> Rel8.lit True) (nmt2 x)
842+ transaction do
843+ selected <- lift do
844+ statement () $ Rel8.select do
845+ x <- Rel8.values [Rel8.lit example]
846+ pure $ Rel8.maybeTable (Rel8.lit False) (\_ -> Rel8.lit True) (nmt2 x)
729847
730848 selected === [True]
731849
@@ -733,11 +851,12 @@ testNestedMaybeTable = databasePropertyTest "Can nest MaybeTable within other ta
733851testEvaluate :: IO TmpPostgres.DB -> TestTree
734852testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect" \transaction -> do
735853
736− transaction \connection -> do
737− selected <- liftIO $ Rel8.select connection do
738− x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])
739− y <- Rel8.evaluate (Rel8.nextval "test_seq")
740− pure (x, (y, y))
854+ transaction do
855+ selected <- lift do
856+ statement () $ Rel8.select do
857+ x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])
858+ y <- Rel8.evaluate (Rel8.nextval "test_seq")
859+ pure (x, (y, y))
741860
742861 normalize selected ===
743862 [ ('a', (0, 0))
@@ -745,11 +864,12 @@ testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect
745864 , ('c', (2, 2))
746865 ]
747866
748− selected' <- liftIO $ Rel8.select connection do
749− x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])
750− y <- Rel8.values (Rel8.lit <$> ['d', 'e', 'f'])
751− z <- Rel8.evaluate (Rel8.nextval "test_seq")
752− pure ((x, y), (z, z))
867+ selected' <- lift do
868+ statement () $ Rel8.select do
869+ x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])
870+ y <- Rel8.values (Rel8.lit <$> ['d', 'e', 'f'])
871+ z <- Rel8.evaluate (Rel8.nextval "test_seq")
872+ pure ((x, y), (z, z))
753873
754874 normalize selected' ===
755875 [ (('a', 'd'), (0, 0))
@@ -767,13 +887,3 @@ testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect
767887 normalize :: [(x, (Int64, Int64))] -> [(x, (Int64, Int64))]
768888 normalize [] = []
769889 normalize xs@((_, (i, _)) : _) = map (fmap (\(a, b) -> (a - i, b - i))) xs
770−
771−{-
772− selected <- liftIO $ Rel8.select connection do
773− x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])
774− x <- Rel8.values (Rel8.lit <$> ['d', 'e', 'f'])
775− y <- Rel8.evaluate (Rel8.nextval "test_seq")
776− pure (x, y, y)
777−
778− selected === [('a', 1, 1), ('b', 2, 2), ('c', 3, 3)]
779−-}