git.iko.soy/rel8
on da76712 help sign in
rel8/tests/Main.hs
889 lines 28 kB history raw
1{-# language BangPatterns #-}
2{-# language BlockArguments #-}
3{-# language DeriveAnyClass #-}
4{-# language DeriveGeneric #-}
5{-# language DerivingStrategies #-}
6{-# language FlexibleContexts #-}
7{-# language FlexibleInstances #-}
8{-# language MonoLocalBinds #-}
9{-# language NamedFieldPuns #-}
10{-# language OverloadedStrings #-}
11{-# language RecordWildCards #-}
12{-# language ScopedTypeVariables #-}
13{-# language StandaloneDeriving #-}
14{-# language TypeApplications #-}
16module Main
17 ( main
18 )
19where
21-- base
22import Control.Applicative ( empty, liftA2, liftA3 )
23import Control.Exception ( bracket, throwIO )
24import Control.Monad ( (>=>), void )
25import Data.Bifunctor ( bimap )
26import Data.Foldable ( for_ )
27import Data.Int ( Int32, Int64 )
28import Data.List ( nub, sort )
29import Data.Maybe ( catMaybes )
30import Data.String ( fromString )
31import Data.Word (Word32)
32import GHC.Generics ( Generic )
34-- bytestring
35import qualified Data.ByteString.Lazy
37-- case-insensitive
38import Data.CaseInsensitive ( mk )
40-- containers
41import Data.Containers.ListUtils ( nubOrdOn )
42import qualified Data.Map.Strict as Map
44-- hasql
45import Hasql.Connection ( Connection, acquire, release )
46import Hasql.Session ( sql, run )
48-- hasql-transaction
49import Hasql.Transaction ( Transaction, condemn, statement )
50import qualified Hasql.Transaction.Sessions as Hasql
52-- hedgehog
53import Hedgehog ( property, (===), forAll, cover, diff, evalM, PropertyT, TestT, test, Gen )
54import qualified Hedgehog.Gen as Gen
55import qualified Hedgehog.Range as Range
57-- mmorph
58import Control.Monad.Morph ( hoist )
60-- rel8
61import Rel8 ( Result )
62import qualified Rel8
64-- scientific
65import Data.Scientific ( Scientific )
67-- tasty
68import Test.Tasty
70-- tasty-hedgehog
71import Test.Tasty.Hedgehog ( testProperty )
73-- text
74import Data.Text ( Text, pack, unpack )
75import qualified Data.Text.Lazy
76import Data.Text.Encoding ( decodeUtf8 )
78-- time
79import Data.Time
81-- transformers
82import Control.Monad.Trans.Class ( lift )
84-- tmp-postgres
85import qualified Database.Postgres.Temp as TmpPostgres
87-- uuid
88import qualified Data.UUID
91main :: IO ()
92main = defaultMain tests
95tests :: TestTree
96tests =
97 withResource startTestDatabase stopTestDatabase \getTestDatabase ->
98 testGroup "rel8"
99 [ testSelectTestTable getTestDatabase
100 , testWhere_ getTestDatabase
101 , testFilter getTestDatabase
102 , testLimit getTestDatabase
103 , testUnion getTestDatabase
104 , testDistinct getTestDatabase
105 , testExists getTestDatabase
106 , testOptional getTestDatabase
107 , testAnd getTestDatabase
108 , testOr getTestDatabase
109 , testNot getTestDatabase
110 , testBool getTestDatabase
111 , testAp getTestDatabase
112 , testDBType getTestDatabase
113 , testDBEq getTestDatabase
114 , testTableEquality getTestDatabase
115 , testFromString getTestDatabase
116 , testCatMaybeTable getTestDatabase
117 , testCatMaybe getTestDatabase
118 , testMaybeTable getTestDatabase
119 , testAggregateMaybeTable getTestDatabase
120 , testNestedTables getTestDatabase
121 , testMaybeTableApplicative getTestDatabase
122 , testLogicalFixities getTestDatabase
123 , testUpdate getTestDatabase
124 , testDelete getTestDatabase
125 , testUpsert getTestDatabase
126 , testSelectNestedPairs getTestDatabase
127 , testSelectArray getTestDatabase
128 , testNestedMaybeTable getTestDatabase
129 , testEvaluate getTestDatabase
130 ]
132 where
134 startTestDatabase = do
135 db <- TmpPostgres.start >>= either throwIO return
137 bracket (either (error . show) return =<< acquire (TmpPostgres.toConnectionString db)) release \conn -> void do
138 flip run conn do
139 sql "CREATE EXTENSION citext"
140 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 )"
142 sql "CREATE SEQUENCE test_seq"
144 return db
146 stopTestDatabase = TmpPostgres.stop
149connect :: TmpPostgres.DB -> IO Connection
150connect = acquire . TmpPostgres.toConnectionString >=> either (maybe empty (fail . unpack . decodeUtf8)) pure
153databasePropertyTest
154 :: TestName
155 -> ((TestT Transaction () -> PropertyT IO ()) -> PropertyT IO ())
156 -> IO TmpPostgres.DB -> TestTree
157databasePropertyTest testName f getTestDatabase =
158 withResource (connect =<< getTestDatabase) release $ \c ->
159 testProperty testName $ property do
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
166data TestTable f = TestTable
167 { testTableColumn1 :: Rel8.Column f Text
168 , testTableColumn2 :: Rel8.Column f Bool
169 }
170 deriving stock Generic
171 deriving anyclass Rel8.Rel8able
174deriving stock instance Eq (TestTable Result)
175deriving stock instance Ord (TestTable Result)
176deriving stock instance Show (TestTable Result)
179testTableSchema :: Rel8.TableSchema (TestTable Rel8.Name)
180testTableSchema =
181 Rel8.TableSchema
182 { name = "test_table"
183 , schema = Nothing
184 , columns = TestTable
185 { testTableColumn1 = "column1"
186 , testTableColumn2 = "column2"
187 }
188 }
191testSelectTestTable :: IO TmpPostgres.DB -> TestTree
192testSelectTestTable = databasePropertyTest "Can SELECT TestTable" \transaction -> do
193 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
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 }
204 statement () $ Rel8.select do
205 Rel8.each testTableSchema
207 sort selected === sort rows
209 cover 1 "Empty" $ null rows
210 cover 1 "Singleton" $ null $ drop 1 rows
211 cover 1 ">1 row" $ not $ null $ drop 1 rows
214testWhere_ :: IO TmpPostgres.DB -> TestTree
215testWhere_ = databasePropertyTest "WHERE (Rel8.where_)" \transaction -> do
216 rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable
218 magicBool <- forAll Gen.bool
220 let expected = filter (\t -> testTableColumn2 t == magicBool) rows
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
229 sort selected === sort expected
231 cover 1 "No results" $ null expected
232 cover 1 "Some results" $ not $ null expected
233 cover 1 "All results" $ expected == rows
236testFilter :: IO TmpPostgres.DB -> TestTree
237testFilter = databasePropertyTest "filter" \transaction -> do
238 rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable
240 transaction do
241 let expected = filter testTableColumn2 rows
243 selected <- lift do
244 statement () $ Rel8.select do
245 Rel8.filter testTableColumn2 =<< Rel8.values (Rel8.lit <$> rows)
247 sort selected === sort expected
249 cover 1 "No results" $ null expected
250 cover 1 "Some results" $ not $ null expected
251 cover 1 "All results" $ expected == rows
254testLimit :: IO TmpPostgres.DB -> TestTree
255testLimit = databasePropertyTest "LIMIT (Rel8.limit)" \transaction -> do
256 rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable
258 n <- forAll $ Gen.integral (Range.linear 0 10)
260 transaction do
261 selected <- lift do
262 statement () $ Rel8.select do
263 Rel8.limit n $ Rel8.values (Rel8.lit <$> rows)
265 diff (length selected) (<=) (fromIntegral n)
267 for_ selected \row ->
268 diff row elem rows
270 cover 1 "n == 0" $ n == 0
271 cover 1 "n < length rows" $ fromIntegral n < length rows
272 cover 1 "n == length rows" $ fromIntegral n == length rows
273 cover 1 "n >= length rows" $ fromIntegral n >= length rows
276testUnion :: IO TmpPostgres.DB -> TestTree
277testUnion = databasePropertyTest "UNION (Rel8.union)" \transaction -> evalM do
278 left <- forAll $ Gen.list (Range.linear 0 10) genTestTable
279 right <- forAll $ Gen.list (Range.linear 0 10) genTestTable
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)
286 sort selected === sort (nub (left ++ right))
289testDistinct :: IO TmpPostgres.DB -> TestTree
290testDistinct = databasePropertyTest "DISTINCT (Rel8.distinct)" \transaction -> do
291 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
293 transaction do
294 selected <- lift do
295 statement () $ Rel8.select do
296 Rel8.distinct do
297 Rel8.values (Rel8.lit <$> rows)
299 sort selected === nub (sort rows)
301 cover 1 "Empty" $ null rows
302 cover 1 "Duplicates" $ not (null rows) && rows /= nub rows
303 cover 1 "No duplicates" $ not (null rows) && rows == nub rows
306testExists :: IO TmpPostgres.DB -> TestTree
307testExists = databasePropertyTest "EXISTS (Rel8.exists)" \transaction -> do
308 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
310 transaction do
311 exists <- lift do
312 statement () $ Rel8.select do
313 Rel8.exists $ Rel8.values $ Rel8.lit <$> rows
315 case rows of
316 [] -> exists === [False]
317 _ -> exists === [True]
320testOptional :: IO TmpPostgres.DB -> TestTree
321testOptional = databasePropertyTest "Rel8.optional" \transaction -> do
322 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
324 transaction do
325 selected <- lift do
326 statement () $ Rel8.select do
327 Rel8.optional $ Rel8.values (Rel8.lit <$> rows)
329 case rows of
330 [] -> selected === [Nothing]
331 _ -> sort selected === fmap Just (sort rows)
334testAnd :: IO TmpPostgres.DB -> TestTree
335testAnd = databasePropertyTest "AND (&&.)" \transaction -> do
336 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool
338 transaction do
339 [result] <- lift do
340 statement () $ Rel8.select do
341 pure $ Rel8.lit x Rel8.&&. Rel8.lit y
343 result === (x && y)
346testOr :: IO TmpPostgres.DB -> TestTree
347testOr = databasePropertyTest "OR (||.)" \transaction -> do
348 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool
350 transaction do
351 [result] <- lift do
352 statement () $ Rel8.select $ pure $
353 Rel8.lit x Rel8.||. Rel8.lit y
355 result === (x || y)
358testLogicalFixities :: IO TmpPostgres.DB -> TestTree
359testLogicalFixities = databasePropertyTest "Logical operator fixities" \transaction -> do
360 (u, v, w, x) <- forAll $ (,,,) <$> Gen.bool <*> Gen.bool <*> Gen.bool <*> Gen.bool
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
367 result === (u || v && w == x)
370testNot :: IO TmpPostgres.DB -> TestTree
371testNot = databasePropertyTest "NOT (not_)" \transaction -> do
372 x <- forAll Gen.bool
374 transaction do
375 [result] <- lift do
376 statement () $ Rel8.select do
377 pure $ Rel8.not_ $ Rel8.lit x
379 result === not x
382testBool :: IO TmpPostgres.DB -> TestTree
383testBool = databasePropertyTest "ifThenElse_" \transaction -> do
384 (x, y, z) <- forAll $ liftA3 (,,) Gen.bool Gen.bool Gen.bool
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)
391 result === if x then y else z
394testAp :: IO TmpPostgres.DB -> TestTree
395testAp = databasePropertyTest "Cartesian product (<*>)" \transaction -> do
396 (rows1, rows2) <- forAll $
397 liftA2 (,)
398 (Gen.list (Range.linear 1 10) genTestTable)
399 (Gen.list (Range.linear 1 10) genTestTable)
401 transaction do
402 result <- lift do
403 statement () $ Rel8.select do
404 liftA2 (,) (Rel8.values (Rel8.lit <$> rows1)) (Rel8.values (Rel8.lit <$> rows2))
406 sort result === sort (liftA2 (,) rows1 rows2)
409testDBType :: IO TmpPostgres.DB -> TestTree
410testDBType getTestDatabase = testGroup "DBType instances"
411 [ dbTypeTest "Bool" Gen.bool
412 , dbTypeTest "ByteString" $ Gen.bytes (Range.linear 0 128)
413 , dbTypeTest "CI Lazy Text" $ mk . Data.Text.Lazy.fromStrict <$> Gen.text (Range.linear 0 10) Gen.unicode
414 , dbTypeTest "CI Text" $ mk <$> Gen.text (Range.linear 0 10) Gen.unicode
415 , dbTypeTest "Day" genDay
416 , dbTypeTest "Double" $ (/10) . fromIntegral @Int @Double <$> Gen.integral (Range.linear (-100) 100)
417 , dbTypeTest "Float" $ (/10) . fromIntegral @Int @Float <$> Gen.integral (Range.linear (-100) 100)
418 , dbTypeTest "Int32" $ Gen.integral @_ @Int32 Range.linearBounded
419 , dbTypeTest "Int64" $ Gen.integral @_ @Int64 Range.linearBounded
420 , dbTypeTest "Lazy ByteString" $ Data.ByteString.Lazy.fromStrict <$> Gen.bytes (Range.linear 0 128)
421 , dbTypeTest "Lazy Text" $ Data.Text.Lazy.fromStrict <$> Gen.text (Range.linear 0 10) Gen.unicode
422 , dbTypeTest "LocalTime" genLocalTime
423 , dbTypeTest "Scientific" $ (/10) . fromIntegral @Int @Scientific <$> Gen.integral (Range.linear (-100) 100)
424 , dbTypeTest "Text" $ Gen.text (Range.linear 0 10) Gen.unicode
425 , dbTypeTest "TimeOfDay" genTimeOfDay
426 , dbTypeTest "UTCTime" $ UTCTime <$> genDay <*> genDiffTime
427 , dbTypeTest "UUID" $ Data.UUID.fromWords <$> genWord32 <*> genWord32 <*> genWord32 <*> genWord32
428 ]
430 where
431 dbTypeTest :: (Eq a, Show a, Rel8.DBType a) => TestName -> Gen a -> TestTree
432 dbTypeTest name generator = testGroup name
433 [ databasePropertyTest name (t generator) getTestDatabase
434 , databasePropertyTest ("Maybe " <> name) (t (Gen.maybe generator)) getTestDatabase
435 ]
437 t :: forall a b. (Eq a, Show a, Rel8.Sql Rel8.DBType a)
438 => Gen a
439 -> (TestT Transaction () -> PropertyT IO b)
440 -> PropertyT IO b
441 t generator transaction = do
442 x <- forAll generator
444 transaction do
445 [res] <- lift do
446 statement () $ Rel8.select do
447 pure (Rel8.litExpr x)
448 diff res (==) x
450 genDay :: Gen Day
451 genDay = do
452 year <- Gen.integral (Range.linear 1970 3000)
453 month <- Gen.integral (Range.linear 1 12)
454 day <- Gen.integral (Range.linear 1 31)
455 Gen.just $ pure $ fromGregorianValid year month day
457 genDiffTime :: Gen DiffTime
458 genDiffTime = secondsToDiffTime <$> Gen.integral (Range.linear 0 86401)
460 genTimeOfDay :: Gen TimeOfDay
461 genTimeOfDay = do
462 hour <- Gen.integral (Range.linear 0 23)
463 minute <- Gen.integral (Range.linear 0 59)
464 sec <- fromIntegral @Int <$> Gen.integral (Range.linear 0 59)
465 Gen.just $ pure $ makeTimeOfDayValid hour minute sec
467 genLocalTime = LocalTime <$> genDay <*> genTimeOfDay
469 genWord32 :: Gen Word32
470 genWord32 = Gen.integral Range.linearBounded
473testDBEq :: IO TmpPostgres.DB -> TestTree
474testDBEq getTestDatabase = testGroup "DBEq instances"
475 [ dbEqTest "Bool" Gen.bool
476 , dbEqTest "Int32" $ Gen.integral @_ @Int32 Range.linearBounded
477 , dbEqTest "Int64" $ Gen.integral @_ @Int64 Range.linearBounded
478 , dbEqTest "Text" $ Gen.text (Range.linear 0 10) Gen.unicode
479 ]
481 where
482 dbEqTest :: (Eq a, Show a, Rel8.DBEq a) => TestName -> Gen a -> TestTree
483 dbEqTest name generator = testGroup name
484 [ databasePropertyTest name (t generator) getTestDatabase
485 , databasePropertyTest ("Maybe " <> name) (t (Gen.maybe generator)) getTestDatabase
486 ]
488 t :: forall a. (Eq a, Show a, Rel8.Sql Rel8.DBEq a)
489 => Gen a
490 -> (TestT Transaction () -> PropertyT IO ())
491 -> PropertyT IO ()
492 t generator transaction = do
493 (x, y) <- forAll (liftA2 (,) generator generator)
495 transaction do
496 [res] <- lift do
497 statement () $ Rel8.select do
498 pure $ Rel8.litExpr x Rel8.==. Rel8.litExpr y
499 res === (x == y)
502testTableEquality :: IO TmpPostgres.DB -> TestTree
503testTableEquality = databasePropertyTest "TestTable equality" \transaction -> do
504 (x, y) <- forAll $ liftA2 (,) genTestTable genTestTable
506 transaction do
507 [eq] <- lift do
508 statement () $ Rel8.select do
509 pure $ Rel8.lit x Rel8.==: Rel8.lit y
511 eq === (x == y)
514testFromString :: IO TmpPostgres.DB -> TestTree
515testFromString = databasePropertyTest "FromString" \transaction -> do
516 str <- forAll $ Gen.list (Range.linear 0 10) Gen.unicode
518 transaction do
519 [result] <- lift do
520 statement () $ Rel8.select do
521 pure $ fromString str
522 result === pack str
525testCatMaybeTable :: IO TmpPostgres.DB -> TestTree
526testCatMaybeTable = databasePropertyTest "catMaybeTable" \transaction -> do
527 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
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)
535 sort selected === sort (filter testTableColumn2 rows)
538testCatMaybe :: IO TmpPostgres.DB -> TestTree
539testCatMaybe = databasePropertyTest "catMaybe" \transaction -> evalM do
540 rows <- forAll $ Gen.list (Range.linear 0 10) $ Gen.maybe Gen.bool
542 transaction do
543 selected <- lift do
544 statement () $ Rel8.select do
545 Rel8.catNull =<< Rel8.values (map Rel8.lit rows)
547 sort selected === sort (catMaybes rows)
550testMaybeTable :: IO TmpPostgres.DB -> TestTree
551testMaybeTable = databasePropertyTest "maybeTable" \transaction -> evalM do
552 (rows, def) <- forAll $ liftA2 (,) (Gen.list (Range.linear 0 10) genTestTable) genTestTable
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))
559 case rows of
560 [] -> selected === [def]
561 _ -> sort selected === sort rows
564testAggregateMaybeTable :: IO TmpPostgres.DB -> TestTree
565testAggregateMaybeTable = databasePropertyTest "aggregateMaybeTable" \transaction -> evalM do
566 rows <- forAll $ Gen.list (Range.linear 0 10) (Gen.maybe (Gen.int64 (Range.linear 0 10)))
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]
578 transaction do
579 selected <- lift do
580 statement () $ Rel8.select do
581 Rel8.aggregate $ Rel8.aggregateMaybeTable Rel8.sum <$> Rel8.values (Rel8.lit <$> rows)
583 sort selected === aggregate rows
586data TwoTestTables f =
587 TwoTestTables
588 { testTable1 :: TestTable f
589 , testTable2 :: TestTable f
590 }
591 deriving stock Generic
592 deriving anyclass Rel8.Rel8able
595deriving stock instance Eq (TwoTestTables Result)
596deriving stock instance Ord (TwoTestTables Result)
597deriving stock instance Show (TwoTestTables Result)
600testNestedTables :: IO TmpPostgres.DB -> TestTree
601testNestedTables = databasePropertyTest "Nested TestTables" \transaction -> evalM do
602 rows <- forAll do
603 Gen.list (Range.linear 0 10) $
604 liftA2 TwoTestTables genTestTable genTestTable
606 transaction do
607 selected <- lift do
608 statement () $ Rel8.select do
609 Rel8.values (Rel8.lit <$> rows)
611 sort selected === sort rows
614testMaybeTableApplicative :: IO TmpPostgres.DB -> TestTree
615testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction -> evalM do
616 rows1 <- genRows
617 rows2 <- genRows
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
626 case (rows1, rows2) of
627 ([], []) -> selected === [Nothing]
628 ([], bs) -> selected === (Nothing <$ bs)
629 (as, []) -> selected === (Nothing <$ as)
630 (as, bs) -> sort selected === sort (Just <$> liftA2 (,) as bs)
631 where
632 genRows :: PropertyT IO [TestTable Result]
633 genRows = forAll do
634 Gen.list (Range.linear 0 10) $ liftA2 TestTable (Gen.text (Range.linear 0 10) Gen.unicode) (pure True)
637genTestTable :: Gen (TestTable Result)
638genTestTable = do
639 testTableColumn1 <- Gen.text (Range.linear 0 5) Gen.alphaNum
640 testTableColumn2 <- Gen.bool
641 return TestTable{..}
644testUpdate :: IO TmpPostgres.DB -> TestTree
645testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do
646 rows <- forAll $ Gen.map (Range.linear 0 5) $ liftA2 (,) genTestTable genTestTable
648 transaction do
649 selected <- lift do
650 statement () $ Rel8.insert Rel8.Insert
651 { into = testTableSchema
652 , rows = Rel8.values $ map Rel8.lit $ Map.keys rows
653 , onConflict = Rel8.DoNothing
654 , returning = pure ()
655 }
657 statement () $ Rel8.update Rel8.Update
658 { target = testTableSchema
659 , from = pure ()
660 , set = \_ r ->
661 let updates = map (bimap Rel8.lit Rel8.lit) $ Map.toList rows
662 in
663 foldl
664 ( \e (x, y) ->
665 Rel8.bool
666 e
667 y
668 ( testTableColumn1 r Rel8.==. testTableColumn1 x Rel8.&&.
669 testTableColumn2 r Rel8.==. testTableColumn2 x
670 )
671 )
672 r
673 updates
674 , updateWhere = \_ _ -> Rel8.lit True
675 , returning = pure ()
676 }
678 statement () $ Rel8.select do
679 Rel8.each testTableSchema
681 sort selected === sort (Map.elems rows)
683 cover 1 "Empty" $ null rows
684 cover 1 "Singleton" $ null $ drop 1 $ Map.keys rows
685 cover 1 ">1 row" $ not $ null $ drop 1 $ Map.keys rows
688testDelete :: IO TmpPostgres.DB -> TestTree
689testDelete = databasePropertyTest "Can DELETE TestTable" \transaction -> do
690 rows <- forAll $ Gen.list (Range.linear 0 5) genTestTable
692 transaction do
693 (deleted, selected) <- lift do
694 statement () $ Rel8.insert Rel8.Insert
695 { into = testTableSchema
696 , rows = Rel8.values $ map Rel8.lit rows
697 , onConflict = Rel8.DoNothing
698 , returning = pure ()
699 }
701 deleted <- statement () $ Rel8.delete Rel8.Delete
702 { from = testTableSchema
703 , using = pure ()
704 , deleteWhere = const testTableColumn2
705 , returning = Rel8.Projection id
706 }
708 selected <- statement () $ Rel8.select do
709 Rel8.each testTableSchema
711 pure (deleted, selected)
713 sort (deleted <> selected) === sort rows
716data 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
724deriving stock instance Eq (UniqueTable Result)
725deriving stock instance Ord (UniqueTable Result)
726deriving stock instance Show (UniqueTable Result)
729uniqueTableSchema :: Rel8.TableSchema (UniqueTable Rel8.Name)
730uniqueTableSchema =
731 Rel8.TableSchema
732 { name = "unique_table"
733 , schema = Nothing
734 , columns = UniqueTable
735 { uniqueTableKey = "key"
736 , uniqueTableValue = "value"
737 }
738 }
741genUniqueTable :: Gen (UniqueTable Result)
742genUniqueTable = do
743 uniqueTableKey <- Gen.text (Range.linear 0 5) Gen.alphaNum
744 uniqueTableValue <- Gen.text (Range.linear 0 5) Gen.alphaNum
745 pure UniqueTable {..}
748testUpsert :: IO TmpPostgres.DB -> TestTree
749testUpsert = 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
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 }
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 }
773 statement () $ Rel8.select do
774 Rel8.each uniqueTableSchema
776 fromUniqueTables selected === fromUniqueTables bs <> fromUniqueTables as
777 where
778 unique = fmap (nubOrdOn uniqueTableKey)
779 fromUniqueTables = Map.fromList . map \(UniqueTable key value) -> (key, value)
782newtype HKNestedPair f = HKNestedPair { pairOne :: (TestTable f, TestTable f) }
783 deriving stock Generic
784 deriving anyclass Rel8.Rel8able
786deriving stock instance Eq (HKNestedPair Result)
787deriving stock instance Ord (HKNestedPair Result)
788deriving stock instance Show (HKNestedPair Result)
791testSelectNestedPairs :: IO TmpPostgres.DB -> TestTree
792testSelectNestedPairs = databasePropertyTest "Can SELECT nested pairs" \transaction -> do
793 rows <- forAll $ Gen.list (Range.linear 0 10) $ HKNestedPair <$> liftA2 (,) genTestTable genTestTable
795 transaction do
796 selected <- lift do
797 statement () $ Rel8.select do
798 Rel8.values $ map Rel8.lit rows
800 sort selected === sort rows
803testSelectArray :: IO TmpPostgres.DB -> TestTree
804testSelectArray = databasePropertyTest "Can SELECT Arrays (with aggregation)" \transaction -> do
805 rows <- forAll $ Gen.list (Range.linear 1 10) Gen.bool
807 transaction do
808 selected <- lift do
809 statement () $ Rel8.select do
810 Rel8.many $ Rel8.values (map Rel8.lit rows)
812 selected === [foldMap pure rows]
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)
822 selected' === liftA2 (,) rows rows
825data NestedMaybeTable f = NestedMaybeTable
826 { nmt1 :: Rel8.Column f Bool
827 , nmt2 :: Rel8.HMaybe f (TestTable f)
828 }
829 deriving stock Generic
830 deriving anyclass Rel8.Rel8able
833deriving stock instance Eq (NestedMaybeTable Result)
834deriving stock instance Ord (NestedMaybeTable Result)
835deriving stock instance Show (NestedMaybeTable Result)
838testNestedMaybeTable :: IO TmpPostgres.DB -> TestTree
839testNestedMaybeTable = databasePropertyTest "Can nest MaybeTable within other tables" \transaction -> do
840 let example = NestedMaybeTable { nmt1 = True, nmt2 = Just (TestTable "Hi" True) }
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)
848 selected === [True]
851testEvaluate :: IO TmpPostgres.DB -> TestTree
852testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect" \transaction -> do
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))
861 normalize selected ===
862 [ ('a', (0, 0))
863 , ('b', (1, 1))
864 , ('c', (2, 2))
865 ]
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))
874 normalize selected' ===
875 [ (('a', 'd'), (0, 0))
876 , (('a', 'e'), (1, 1))
877 , (('a', 'f'), (2, 2))
878 , (('b', 'd'), (3, 3))
879 , (('b', 'e'), (4, 4))
880 , (('b', 'f'), (5, 5))
881 , (('c', 'd'), (6, 6))
882 , (('c', 'e'), (7, 7))
883 , (('c', 'f'), (8, 8))
884 ]
886 where
887 normalize :: [(x, (Int64, Int64))] -> [(x, (Int64, Int64))]
888 normalize [] = []
889 normalize xs@((_, (i, _)) : _) = map (fmap (\(a, b) -> (a - i, b - i))) xs