git.iko.soy/rel8
on ca7aaef help sign in
rel8/tests/Main.hs
725 lines 23 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
65-- scientific
66import Data.Scientific ( Scientific )
68-- tasty
69import Test.Tasty
71-- tasty-hedgehog
72import Test.Tasty.Hedgehog ( testProperty )
74-- text
75import Data.Text (Text, pack)
76import qualified Data.Text.Lazy
78-- time
79import Data.Time
81-- tmp-postgres
82import qualified Database.Postgres.Temp as TmpPostgres
84-- uuid
85import qualified Data.UUID
88main :: IO ()
89main = defaultMain tests
92tests :: TestTree
93tests =
94 withResource startTestDatabase stopTestDatabase \getTestDatabase ->
95 testGroup "rel8"
96 [ testSelectTestTable getTestDatabase
97 , testWhere_ getTestDatabase
98 , testFilter getTestDatabase
99 , testLimit getTestDatabase
100 , testUnion getTestDatabase
101 , testDistinct getTestDatabase
102 , testExists getTestDatabase
103 , testOptional getTestDatabase
104 , testAnd getTestDatabase
105 , testOr getTestDatabase
106 , testNot getTestDatabase
107 , testBool getTestDatabase
108 , testAp getTestDatabase
109 , testDBType getTestDatabase
110 , testDBEq getTestDatabase
111 , testTableEquality getTestDatabase
112 , testFromString getTestDatabase
113 , testCatMaybeTable getTestDatabase
114 , testCatMaybe getTestDatabase
115 , testMaybeTable getTestDatabase
116 , testNestedTables getTestDatabase
117 , testMaybeTableApplicative getTestDatabase
118 , testLogicalFixities getTestDatabase
119 , testUpdate getTestDatabase
120 , testDelete getTestDatabase
121 , testSelectNestedPairs getTestDatabase
122 , testSelectArray getTestDatabase
123 , testNestedMaybeTable getTestDatabase
124 ]
126 where
128 startTestDatabase = do
129 db <- TmpPostgres.start >>= either throwIO return
131 bracket (either (error . show) return =<< acquire (TmpPostgres.toConnectionString db)) release \conn -> void do
132 flip run conn do
133 sql "CREATE EXTENSION citext"
134 sql "CREATE TABLE test_table ( column1 text not null, column2 bool not null )"
136 return db
138 stopTestDatabase = TmpPostgres.stop
141databasePropertyTest
142 :: TestName
143 -> (((Connection -> TestT IO ()) -> PropertyT IO ()) -> PropertyT IO ())
144 -> IO TmpPostgres.DB -> TestTree
145databasePropertyTest testName f getTestDatabase =
146 withResource connect release $ \c ->
147 testProperty testName $ property do
148 connection <- liftIO c
149 f \g -> test $ rollingBack connection $ g connection
151 where
153 connect = either (error . show) return =<< acquire . TmpPostgres.toConnectionString =<< getTestDatabase
156data TestTable f = TestTable
157 { testTableColumn1 :: Rel8.Column f Text
158 , testTableColumn2 :: Rel8.Column f Bool
159 }
160 deriving stock Generic
161 deriving anyclass Rel8.Rel8able
164deriving stock instance Eq (TestTable Identity)
165deriving stock instance Ord (TestTable Identity)
166deriving stock instance Show (TestTable Identity)
169testTableSchema :: Rel8.TableSchema (TestTable Rel8.Name)
170testTableSchema =
171 Rel8.TableSchema
172 { name = "test_table"
173 , schema = Nothing
174 , columns = TestTable
175 { testTableColumn1 = "column1"
176 , testTableColumn2 = "column2"
177 }
178 }
181testSelectTestTable :: IO TmpPostgres.DB -> TestTree
182testSelectTestTable = databasePropertyTest "Can SELECT TestTable" \transaction -> do
183 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
185 transaction \connection -> do
186 void do
187 liftIO $ Rel8.insert connection
188 Rel8.Insert
189 { into = testTableSchema
190 , rows = map (Rel8.toInsert . Rel8.lit) rows
191 , onConflict = Rel8.DoNothing
192 , returning = Rel8.NumberOfRowsAffected
193 }
195 selected <- liftIO $ Rel8.select connection do
196 Rel8.each testTableSchema
198 sort selected === sort rows
200 cover 1 "Empty" $ null rows
201 cover 1 "Singleton" $ null $ drop 1 rows
202 cover 1 ">1 row" $ not $ null $ drop 1 rows
205testWhere_ :: IO TmpPostgres.DB -> TestTree
206testWhere_ = databasePropertyTest "WHERE (Rel8.where_)" \transaction -> do
207 rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable
209 magicBool <- forAll Gen.bool
211 let expected = filter (\t -> testTableColumn2 t == magicBool) rows
213 transaction \connection -> do
214 selected <- liftIO $ Rel8.select connection do
215 t <- Rel8.values $ Rel8.lit <$> rows
216 Rel8.where_ $ testTableColumn2 t Rel8.==. Rel8.lit magicBool
217 return t
219 sort selected === sort expected
221 cover 1 "No results" $ null expected
222 cover 1 "Some results" $ not $ null expected
223 cover 1 "All results" $ expected == rows
226testFilter :: IO TmpPostgres.DB -> TestTree
227testFilter = databasePropertyTest "filter" \transaction -> do
228 rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable
230 transaction \connection -> do
231 let expected = filter testTableColumn2 rows
233 selected <- liftIO $ Rel8.select connection
234 $ Rel8.filter testTableColumn2 =<< Rel8.values (Rel8.lit <$> rows)
236 sort selected === sort expected
238 cover 1 "No results" $ null expected
239 cover 1 "Some results" $ not $ null expected
240 cover 1 "All results" $ expected == rows
243testLimit :: IO TmpPostgres.DB -> TestTree
244testLimit = databasePropertyTest "LIMIT (Rel8.limit)" \transaction -> do
245 rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable
247 n <- forAll $ Gen.integral (Range.linear 0 10)
249 transaction \connection -> do
250 selected <- liftIO $ Rel8.select connection do
251 Rel8.limit n $ Rel8.values (Rel8.lit <$> rows)
253 diff (length selected) (<=) (fromIntegral n)
255 for_ selected \row ->
256 diff row elem rows
258 cover 1 "n == 0" $ n == 0
259 cover 1 "n < length rows" $ fromIntegral n < length rows
260 cover 1 "n == length rows" $ fromIntegral n == length rows
261 cover 1 "n >= length rows" $ fromIntegral n >= length rows
264testUnion :: IO TmpPostgres.DB -> TestTree
265testUnion = databasePropertyTest "UNION (Rel8.union)" \transaction -> evalM do
266 left <- forAll $ Gen.list (Range.linear 0 10) genTestTable
267 right <- forAll $ Gen.list (Range.linear 0 10) genTestTable
269 transaction \connection -> do
270 selected <- liftIO $ Rel8.select connection do
271 Rel8.values (Rel8.lit <$> nub left) `Rel8.union` Rel8.values (Rel8.lit <$> nub right)
273 sort selected === sort (nub (left ++ right))
276testDistinct :: IO TmpPostgres.DB -> TestTree
277testDistinct = databasePropertyTest "DISTINCT (Rel8.distinct)" \transaction -> do
278 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
280 transaction \connection -> do
281 selected <- liftIO $ Rel8.select connection $ Rel8.distinct do
282 Rel8.values (Rel8.lit <$> rows)
284 sort selected === nub (sort rows)
286 cover 1 "Empty" $ null rows
287 cover 1 "Duplicates" $ not (null rows) && rows /= nub rows
288 cover 1 "No duplicates" $ not (null rows) && rows == nub rows
291testExists :: IO TmpPostgres.DB -> TestTree
292testExists = databasePropertyTest "EXISTS (Rel8.exists)" \transaction -> do
293 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
295 transaction \connection -> do
296 exists <- liftIO $ Rel8.select connection $ Rel8.exists $ Rel8.values $ Rel8.lit <$> rows
298 case rows of
299 [] -> exists === [False]
300 _ -> exists === [True]
303testOptional :: IO TmpPostgres.DB -> TestTree
304testOptional = databasePropertyTest "Rel8.optional" \transaction -> do
305 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
307 transaction \connection -> do
308 selected <- liftIO $ Rel8.select connection do
309 Rel8.optional $ Rel8.values (Rel8.lit <$> rows)
311 case rows of
312 [] -> selected === [Nothing]
313 _ -> sort selected === fmap Just (sort rows)
316testAnd :: IO TmpPostgres.DB -> TestTree
317testAnd = databasePropertyTest "AND (&&.)" \transaction -> do
318 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool
320 transaction \connection -> do
321 [result] <- liftIO $ Rel8.select connection $ pure $
322 Rel8.lit x Rel8.&&. Rel8.lit y
324 result === (x && y)
327testOr :: IO TmpPostgres.DB -> TestTree
328testOr = databasePropertyTest "OR (||.)" \transaction -> do
329 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool
331 transaction \connection -> do
332 [result] <- liftIO $ Rel8.select connection $ pure $
333 Rel8.lit x Rel8.||. Rel8.lit y
335 result === (x || y)
338testLogicalFixities :: IO TmpPostgres.DB -> TestTree
339testLogicalFixities = databasePropertyTest "Logical operator fixities" \transaction -> do
340 (u, v, w, x) <- forAll $ (,,,) <$> Gen.bool <*> Gen.bool <*> Gen.bool <*> Gen.bool
342 transaction \connection -> do
343 [result] <- liftIO $ Rel8.select connection $ pure $
344 Rel8.lit u Rel8.||. Rel8.lit v Rel8.&&. Rel8.lit w Rel8.==. Rel8.lit x
346 result === (u || v && w == x)
349testNot :: IO TmpPostgres.DB -> TestTree
350testNot = databasePropertyTest "NOT (not_)" \transaction -> do
351 x <- forAll Gen.bool
353 transaction \connection -> do
354 [result] <- liftIO $ Rel8.select connection $ pure $
355 Rel8.not_ $ Rel8.lit x
357 result === not x
360testBool :: IO TmpPostgres.DB -> TestTree
361testBool = databasePropertyTest "ifThenElse_" \transaction -> do
362 (x, y, z) <- forAll $ liftA3 (,,) Gen.bool Gen.bool Gen.bool
364 transaction \connection -> do
365 [result] <- liftIO $ Rel8.select connection $ pure $
366 Rel8.bool (Rel8.lit z) (Rel8.lit y) (Rel8.lit x)
368 result === if x then y else z
371testAp :: IO TmpPostgres.DB -> TestTree
372testAp = databasePropertyTest "Cartesian product (<*>)" \transaction -> do
373 (rows1, rows2) <- forAll $
374 liftA2 (,)
375 (Gen.list (Range.linear 1 10) genTestTable)
376 (Gen.list (Range.linear 1 10) genTestTable)
378 transaction \connection -> do
379 result <- liftIO $ Rel8.select connection $ do
380 liftA2 (,) (Rel8.values (Rel8.lit <$> rows1)) (Rel8.values (Rel8.lit <$> rows2))
382 sort result === sort (liftA2 (,) rows1 rows2)
385testDBType :: IO TmpPostgres.DB -> TestTree
386testDBType getTestDatabase = testGroup "DBType instances"
387 [ dbTypeTest "Bool" Gen.bool
388 , dbTypeTest "ByteString" $ Gen.bytes (Range.linear 0 128)
389 , dbTypeTest "CI Lazy Text" $ mk . Data.Text.Lazy.fromStrict <$> Gen.text (Range.linear 0 10) Gen.unicode
390 , dbTypeTest "CI Text" $ mk <$> Gen.text (Range.linear 0 10) Gen.unicode
391 , dbTypeTest "Day" genDay
392 , dbTypeTest "Double" $ (/10) . fromIntegral @Int @Double <$> Gen.integral (Range.linear (-100) 100)
393 , dbTypeTest "Float" $ (/10) . fromIntegral @Int @Float <$> Gen.integral (Range.linear (-100) 100)
394 , dbTypeTest "Int32" $ Gen.integral @_ @Int32 Range.linearBounded
395 , dbTypeTest "Int64" $ Gen.integral @_ @Int64 Range.linearBounded
396 , dbTypeTest "Lazy ByteString" $ Data.ByteString.Lazy.fromStrict <$> Gen.bytes (Range.linear 0 128)
397 , dbTypeTest "Lazy Text" $ Data.Text.Lazy.fromStrict <$> Gen.text (Range.linear 0 10) Gen.unicode
398 , dbTypeTest "LocalTime" genLocalTime
399 , dbTypeTest "Scientific" $ (/10) . fromIntegral @Int @Scientific <$> Gen.integral (Range.linear (-100) 100)
400 , dbTypeTest "Text" $ Gen.text (Range.linear 0 10) Gen.unicode
401 , dbTypeTest "TimeOfDay" genTimeOfDay
402 , dbTypeTest "UTCTime" $ UTCTime <$> genDay <*> genDiffTime
403 , dbTypeTest "UUID" $ Data.UUID.fromWords <$> genWord32 <*> genWord32 <*> genWord32 <*> genWord32
404 ]
406 where
407 dbTypeTest :: (Eq a, Show a, Rel8.DBType a) => TestName -> Gen a -> TestTree
408 dbTypeTest name generator = testGroup name
409 [ databasePropertyTest name (t (==) generator) getTestDatabase
410 , databasePropertyTest ("Maybe " <> name) (t (==) (Gen.maybe generator)) getTestDatabase
411 ]
413 t :: forall a b. (Show a, Rel8.Sql Rel8.DBType a)
414 => (a -> a -> Bool)
415 -> Gen a
416 -> ((Connection -> TestT IO ()) -> PropertyT IO b)
417 -> PropertyT IO b
418 t eq generator transaction = do
419 x <- forAll generator
421 transaction \connection -> do
422 [res] <- liftIO $ Rel8.select connection $ pure (Rel8.litExpr x)
423 diff res eq x
425 genDay :: Gen Day
426 genDay = do
427 year <- Gen.integral (Range.linear 1970 3000)
428 month <- Gen.integral (Range.linear 1 12)
429 day <- Gen.integral (Range.linear 1 31)
430 Gen.just $ pure $ fromGregorianValid year month day
432 genDiffTime :: Gen DiffTime
433 genDiffTime = secondsToDiffTime <$> Gen.integral (Range.linear 0 86401)
435 genTimeOfDay :: Gen TimeOfDay
436 genTimeOfDay = do
437 hour <- Gen.integral (Range.linear 0 23)
438 minute <- Gen.integral (Range.linear 0 59)
439 sec <- fromIntegral @Int <$> Gen.integral (Range.linear 0 59)
440 Gen.just $ pure $ makeTimeOfDayValid hour minute sec
442 genLocalTime = LocalTime <$> genDay <*> genTimeOfDay
444 genWord32 :: Gen Word32
445 genWord32 = Gen.integral Range.linearBounded
448testDBEq :: IO TmpPostgres.DB -> TestTree
449testDBEq getTestDatabase = testGroup "DBEq instances"
450 [ dbEqTest "Bool" Gen.bool
451 , dbEqTest "Int32" $ Gen.integral @_ @Int32 Range.linearBounded
452 , dbEqTest "Int64" $ Gen.integral @_ @Int64 Range.linearBounded
453 , dbEqTest "Text" $ Gen.text (Range.linear 0 10) Gen.unicode
454 ]
456 where
457 dbEqTest :: (Eq a, Show a, Rel8.DBEq a) => TestName -> Gen a -> TestTree
458 dbEqTest name generator = testGroup name
459 [ databasePropertyTest name (t generator) getTestDatabase
460 , databasePropertyTest ("Maybe " <> name) (t (Gen.maybe generator)) getTestDatabase
461 ]
463 t :: forall a. (Eq a, Show a, Rel8.Sql Rel8.DBEq a)
464 => Gen a
465 -> ((Connection -> TestT IO ()) -> PropertyT IO ())
466 -> PropertyT IO ()
467 t generator transaction = do
468 (x, y) <- forAll (liftA2 (,) generator generator)
470 transaction \connection -> do
471 [res] <- liftIO $ Rel8.select connection $ pure $ Rel8.litExpr x Rel8.==. Rel8.litExpr y
472 res === (x == y)
474 cover 1 "Equal" $ x == y
475 cover 1 "Not Equal" $ x /= y
478testTableEquality :: IO TmpPostgres.DB -> TestTree
479testTableEquality = databasePropertyTest "TestTable equality" \transaction -> do
480 (x, y) <- forAll $ liftA2 (,) genTestTable genTestTable
482 transaction \connection -> do
483 [eq] <- liftIO $ Rel8.select connection do
484 pure $ Rel8.lit x Rel8.==: Rel8.lit y
486 eq === (x == y)
488 cover 1 "Equal" $ x == y
489 cover 1 "Not Equal" $ x /= y
492testFromString :: IO TmpPostgres.DB -> TestTree
493testFromString = databasePropertyTest "FromString" \transaction -> do
494 str <- forAll $ Gen.list (Range.linear 0 10) Gen.unicode
496 transaction \connection -> do
497 [result] <- liftIO $ Rel8.select connection $ pure $ fromString str
498 result === pack str
501testCatMaybeTable :: IO TmpPostgres.DB -> TestTree
502testCatMaybeTable = databasePropertyTest "catMaybeTable" \transaction -> do
503 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
505 transaction \connection -> do
506 selected <- liftIO $ Rel8.select connection do
507 testTable <- Rel8.values $ Rel8.lit <$> rows
508 Rel8.catMaybeTable $ Rel8.bool Rel8.nothingTable (pure testTable) (testTableColumn2 testTable)
510 sort selected === sort (filter testTableColumn2 rows)
513testCatMaybe :: IO TmpPostgres.DB -> TestTree
514testCatMaybe = databasePropertyTest "catMaybe" \transaction -> evalM do
515 rows <- forAll $ Gen.list (Range.linear 0 10) $ Gen.maybe Gen.bool
517 transaction \connection -> do
518 selected <- evalM $ liftIO $ Rel8.select connection do
519 Rel8.catNullable =<< Rel8.values (map Rel8.lit rows)
521 sort selected === sort (catMaybes rows)
524testMaybeTable :: IO TmpPostgres.DB -> TestTree
525testMaybeTable = databasePropertyTest "maybeTable" \transaction -> evalM do
526 (rows, def) <- forAll $ liftA2 (,) (Gen.list (Range.linear 0 10) genTestTable) genTestTable
528 transaction \connection -> do
529 selected <- liftIO $ Rel8.select connection $
530 Rel8.maybeTable (Rel8.lit def) id <$> Rel8.optional (Rel8.values (Rel8.lit <$> rows))
532 case rows of
533 [] -> selected === [def]
534 _ -> sort selected === sort rows
537data TwoTestTables f =
538 TwoTestTables
539 { testTable1 :: TestTable f
540 , testTable2 :: TestTable f
541 }
542 deriving stock Generic
543 deriving anyclass Rel8.Rel8able
546deriving stock instance Eq (TwoTestTables Identity)
547deriving stock instance Ord (TwoTestTables Identity)
548deriving stock instance Show (TwoTestTables Identity)
551testNestedTables :: IO TmpPostgres.DB -> TestTree
552testNestedTables = databasePropertyTest "Nested TestTables" \transaction -> evalM do
553 rows <- forAll do
554 Gen.list (Range.linear 0 10) $
555 liftA2 TwoTestTables genTestTable genTestTable
557 transaction \connection -> do
558 selected <- liftIO $ Rel8.select connection do
559 Rel8.values (Rel8.lit <$> rows)
561 sort selected === sort rows
564testMaybeTableApplicative :: IO TmpPostgres.DB -> TestTree
565testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction -> evalM do
566 rows1 <- genRows
567 rows2 <- genRows
569 transaction \connection -> do
570 selected <- liftIO $ Rel8.select connection do
571 as <- Rel8.optional (Rel8.values (Rel8.lit <$> rows1))
572 bs <- Rel8.optional (Rel8.values (Rel8.lit <$> rows2))
573 pure $ liftA2 (,) as bs
575 case (rows1, rows2) of
576 ([], []) -> selected === [Nothing]
577 ([], bs) -> selected === (Nothing <$ bs)
578 (as, []) -> selected === (Nothing <$ as)
579 (as, bs) -> sort selected === sort (Just <$> liftA2 (,) as bs)
580 where
581 genRows :: PropertyT IO [TestTable Identity]
582 genRows = forAll do
583 Gen.list (Range.linear 0 10) $ liftA2 TestTable (Gen.text (Range.linear 0 10) Gen.unicode) (pure True)
585rollingBack
586 :: (MonadBaseControl IO m, MonadIO m)
587 => Connection -> m a -> m a
588rollingBack connection =
589 bracket_
590 (liftIO (run (sql "BEGIN") connection))
591 (liftIO (run (sql "ROLLBACK") connection))
594genTestTable :: Gen (TestTable Identity)
595genTestTable = do
596 testTableColumn1 <- Gen.text (Range.linear 0 5) Gen.alphaNum
597 testTableColumn2 <- Gen.bool
598 return TestTable{..}
601testUpdate :: IO TmpPostgres.DB -> TestTree
602testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do
603 rows <- forAll $ Gen.map (Range.linear 0 5) $ liftA2 (,) genTestTable genTestTable
605 transaction \connection -> do
606 void $ liftIO $ Rel8.insert connection
607 Rel8.Insert
608 { into = testTableSchema
609 , rows = map (Rel8.toInsert . Rel8.lit) $ Map.keys rows
610 , onConflict = Rel8.DoNothing
611 , returning = Rel8.NumberOfRowsAffected
612 }
614 void $ liftIO $ Rel8.update connection
615 Rel8.Update
616 { target = testTableSchema
617 , set = \r ->
618 let updates = map (bimap Rel8.lit Rel8.lit) $ Map.toList rows
619 in
620 foldl
621 ( \e (x, y) ->
622 Rel8.bool
623 e
624 y
625 ( testTableColumn1 r Rel8.==. testTableColumn1 x Rel8.&&.
626 testTableColumn2 r Rel8.==. testTableColumn2 x
627 )
628 )
629 r
630 updates
631 , updateWhere = \_ -> Rel8.lit True
632 , returning = Rel8.NumberOfRowsAffected
633 }
635 selected <- liftIO $ Rel8.select connection do
636 Rel8.each testTableSchema
638 sort selected === sort (Map.elems rows)
640 cover 1 "Empty" $ null rows
641 cover 1 "Singleton" $ null $ drop 1 $ Map.keys rows
642 cover 1 ">1 row" $ not $ null $ drop 1 $ Map.keys rows
645testDelete :: IO TmpPostgres.DB -> TestTree
646testDelete = databasePropertyTest "Can DELETE TestTable" \transaction -> do
647 rows <- forAll $ Gen.list (Range.linear 0 5) genTestTable
649 transaction \connection -> do
650 void $ liftIO $ Rel8.insert connection
651 Rel8.Insert
652 { into = testTableSchema
653 , rows = map (Rel8.toInsert . Rel8.lit) rows
654 , onConflict = Rel8.DoNothing
655 , returning = Rel8.NumberOfRowsAffected
656 }
658 deleted <-
659 liftIO $ Rel8.delete connection
660 Rel8.Delete
661 { from = testTableSchema
662 , deleteWhere = testTableColumn2
663 , returning = Rel8.Projection id
664 }
666 selected <- liftIO $ Rel8.select connection do
667 Rel8.each testTableSchema
669 sort (deleted <> selected) === sort rows
672newtype HKNestedPair f = HKNestedPair { pairOne :: (TestTable f, TestTable f) }
673 deriving stock Generic
674 deriving anyclass Rel8.Rel8able
676deriving stock instance Eq (HKNestedPair Identity)
677deriving stock instance Ord (HKNestedPair Identity)
678deriving stock instance Show (HKNestedPair Identity)
681testSelectNestedPairs :: IO TmpPostgres.DB -> TestTree
682testSelectNestedPairs = databasePropertyTest "Can SELECT nested pairs" \transaction -> do
683 rows <- forAll $ Gen.list (Range.linear 0 10) $ HKNestedPair <$> liftA2 (,) genTestTable genTestTable
685 transaction \connection -> do
686 selected <- liftIO $ Rel8.select connection do
687 Rel8.values $ map Rel8.lit rows
689 sort selected === sort rows
692testSelectArray :: IO TmpPostgres.DB -> TestTree
693testSelectArray = databasePropertyTest "Can SELECT Arrays (with aggregation)" \transaction -> do
694 rows <- forAll $ Gen.list (Range.linear 1 10) Gen.bool
696 transaction \connection -> do
697 selected <- liftIO $ Rel8.select connection $ Rel8.aggregate do
698 Rel8.listAgg <$> Rel8.values (map Rel8.lit rows)
700 selected === [foldMap pure rows]
703data NestedMaybeTable f = NestedMaybeTable
704 { nmt1 :: Rel8.Column f Bool
705 , nmt2 :: Rel8.HMaybe f (TestTable f)
706 }
707 deriving stock Generic
708 deriving anyclass Rel8.Rel8able
711deriving stock instance Eq (NestedMaybeTable Identity)
712deriving stock instance Ord (NestedMaybeTable Identity)
713deriving stock instance Show (NestedMaybeTable Identity)
716testNestedMaybeTable :: IO TmpPostgres.DB -> TestTree
717testNestedMaybeTable = databasePropertyTest "Can nest MaybeTable within other tables" \transaction -> do
718 let example = NestedMaybeTable { nmt1 = True, nmt2 = Just (TestTable "Hi" True) }
720 transaction \connection -> do
721 selected <- liftIO $ Rel8.select connection do
722 x <- Rel8.values [Rel8.lit example]
723 pure $ Rel8.maybeTable (Rel8.lit False) (\_ -> Rel8.lit True) (nmt2 x)
725 selected === [True]