git.iko.soy/rel8
on 7aa4f92 help sign in
rel8/tests/Main.hs
786 lines 26 kB history raw
1{-# language BlockArguments #-}
2{-# language BlockArguments #-}
3{-# language DataKinds #-}
4{-# language DeriveAnyClass #-}
5{-# language DeriveGeneric #-}
6{-# language DerivingStrategies #-}
7{-# language DisambiguateRecordFields #-}
8{-# language FlexibleContexts #-}
9{-# language FlexibleInstances #-}
10{-# language GADTs #-}
11{-# language NamedFieldPuns #-}
12{-# language OverloadedStrings #-}
13{-# language RecordWildCards #-}
14{-# language ScopedTypeVariables #-}
15{-# language StandaloneDeriving #-}
16{-# language TypeApplications #-}
18{-# options_ghc -fno-warn-redundant-constraints #-}
20module Main
21 ( main
22 )
23where
25-- base
26import Control.Applicative ( liftA2, liftA3 )
27import Control.Monad (void)
28import Control.Monad.IO.Class ( MonadIO, liftIO )
29import Data.Bifunctor ( bimap )
30import Data.Foldable ( for_ )
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.Kind.Nullability as Rel8
67import qualified Rel8.Query.Aggregate as Rel8
68import qualified Rel8.Query.Distinct as Rel8
69import qualified Rel8.Query.Each as Rel8
70import qualified Rel8.Query.Exists as Rel8
71import qualified Rel8.Query.Filter as Rel8
72import qualified Rel8.Query.Limit as Rel8
73import qualified Rel8.Query.Maybe as Rel8
74import qualified Rel8.Query.Null as Rel8
75import qualified Rel8.Query.Set as Rel8
76import qualified Rel8.Query.Values as Rel8
77import qualified Rel8.Schema.Column as Rel8
78import qualified Rel8.Schema.Context as Rel8
79import qualified Rel8.Schema.Generic as Rel8
80import qualified Rel8.Schema.Table as Rel8
81import qualified Rel8.Schema.Value as Rel8
82import qualified Rel8.Statement.Delete as Rel8
83import qualified Rel8.Statement.Insert as Rel8
84import qualified Rel8.Statement.Returning as Rel8
85import qualified Rel8.Statement.Select as Rel8
86import qualified Rel8.Statement.Update as Rel8
87import qualified Rel8.Table.Aggregate as Rel8
88import qualified Rel8.Table.Bool as Rel8
89import qualified Rel8.Table.Eq as Rel8
90import qualified Rel8.Table.Insert as Rel8
91import qualified Rel8.Table.Maybe as Rel8
92import qualified Rel8.Table.Serialize 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 Rel8.Result)
195deriving stock instance Ord (TestTable Rel8.Result)
196deriving stock instance Show (TestTable Rel8.Result)
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 testing 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 <- testing 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 <- testing 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 <- testing 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 <- testing 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 <- testing 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 <- testing 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 <- testing 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 <- testing 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] <- testing 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] <- testing 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] <- testing 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] <- testing 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] <- testing 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 <- testing 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.NonNullable, a) ~ Rel8.ToValue a
440 , Rel8.Serializable (Rel8.Expr 'Rel8.NonNullable a) a
441 , Rel8.Serializable (Rel8.Expr 'Rel8.Nullable a) (Maybe a)
442 )
443 => TestName
444 -> Gen a
445 -> TestTree
446 dbTypeTest name generator = testGroup name
447 [ databasePropertyTest name (t (==) generator) getTestDatabase
448 , databasePropertyTest ("Maybe " <> name) (t (==) (Gen.maybe generator)) getTestDatabase
449 ]
451 t :: forall a b nullability value.
452 ( Show a
453 , '(nullability, value) ~ Rel8.ToValue a
454 , Rel8.Serializable (Rel8.Expr nullability value) a
455 )
456 => (a -> a -> Bool)
457 -> Gen a
458 -> ((Connection -> TestT IO ()) -> PropertyT IO b)
459 -> PropertyT IO b
460 t eq generator transaction = do
461 x <- forAll generator
463 transaction \connection -> do
464 [res] <- testing Rel8.select connection $ pure (Rel8.lit x :: Rel8.Expr nullability value)
465 diff res eq x
467 genDay :: Gen Day
468 genDay = do
469 year <- Gen.integral (Range.linear 1970 3000)
470 month <- Gen.integral (Range.linear 1 12)
471 day <- Gen.integral (Range.linear 1 31)
472 Gen.just $ pure $ fromGregorianValid year month day
474 genDiffTime :: Gen DiffTime
475 genDiffTime = secondsToDiffTime <$> Gen.integral (Range.linear 0 86401)
477 genTimeOfDay :: Gen TimeOfDay
478 genTimeOfDay = do
479 hour <- Gen.integral (Range.linear 0 23)
480 minute <- Gen.integral (Range.linear 0 59)
481 sec <- fromIntegral @Int <$> Gen.integral (Range.linear 0 59)
482 Gen.just $ pure $ makeTimeOfDayValid hour minute sec
484 genLocalTime = LocalTime <$> genDay <*> genTimeOfDay
486 genWord32 :: Gen Word32
487 genWord32 = Gen.integral Range.linearBounded
490testDBEq :: IO TmpPostgres.DB -> TestTree
491testDBEq getTestDatabase = testGroup "DBEq instances"
492 [ dbEqTest "Bool" Gen.bool
493 , dbEqTest "Int32" $ Gen.integral @_ @Int32 Range.linearBounded
494 , dbEqTest "Int64" $ Gen.integral @_ @Int64 Range.linearBounded
495 , dbEqTest "Text" $ Gen.text (Range.linear 0 10) Gen.unicode
496 ]
498 where
499 dbEqTest ::
500 ( Eq a, Show a, Rel8.DBEq a
501 , ' ('Rel8.NonNullable, a) ~ Rel8.ToValue a
502 , Rel8.Serializable (Rel8.Expr 'Rel8.NonNullable a) a
503 , Rel8.Serializable (Rel8.Expr 'Rel8.Nullable a) (Maybe a)
504 )
505 => TestName
506 -> Gen a
507 -> TestTree
508 dbEqTest name generator = testGroup name
509 [ databasePropertyTest name (t generator) getTestDatabase
510 , databasePropertyTest ("Maybe " <> name) (t (Gen.maybe generator)) getTestDatabase
511 ]
513 t :: forall a nullability value.
514 ( Eq a
515 , Show a
516 , '(nullability, value) ~ Rel8.ToValue a
517 , Rel8.Serializable (Rel8.Expr nullability value) a
518 , Rel8.KnownNullability nullability
519 , Rel8.DBEq value
520 )
521 => Gen a
522 -> ((Connection -> TestT IO ()) -> PropertyT IO ())
523 -> PropertyT IO ()
524 t generator transaction = do
525 (x, y) <- forAll (liftA2 (,) generator generator)
527 transaction \connection -> do
528 [res] <- testing Rel8.select connection $ pure $ Rel8.lit @(Rel8.Expr nullability value) x Rel8.==. Rel8.lit y
529 res === (x == y)
531 cover 1 "Equal" $ x == y
532 cover 1 "Not Equal" $ x /= y
535testTableEquality :: IO TmpPostgres.DB -> TestTree
536testTableEquality = databasePropertyTest "TestTable equality" \transaction -> do
537 (x, y) <- forAll $ liftA2 (,) genTestTable genTestTable
539 transaction \connection -> do
540 [eq] <- testing Rel8.select connection do
541 pure $ Rel8.lit x Rel8.==: Rel8.lit y
543 eq === (x == y)
545 cover 1 "Equal" $ x == y
546 cover 1 "Not Equal" $ x /= y
549testFromString :: IO TmpPostgres.DB -> TestTree
550testFromString = databasePropertyTest "FromString" \transaction -> do
551 str <- forAll $ Gen.list (Range.linear 0 10) Gen.unicode
553 transaction \connection -> do
554 [result] <- testing Rel8.select connection $ pure $ fromString str
555 result === pack str
558testCatMaybeTable :: IO TmpPostgres.DB -> TestTree
559testCatMaybeTable = databasePropertyTest "catMaybeTable" \transaction -> do
560 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
562 transaction \connection -> do
563 selected <- testing Rel8.select connection do
564 testTable <- Rel8.values $ Rel8.lit <$> rows
565 Rel8.catMaybeTable $ Rel8.bool Rel8.nothingTable (pure testTable) (testTableColumn2 testTable)
567 sort selected === sort (filter testTableColumn2 rows)
570testCatMaybe :: IO TmpPostgres.DB -> TestTree
571testCatMaybe = databasePropertyTest "catMaybe" \transaction -> evalM do
572 rows <- forAll $ Gen.list (Range.linear 0 10) $ Gen.maybe Gen.bool
574 transaction \connection -> do
575 selected <- evalM $ testing Rel8.select connection do
576 Rel8.catNullable =<< Rel8.values (map Rel8.lit rows)
578 sort selected === sort (catMaybes rows)
581testMaybeTable :: IO TmpPostgres.DB -> TestTree
582testMaybeTable = databasePropertyTest "maybeTable" \transaction -> evalM do
583 (rows, def) <- forAll $ liftA2 (,) (Gen.list (Range.linear 0 10) genTestTable) genTestTable
585 transaction \connection -> do
586 selected <- testing Rel8.select connection $
587 Rel8.maybeTable (Rel8.lit def) id <$> Rel8.optional (Rel8.values (Rel8.lit <$> rows))
589 case rows of
590 [] -> selected === [def]
591 _ -> sort selected === sort rows
594data TwoTestTables f =
595 TwoTestTables
596 { testTable1 :: TestTable f
597 , testTable2 :: TestTable f
598 }
599 deriving stock Generic
600 deriving anyclass Rel8.Rel8able
603deriving stock instance Eq (TwoTestTables Rel8.Result)
604deriving stock instance Ord (TwoTestTables Rel8.Result)
605deriving stock instance Show (TwoTestTables Rel8.Result)
608testNestedTables :: IO TmpPostgres.DB -> TestTree
609testNestedTables = databasePropertyTest "Nested TestTables" \transaction -> evalM do
610 rows <- forAll do
611 Gen.list (Range.linear 0 10) $
612 liftA2 TwoTestTables genTestTable genTestTable
614 transaction \connection -> do
615 selected <- testing Rel8.select connection do
616 Rel8.values (Rel8.lit <$> rows)
618 sort selected === sort rows
621testMaybeTableApplicative :: IO TmpPostgres.DB -> TestTree
622testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction -> evalM do
623 rows1 <- genRows
624 rows2 <- genRows
626 transaction \connection -> do
627 selected <- testing Rel8.select connection do
628 as <- Rel8.optional (Rel8.values (Rel8.lit <$> rows1))
629 bs <- Rel8.optional (Rel8.values (Rel8.lit <$> rows2))
630 pure $ liftA2 (,) as bs
632 case (rows1, rows2) of
633 ([], []) -> selected === [Nothing]
634 ([], bs) -> selected === (Nothing <$ bs)
635 (as, []) -> selected === (Nothing <$ as)
636 (as, bs) -> sort selected === sort (Just <$> liftA2 (,) as bs)
637 where
638 genRows :: PropertyT IO [TestTable Rel8.Result]
639 genRows = forAll do
640 Gen.list (Range.linear 0 10) $ liftA2 TestTable (Gen.text (Range.linear 0 10) Gen.unicode) (pure True)
642rollingBack
643 :: (MonadBaseControl IO m, MonadIO m)
644 => Connection -> m a -> m a
645rollingBack connection =
646 bracket_
647 (liftIO (run (sql "BEGIN") connection))
648 (liftIO (run (sql "ROLLBACK") connection))
651genTestTable :: Gen (TestTable Rel8.Result)
652genTestTable = do
653 testTableColumn1 <- Gen.text (Range.linear 0 5) Gen.alphaNum
654 testTableColumn2 <- Gen.bool
655 return TestTable{..}
658testUpdate :: IO TmpPostgres.DB -> TestTree
659testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do
660 rows <- forAll $ Gen.map (Range.linear 0 5) $ liftA2 (,) genTestTable genTestTable
662 transaction \connection -> do
663 void $ testing Rel8.insert connection
664 Rel8.Insert
665 { into = testTableSchema
666 , rows = map (Rel8.toInsert . Rel8.lit) $ Map.keys rows
667 , onConflict = Rel8.DoNothing
668 , returning = Rel8.NumberOfRowsAffected
669 }
671 void $ testing Rel8.update connection
672 Rel8.Update
673 { target = testTableSchema
674 , set = \r ->
675 let updates = map (bimap Rel8.lit Rel8.lit) $ Map.toList rows
676 in
677 foldl
678 ( \e (x, y) ->
679 Rel8.bool
680 e
681 y
682 ( testTableColumn1 r Rel8.==. testTableColumn1 x Rel8.&&.
683 testTableColumn2 r Rel8.==. testTableColumn2 x
684 )
685 )
686 r
687 updates
688 , updateWhere = \_ -> Rel8.lit True
689 , returning = Rel8.NumberOfRowsAffected
690 }
692 selected <- testing Rel8.select connection do
693 Rel8.each testTableSchema
695 sort selected === sort (Map.elems rows)
697 cover 1 "Empty" $ null rows
698 cover 1 "Singleton" $ null $ drop 1 $ Map.keys rows
699 cover 1 ">1 row" $ not $ null $ drop 1 $ Map.keys rows
702testDelete :: IO TmpPostgres.DB -> TestTree
703testDelete = databasePropertyTest "Can DELETE TestTable" \transaction -> do
704 rows <- forAll $ Gen.list (Range.linear 0 5) genTestTable
706 transaction \connection -> do
707 void $ testing Rel8.insert connection
708 Rel8.Insert
709 { into = testTableSchema
710 , rows = map (Rel8.toInsert . Rel8.lit) rows
711 , onConflict = Rel8.DoNothing
712 , returning = Rel8.NumberOfRowsAffected
713 }
715 deleted <-
716 testing Rel8.delete connection
717 Rel8.Delete
718 { from = testTableSchema
719 , deleteWhere = testTableColumn2
720 , returning = Rel8.Projection id
721 }
723 selected <- testing Rel8.select connection do
724 Rel8.each testTableSchema
726 sort (deleted <> selected) === sort rows
729newtype HKNestedPair f = HKNestedPair { pairOne :: (TestTable f, TestTable f) }
730 deriving stock Generic
731 deriving anyclass Rel8.Rel8able
733deriving stock instance Eq (HKNestedPair Rel8.Result)
734deriving stock instance Ord (HKNestedPair Rel8.Result)
735deriving stock instance Show (HKNestedPair Rel8.Result)
738testSelectNestedPairs :: IO TmpPostgres.DB -> TestTree
739testSelectNestedPairs = databasePropertyTest "Can SELECT nested pairs" \transaction -> do
740 rows <- forAll $ Gen.list (Range.linear 0 10) $ HKNestedPair <$> liftA2 (,) genTestTable genTestTable
742 transaction \connection -> do
743 selected <- testing Rel8.select connection do
744 Rel8.values $ map Rel8.lit rows
746 sort selected === sort rows
749testSelectArray :: IO TmpPostgres.DB -> TestTree
750testSelectArray = databasePropertyTest "Can SELECT Arrays (with aggregation)" \transaction -> do
751 rows <- forAll $ Gen.list (Range.linear 1 10) Gen.bool
753 transaction \connection -> do
754 selected <- testing Rel8.select connection $ Rel8.aggregate do
755 Rel8.listAgg <$> Rel8.values (map Rel8.lit rows)
757 selected === [foldMap pure rows]
760data NestedMaybeTable f = NestedMaybeTable
761 { nmt1 :: Rel8.Column f Bool
762 , nmt2 :: Rel8.HMaybe f (TestTable f)
763 }
764 deriving stock Generic
765 deriving anyclass Rel8.Rel8able
768deriving stock instance Eq (NestedMaybeTable Rel8.Result)
769deriving stock instance Ord (NestedMaybeTable Rel8.Result)
770deriving stock instance Show (NestedMaybeTable Rel8.Result)
773testNestedMaybeTable :: IO TmpPostgres.DB -> TestTree
774testNestedMaybeTable = databasePropertyTest "Can nest MaybeTable within other tables" \transaction -> do
775 let example = NestedMaybeTable { nmt1 = True, nmt2 = Just (TestTable "Hi" True) }
777 transaction \connection -> do
778 selected <- testing Rel8.select connection do
779 x <- Rel8.values [Rel8.lit example]
780 pure $ Rel8.maybeTable (Rel8.lit False) (\_ -> Rel8.lit True) (nmt2 x)
782 selected === [True]
785testing :: MonadIO m => (a -> Connection -> IO b) -> Connection -> a -> m b
786testing f connection a = liftIO $ f a connection