git.iko.soy/rel8
on 5a2ea36 help sign in
rel8/tests/Main.hs
771 lines 25 kB history raw
1{-# language BlockArguments #-}
2{-# language DataKinds #-}
3{-# language DeriveAnyClass #-}
4{-# language DeriveGeneric #-}
5{-# language DerivingStrategies #-}
6{-# language DisambiguateRecordFields #-}
7{-# language FlexibleContexts #-}
8{-# language FlexibleInstances #-}
9{-# language GADTs #-}
10{-# language NamedFieldPuns #-}
11{-# language OverloadedStrings #-}
12{-# language RecordWildCards #-}
13{-# language ScopedTypeVariables #-}
14{-# language StandaloneDeriving #-}
15{-# language TypeApplications #-}
17{-# options_ghc -fno-warn-redundant-constraints #-}
19module Main
20 ( main
21 )
22where
24-- base
25import Control.Applicative ( liftA2, liftA3 )
26import Control.Monad (void)
27import Control.Monad.IO.Class ( MonadIO, liftIO )
28import Data.Bifunctor ( bimap )
29import Data.Foldable ( for_ )
30import Data.Functor.Identity ( Identity )
31import Data.Int ( Int32, Int64 )
32import Data.List ( nub, sort )
33import Data.Maybe ( catMaybes )
34import Data.String ( fromString )
35import Data.Word (Word32)
36import GHC.Generics ( Generic )
38-- bytestring
39import qualified Data.ByteString.Lazy
41-- case-insensitive
42import Data.CaseInsensitive (mk)
44-- containers
45import qualified Data.Map.Strict as Map
47-- hasql
48import Hasql.Connection ( Connection, acquire, release )
49import Hasql.Session ( sql, run )
51-- hedgehog
52import Hedgehog ( property, (===), forAll, cover, diff, evalM, PropertyT, TestT, test, Gen )
53import qualified Hedgehog.Gen as Gen
54import qualified Hedgehog.Range as Range
56-- lifted-base
57import Control.Exception.Lifted ( bracket, throwIO, bracket_ )
59-- monad-control
60import Control.Monad.Trans.Control ( MonadBaseControl )
62-- rel8
63import qualified Rel8.Expr as Rel8
64import qualified Rel8.Expr.Bool as Rel8
65import qualified Rel8.Expr.Eq as Rel8
66import qualified Rel8.Query.Aggregate as Rel8
67import qualified Rel8.Query.Distinct as Rel8
68import qualified Rel8.Query.Each as Rel8
69import qualified Rel8.Query.Exists as Rel8
70import qualified Rel8.Query.Filter as Rel8
71import qualified Rel8.Query.Limit as Rel8
72import qualified Rel8.Query.Maybe as Rel8
73import qualified Rel8.Query.Null as Rel8
74import qualified Rel8.Query.Set as Rel8
75import qualified Rel8.Query.Values as Rel8
76import qualified Rel8.Schema.Column as Rel8
77import qualified Rel8.Schema.Context as Rel8
78import qualified Rel8.Schema.Generic as Rel8
79import qualified Rel8.Schema.Nullability as Rel8
80import qualified Rel8.Schema.Table as Rel8
81import qualified Rel8.Statement.Delete as Rel8
82import qualified Rel8.Statement.Insert as Rel8
83import qualified Rel8.Statement.Returning as Rel8
84import qualified Rel8.Statement.Select as Rel8
85import qualified Rel8.Statement.Update as Rel8
86import qualified Rel8.Table.Aggregate as Rel8
87import qualified Rel8.Table.Bool as Rel8
88import qualified Rel8.Table.Eq as Rel8
89import qualified Rel8.Table.Insert as Rel8
90import qualified Rel8.Table.Maybe as Rel8
91import qualified Rel8.Table.Serialize as Rel8
92import qualified Rel8.Type as Rel8
93import qualified Rel8.Type.Eq as Rel8
95-- scientific
96import Data.Scientific ( Scientific )
98-- tasty
99import Test.Tasty
101-- tasty-hedgehog
102import Test.Tasty.Hedgehog ( testProperty )
104-- text
105import Data.Text (Text, pack)
106import qualified Data.Text.Lazy
108-- time
109import Data.Time
111-- tmp-postgres
112import qualified Database.Postgres.Temp as TmpPostgres
114-- uuid
115import qualified Data.UUID
118main :: IO ()
119main = defaultMain tests
122tests :: TestTree
123tests =
124 withResource startTestDatabase stopTestDatabase \getTestDatabase ->
125 testGroup "rel8"
126 [ testSelectTestTable getTestDatabase
127 , testWhere_ getTestDatabase
128 , testFilter getTestDatabase
129 , testLimit getTestDatabase
130 , testUnion getTestDatabase
131 , testDistinct getTestDatabase
132 , testExists getTestDatabase
133 , testOptional getTestDatabase
134 , testAnd getTestDatabase
135 , testOr getTestDatabase
136 , testNot getTestDatabase
137 , testBool getTestDatabase
138 , testAp getTestDatabase
139 , testDBType getTestDatabase
140 , testDBEq getTestDatabase
141 , testTableEquality getTestDatabase
142 , testFromString getTestDatabase
143 , testCatMaybeTable getTestDatabase
144 , testCatMaybe getTestDatabase
145 , testMaybeTable getTestDatabase
146 , testNestedTables getTestDatabase
147 , testMaybeTableApplicative getTestDatabase
148 , testLogicalFixities getTestDatabase
149 , testUpdate getTestDatabase
150 , testDelete getTestDatabase
151 , testSelectNestedPairs getTestDatabase
152 , testSelectArray getTestDatabase
153 , testNestedMaybeTable getTestDatabase
154 ]
156 where
158 startTestDatabase = do
159 db <- TmpPostgres.start >>= either throwIO return
161 bracket (either (error . show) return =<< acquire (TmpPostgres.toConnectionString db)) release \conn -> void do
162 flip run conn do
163 sql "CREATE EXTENSION citext"
164 sql "CREATE TABLE test_table ( column1 text not null, column2 bool not null )"
166 return db
168 stopTestDatabase = TmpPostgres.stop
171databasePropertyTest
172 :: TestName
173 -> (((Connection -> TestT IO ()) -> PropertyT IO ()) -> PropertyT IO ())
174 -> IO TmpPostgres.DB -> TestTree
175databasePropertyTest testName f getTestDatabase =
176 withResource connect release $ \c ->
177 testProperty testName $ property do
178 connection <- liftIO c
179 f \g -> test $ rollingBack connection $ g connection
181 where
183 connect = either (error . show) return =<< acquire . TmpPostgres.toConnectionString =<< getTestDatabase
186data TestTable f = TestTable
187 { testTableColumn1 :: Rel8.Column f Text
188 , testTableColumn2 :: Rel8.Column f Bool
189 }
190 deriving stock Generic
191 deriving anyclass Rel8.Rel8able
194deriving stock instance Eq (TestTable Identity)
195deriving stock instance Ord (TestTable Identity)
196deriving stock instance Show (TestTable Identity)
199testTableSchema :: Rel8.TableSchema (TestTable Rel8.Name)
200testTableSchema =
201 Rel8.TableSchema
202 { name = "test_table"
203 , schema = Nothing
204 , columns = TestTable
205 { testTableColumn1 = "column1"
206 , testTableColumn2 = "column2"
207 }
208 }
211testSelectTestTable :: IO TmpPostgres.DB -> TestTree
212testSelectTestTable = databasePropertyTest "Can SELECT TestTable" \transaction -> do
213 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
215 transaction \connection -> do
216 void do
217 liftIO $ Rel8.insert connection
218 Rel8.Insert
219 { into = testTableSchema
220 , rows = map (Rel8.toInsert . Rel8.lit) rows
221 , onConflict = Rel8.DoNothing
222 , returning = Rel8.NumberOfRowsAffected
223 }
225 selected <- liftIO $ Rel8.select connection do
226 Rel8.each testTableSchema
228 sort selected === sort rows
230 cover 1 "Empty" $ null rows
231 cover 1 "Singleton" $ null $ drop 1 rows
232 cover 1 ">1 row" $ not $ null $ drop 1 rows
235testWhere_ :: IO TmpPostgres.DB -> TestTree
236testWhere_ = databasePropertyTest "WHERE (Rel8.where_)" \transaction -> do
237 rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable
239 magicBool <- forAll Gen.bool
241 let expected = filter (\t -> testTableColumn2 t == magicBool) rows
243 transaction \connection -> do
244 selected <- liftIO $ Rel8.select connection do
245 t <- Rel8.values $ Rel8.lit <$> rows
246 Rel8.where_ $ testTableColumn2 t Rel8.==. Rel8.lit magicBool
247 return t
249 sort selected === sort expected
251 cover 1 "No results" $ null expected
252 cover 1 "Some results" $ not $ null expected
253 cover 1 "All results" $ expected == rows
256testFilter :: IO TmpPostgres.DB -> TestTree
257testFilter = databasePropertyTest "filter" \transaction -> do
258 rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable
260 transaction \connection -> do
261 let expected = filter testTableColumn2 rows
263 selected <- liftIO $ Rel8.select connection
264 $ Rel8.filter testTableColumn2 =<< Rel8.values (Rel8.lit <$> rows)
266 sort selected === sort expected
268 cover 1 "No results" $ null expected
269 cover 1 "Some results" $ not $ null expected
270 cover 1 "All results" $ expected == rows
273testLimit :: IO TmpPostgres.DB -> TestTree
274testLimit = databasePropertyTest "LIMIT (Rel8.limit)" \transaction -> do
275 rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable
277 n <- forAll $ Gen.integral (Range.linear 0 10)
279 transaction \connection -> do
280 selected <- liftIO $ Rel8.select connection do
281 Rel8.limit n $ Rel8.values (Rel8.lit <$> rows)
283 diff (length selected) (<=) (fromIntegral n)
285 for_ selected \row ->
286 diff row elem rows
288 cover 1 "n == 0" $ n == 0
289 cover 1 "n < length rows" $ fromIntegral n < length rows
290 cover 1 "n == length rows" $ fromIntegral n == length rows
291 cover 1 "n >= length rows" $ fromIntegral n >= length rows
294testUnion :: IO TmpPostgres.DB -> TestTree
295testUnion = databasePropertyTest "UNION (Rel8.union)" \transaction -> evalM do
296 left <- forAll $ Gen.list (Range.linear 0 10) genTestTable
297 right <- forAll $ Gen.list (Range.linear 0 10) genTestTable
299 transaction \connection -> do
300 selected <- liftIO $ Rel8.select connection do
301 Rel8.values (Rel8.lit <$> nub left) `Rel8.union` Rel8.values (Rel8.lit <$> nub right)
303 sort selected === sort (nub (left ++ right))
306testDistinct :: IO TmpPostgres.DB -> TestTree
307testDistinct = databasePropertyTest "DISTINCT (Rel8.distinct)" \transaction -> do
308 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
310 transaction \connection -> do
311 selected <- liftIO $ Rel8.select connection $ Rel8.distinct do
312 Rel8.values (Rel8.lit <$> rows)
314 sort selected === nub (sort rows)
316 cover 1 "Empty" $ null rows
317 cover 1 "Duplicates" $ not (null rows) && rows /= nub rows
318 cover 1 "No duplicates" $ not (null rows) && rows == nub rows
321testExists :: IO TmpPostgres.DB -> TestTree
322testExists = databasePropertyTest "EXISTS (Rel8.exists)" \transaction -> do
323 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
325 transaction \connection -> do
326 exists <- liftIO $ Rel8.select connection $ Rel8.exists $ Rel8.values $ Rel8.lit <$> rows
328 case rows of
329 [] -> exists === [False]
330 _ -> exists === [True]
333testOptional :: IO TmpPostgres.DB -> TestTree
334testOptional = databasePropertyTest "Rel8.optional" \transaction -> do
335 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
337 transaction \connection -> do
338 selected <- liftIO $ Rel8.select connection do
339 Rel8.optional $ Rel8.values (Rel8.lit <$> rows)
341 case rows of
342 [] -> selected === [Nothing]
343 _ -> sort selected === fmap Just (sort rows)
346testAnd :: IO TmpPostgres.DB -> TestTree
347testAnd = databasePropertyTest "AND (&&.)" \transaction -> do
348 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool
350 transaction \connection -> do
351 [result] <- liftIO $ Rel8.select connection $ pure $
352 Rel8.lit x Rel8.&&. Rel8.lit y
354 result === (x && y)
357testOr :: IO TmpPostgres.DB -> TestTree
358testOr = databasePropertyTest "OR (||.)" \transaction -> do
359 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool
361 transaction \connection -> do
362 [result] <- liftIO $ Rel8.select connection $ pure $
363 Rel8.lit x Rel8.||. Rel8.lit y
365 result === (x || y)
368testLogicalFixities :: IO TmpPostgres.DB -> TestTree
369testLogicalFixities = databasePropertyTest "Logical operator fixities" \transaction -> do
370 (u, v, w, x) <- forAll $ (,,,) <$> Gen.bool <*> Gen.bool <*> Gen.bool <*> Gen.bool
372 transaction \connection -> do
373 [result] <- liftIO $ Rel8.select connection $ pure $
374 Rel8.lit u Rel8.||. Rel8.lit v Rel8.&&. Rel8.lit w Rel8.==. Rel8.lit x
376 result === (u || v && w == x)
379testNot :: IO TmpPostgres.DB -> TestTree
380testNot = databasePropertyTest "NOT (not_)" \transaction -> do
381 x <- forAll Gen.bool
383 transaction \connection -> do
384 [result] <- liftIO $ Rel8.select connection $ pure $
385 Rel8.not_ $ Rel8.lit x
387 result === not x
390testBool :: IO TmpPostgres.DB -> TestTree
391testBool = databasePropertyTest "ifThenElse_" \transaction -> do
392 (x, y, z) <- forAll $ liftA3 (,,) Gen.bool Gen.bool Gen.bool
394 transaction \connection -> do
395 [result] <- liftIO $ Rel8.select connection $ pure $
396 Rel8.bool (Rel8.lit z) (Rel8.lit y) (Rel8.lit x)
398 result === if x then y else z
401testAp :: IO TmpPostgres.DB -> TestTree
402testAp = databasePropertyTest "Cartesian product (<*>)" \transaction -> do
403 (rows1, rows2) <- forAll $
404 liftA2 (,)
405 (Gen.list (Range.linear 1 10) genTestTable)
406 (Gen.list (Range.linear 1 10) genTestTable)
408 transaction \connection -> do
409 result <- liftIO $ Rel8.select connection $ do
410 liftA2 (,) (Rel8.values (Rel8.lit <$> rows1)) (Rel8.values (Rel8.lit <$> rows2))
412 sort result === sort (liftA2 (,) rows1 rows2)
415testDBType :: IO TmpPostgres.DB -> TestTree
416testDBType getTestDatabase = testGroup "DBType instances"
417 [ dbTypeTest "Bool" Gen.bool
418 , dbTypeTest "ByteString" $ Gen.bytes (Range.linear 0 128)
419 , dbTypeTest "CI Lazy Text" $ mk . Data.Text.Lazy.fromStrict <$> Gen.text (Range.linear 0 10) Gen.unicode
420 , dbTypeTest "CI Text" $ mk <$> Gen.text (Range.linear 0 10) Gen.unicode
421 , dbTypeTest "Day" genDay
422 , dbTypeTest "Double" $ (/10) . fromIntegral @Int @Double <$> Gen.integral (Range.linear (-100) 100)
423 , dbTypeTest "Float" $ (/10) . fromIntegral @Int @Float <$> Gen.integral (Range.linear (-100) 100)
424 , dbTypeTest "Int32" $ Gen.integral @_ @Int32 Range.linearBounded
425 , dbTypeTest "Int64" $ Gen.integral @_ @Int64 Range.linearBounded
426 , dbTypeTest "Lazy ByteString" $ Data.ByteString.Lazy.fromStrict <$> Gen.bytes (Range.linear 0 128)
427 , dbTypeTest "Lazy Text" $ Data.Text.Lazy.fromStrict <$> Gen.text (Range.linear 0 10) Gen.unicode
428 , dbTypeTest "LocalTime" genLocalTime
429 , dbTypeTest "Scientific" $ (/10) . fromIntegral @Int @Scientific <$> Gen.integral (Range.linear (-100) 100)
430 , dbTypeTest "Text" $ Gen.text (Range.linear 0 10) Gen.unicode
431 , dbTypeTest "TimeOfDay" genTimeOfDay
432 , dbTypeTest "UTCTime" $ UTCTime <$> genDay <*> genDiffTime
433 , dbTypeTest "UUID" $ Data.UUID.fromWords <$> genWord32 <*> genWord32 <*> genWord32 <*> genWord32
434 ]
436 where
437 dbTypeTest ::
438 ( Eq a, Show a
439 , Rel8.Sql Rel8.DBType a
440 , Rel8.IsMaybe a ~ 'False
441 , Rel8.Serializable (Rel8.Expr a) a
442 , Rel8.Serializable (Rel8.Expr (Maybe a)) (Maybe a)
443 ) => TestName -> Gen a -> TestTree
444 dbTypeTest name generator = testGroup name
445 [ databasePropertyTest name (t (==) generator) getTestDatabase
446 , databasePropertyTest ("Maybe " <> name) (t (==) (Gen.maybe generator)) getTestDatabase
447 ]
449 t :: forall a b. (Show a, Rel8.Sql Rel8.DBType a, Rel8.Serializable (Rel8.Expr a) a)
450 => (a -> a -> Bool)
451 -> Gen a
452 -> ((Connection -> TestT IO ()) -> PropertyT IO b)
453 -> PropertyT IO b
454 t eq generator transaction = do
455 x <- forAll generator
457 transaction \connection -> do
458 [res] <- liftIO $ Rel8.select connection $ pure (Rel8.lit x :: Rel8.Expr a)
459 diff res eq x
461 genDay :: Gen Day
462 genDay = do
463 year <- Gen.integral (Range.linear 1970 3000)
464 month <- Gen.integral (Range.linear 1 12)
465 day <- Gen.integral (Range.linear 1 31)
466 Gen.just $ pure $ fromGregorianValid year month day
468 genDiffTime :: Gen DiffTime
469 genDiffTime = secondsToDiffTime <$> Gen.integral (Range.linear 0 86401)
471 genTimeOfDay :: Gen TimeOfDay
472 genTimeOfDay = do
473 hour <- Gen.integral (Range.linear 0 23)
474 minute <- Gen.integral (Range.linear 0 59)
475 sec <- fromIntegral @Int <$> Gen.integral (Range.linear 0 59)
476 Gen.just $ pure $ makeTimeOfDayValid hour minute sec
478 genLocalTime = LocalTime <$> genDay <*> genTimeOfDay
480 genWord32 :: Gen Word32
481 genWord32 = Gen.integral Range.linearBounded
484testDBEq :: IO TmpPostgres.DB -> TestTree
485testDBEq getTestDatabase = testGroup "DBEq instances"
486 [ dbEqTest "Bool" Gen.bool
487 , dbEqTest "Int32" $ Gen.integral @_ @Int32 Range.linearBounded
488 , dbEqTest "Int64" $ Gen.integral @_ @Int64 Range.linearBounded
489 , dbEqTest "Text" $ Gen.text (Range.linear 0 10) Gen.unicode
490 ]
492 where
493 dbEqTest ::
494 ( Eq a, Show a
495 , Rel8.Sql Rel8.DBEq a
496 , Rel8.IsMaybe a ~ 'False
497 , Rel8.Serializable (Rel8.Expr a) a
498 , Rel8.Serializable (Rel8.Expr (Maybe a)) (Maybe a)
499 ) => TestName -> Gen a -> TestTree
500 dbEqTest name generator = testGroup name
501 [ databasePropertyTest name (t generator) getTestDatabase
502 , databasePropertyTest ("Maybe " <> name) (t (Gen.maybe generator)) getTestDatabase
503 ]
505 t :: forall a.
506 ( Eq a, Show a
507 , Rel8.Sql Rel8.DBEq a
508 , Rel8.Serializable (Rel8.Expr a) a
509 )
510 => Gen a
511 -> ((Connection -> TestT IO ()) -> PropertyT IO ())
512 -> PropertyT IO ()
513 t generator transaction = do
514 (x, y) <- forAll (liftA2 (,) generator generator)
516 transaction \connection -> do
517 [res] <- liftIO $ Rel8.select connection $ pure $ Rel8.lit @(Rel8.Expr a) x Rel8.==. Rel8.lit y
518 res === (x == y)
520 cover 1 "Equal" $ x == y
521 cover 1 "Not Equal" $ x /= y
524testTableEquality :: IO TmpPostgres.DB -> TestTree
525testTableEquality = databasePropertyTest "TestTable equality" \transaction -> do
526 (x, y) <- forAll $ liftA2 (,) genTestTable genTestTable
528 transaction \connection -> do
529 [eq] <- liftIO $ Rel8.select connection do
530 pure $ Rel8.lit x Rel8.==: Rel8.lit y
532 eq === (x == y)
534 cover 1 "Equal" $ x == y
535 cover 1 "Not Equal" $ x /= y
538testFromString :: IO TmpPostgres.DB -> TestTree
539testFromString = databasePropertyTest "FromString" \transaction -> do
540 str <- forAll $ Gen.list (Range.linear 0 10) Gen.unicode
542 transaction \connection -> do
543 [result] <- liftIO $ Rel8.select connection $ pure $ fromString str
544 result === pack str
547testCatMaybeTable :: IO TmpPostgres.DB -> TestTree
548testCatMaybeTable = databasePropertyTest "catMaybeTable" \transaction -> do
549 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
551 transaction \connection -> do
552 selected <- liftIO $ Rel8.select connection do
553 testTable <- Rel8.values $ Rel8.lit <$> rows
554 Rel8.catMaybeTable $ Rel8.bool Rel8.nothingTable (pure testTable) (testTableColumn2 testTable)
556 sort selected === sort (filter testTableColumn2 rows)
559testCatMaybe :: IO TmpPostgres.DB -> TestTree
560testCatMaybe = databasePropertyTest "catMaybe" \transaction -> evalM do
561 rows <- forAll $ Gen.list (Range.linear 0 10) $ Gen.maybe Gen.bool
563 transaction \connection -> do
564 selected <- evalM $ liftIO $ Rel8.select connection do
565 Rel8.catNullable =<< Rel8.values (map Rel8.lit rows)
567 sort selected === sort (catMaybes rows)
570testMaybeTable :: IO TmpPostgres.DB -> TestTree
571testMaybeTable = databasePropertyTest "maybeTable" \transaction -> evalM do
572 (rows, def) <- forAll $ liftA2 (,) (Gen.list (Range.linear 0 10) genTestTable) genTestTable
574 transaction \connection -> do
575 selected <- liftIO $ Rel8.select connection $
576 Rel8.maybeTable (Rel8.lit def) id <$> Rel8.optional (Rel8.values (Rel8.lit <$> rows))
578 case rows of
579 [] -> selected === [def]
580 _ -> sort selected === sort rows
583data TwoTestTables f =
584 TwoTestTables
585 { testTable1 :: TestTable f
586 , testTable2 :: TestTable f
587 }
588 deriving stock Generic
589 deriving anyclass Rel8.Rel8able
592deriving stock instance Eq (TwoTestTables Identity)
593deriving stock instance Ord (TwoTestTables Identity)
594deriving stock instance Show (TwoTestTables Identity)
597testNestedTables :: IO TmpPostgres.DB -> TestTree
598testNestedTables = databasePropertyTest "Nested TestTables" \transaction -> evalM do
599 rows <- forAll do
600 Gen.list (Range.linear 0 10) $
601 liftA2 TwoTestTables genTestTable genTestTable
603 transaction \connection -> do
604 selected <- liftIO $ Rel8.select connection do
605 Rel8.values (Rel8.lit <$> rows)
607 sort selected === sort rows
610testMaybeTableApplicative :: IO TmpPostgres.DB -> TestTree
611testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction -> evalM do
612 rows1 <- genRows
613 rows2 <- genRows
615 transaction \connection -> do
616 selected <- liftIO $ Rel8.select connection do
617 as <- Rel8.optional (Rel8.values (Rel8.lit <$> rows1))
618 bs <- Rel8.optional (Rel8.values (Rel8.lit <$> rows2))
619 pure $ liftA2 (,) as bs
621 case (rows1, rows2) of
622 ([], []) -> selected === [Nothing]
623 ([], bs) -> selected === (Nothing <$ bs)
624 (as, []) -> selected === (Nothing <$ as)
625 (as, bs) -> sort selected === sort (Just <$> liftA2 (,) as bs)
626 where
627 genRows :: PropertyT IO [TestTable Identity]
628 genRows = forAll do
629 Gen.list (Range.linear 0 10) $ liftA2 TestTable (Gen.text (Range.linear 0 10) Gen.unicode) (pure True)
631rollingBack
632 :: (MonadBaseControl IO m, MonadIO m)
633 => Connection -> m a -> m a
634rollingBack connection =
635 bracket_
636 (liftIO (run (sql "BEGIN") connection))
637 (liftIO (run (sql "ROLLBACK") connection))
640genTestTable :: Gen (TestTable Identity)
641genTestTable = do
642 testTableColumn1 <- Gen.text (Range.linear 0 5) Gen.alphaNum
643 testTableColumn2 <- Gen.bool
644 return TestTable{..}
647testUpdate :: IO TmpPostgres.DB -> TestTree
648testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do
649 rows <- forAll $ Gen.map (Range.linear 0 5) $ liftA2 (,) genTestTable genTestTable
651 transaction \connection -> do
652 void $ liftIO $ Rel8.insert connection
653 Rel8.Insert
654 { into = testTableSchema
655 , rows = map (Rel8.toInsert . Rel8.lit) $ Map.keys rows
656 , onConflict = Rel8.DoNothing
657 , returning = Rel8.NumberOfRowsAffected
658 }
660 void $ liftIO $ Rel8.update connection
661 Rel8.Update
662 { target = testTableSchema
663 , set = \r ->
664 let updates = map (bimap Rel8.lit Rel8.lit) $ Map.toList rows
665 in
666 foldl
667 ( \e (x, y) ->
668 Rel8.bool
669 e
670 y
671 ( testTableColumn1 r Rel8.==. testTableColumn1 x Rel8.&&.
672 testTableColumn2 r Rel8.==. testTableColumn2 x
673 )
674 )
675 r
676 updates
677 , updateWhere = \_ -> Rel8.lit True
678 , returning = Rel8.NumberOfRowsAffected
679 }
681 selected <- liftIO $ Rel8.select connection do
682 Rel8.each testTableSchema
684 sort selected === sort (Map.elems rows)
686 cover 1 "Empty" $ null rows
687 cover 1 "Singleton" $ null $ drop 1 $ Map.keys rows
688 cover 1 ">1 row" $ not $ null $ drop 1 $ Map.keys rows
691testDelete :: IO TmpPostgres.DB -> TestTree
692testDelete = databasePropertyTest "Can DELETE TestTable" \transaction -> do
693 rows <- forAll $ Gen.list (Range.linear 0 5) genTestTable
695 transaction \connection -> do
696 void $ liftIO $ Rel8.insert connection
697 Rel8.Insert
698 { into = testTableSchema
699 , rows = map (Rel8.toInsert . Rel8.lit) rows
700 , onConflict = Rel8.DoNothing
701 , returning = Rel8.NumberOfRowsAffected
702 }
704 deleted <-
705 liftIO $ Rel8.delete connection
706 Rel8.Delete
707 { from = testTableSchema
708 , deleteWhere = testTableColumn2
709 , returning = Rel8.Projection id
710 }
712 selected <- liftIO $ Rel8.select connection do
713 Rel8.each testTableSchema
715 sort (deleted <> selected) === sort rows
718newtype HKNestedPair f = HKNestedPair { pairOne :: (TestTable f, TestTable f) }
719 deriving stock Generic
720 deriving anyclass Rel8.Rel8able
722deriving stock instance Eq (HKNestedPair Identity)
723deriving stock instance Ord (HKNestedPair Identity)
724deriving stock instance Show (HKNestedPair Identity)
727testSelectNestedPairs :: IO TmpPostgres.DB -> TestTree
728testSelectNestedPairs = databasePropertyTest "Can SELECT nested pairs" \transaction -> do
729 rows <- forAll $ Gen.list (Range.linear 0 10) $ HKNestedPair <$> liftA2 (,) genTestTable genTestTable
731 transaction \connection -> do
732 selected <- liftIO $ Rel8.select connection do
733 Rel8.values $ map Rel8.lit rows
735 sort selected === sort rows
738testSelectArray :: IO TmpPostgres.DB -> TestTree
739testSelectArray = databasePropertyTest "Can SELECT Arrays (with aggregation)" \transaction -> do
740 rows <- forAll $ Gen.list (Range.linear 1 10) Gen.bool
742 transaction \connection -> do
743 selected <- liftIO $ Rel8.select connection $ Rel8.aggregate do
744 Rel8.listAgg <$> Rel8.values (map Rel8.lit rows)
746 selected === [foldMap pure rows]
749data NestedMaybeTable f = NestedMaybeTable
750 { nmt1 :: Rel8.Column f Bool
751 , nmt2 :: Rel8.HMaybe f (TestTable f)
752 }
753 deriving stock Generic
754 deriving anyclass Rel8.Rel8able
757deriving stock instance Eq (NestedMaybeTable Identity)
758deriving stock instance Ord (NestedMaybeTable Identity)
759deriving stock instance Show (NestedMaybeTable Identity)
762testNestedMaybeTable :: IO TmpPostgres.DB -> TestTree
763testNestedMaybeTable = databasePropertyTest "Can nest MaybeTable within other tables" \transaction -> do
764 let example = NestedMaybeTable { nmt1 = True, nmt2 = Just (TestTable "Hi" True) }
766 transaction \connection -> do
767 selected <- liftIO $ Rel8.select connection do
768 x <- Rel8.values [Rel8.lit example]
769 pure $ Rel8.maybeTable (Rel8.lit False) (\_ -> Rel8.lit True) (nmt2 x)
771 selected === [True]