2020-06-12 20:03:52 +03:00
|
|
|
{-# language BlockArguments #-}
|
|
|
|
{-# language QuasiQuotes #-}
|
|
|
|
{-# language DisambiguateRecordFields #-}
|
|
|
|
{-# language OverloadedStrings #-}
|
|
|
|
{-# language RecordWildCards #-}
|
|
|
|
{-# language DeriveGeneric #-}
|
|
|
|
{-# language StandaloneDeriving #-}
|
|
|
|
{-# language DeriveAnyClass #-}
|
|
|
|
{-# language FlexibleInstances #-}
|
|
|
|
{-# language FlexibleContexts #-}
|
|
|
|
|
|
|
|
module Main where
|
|
|
|
|
2020-06-14 14:27:55 +03:00
|
|
|
import Control.Applicative ( liftA2 )
|
2020-06-14 14:14:24 +03:00
|
|
|
import Control.Exception.Lifted ( bracket, throwIO, finally )
|
2020-06-13 23:03:09 +03:00
|
|
|
import Control.Monad.IO.Class ( MonadIO, liftIO )
|
|
|
|
import Control.Monad.Trans.Control ( MonadBaseControl, liftBaseOp_ )
|
2020-06-13 12:51:02 +03:00
|
|
|
import Data.Foldable ( for_ )
|
2020-06-13 16:26:14 +03:00
|
|
|
import Data.List ( nub, sort )
|
2020-06-12 20:03:52 +03:00
|
|
|
import Database.PostgreSQL.Simple ( Connection, connectPostgreSQL, close, withTransaction, execute_, executeMany, rollback )
|
|
|
|
import Database.PostgreSQL.Simple.SqlQQ ( sql )
|
|
|
|
import qualified Database.Postgres.Temp as TmpPostgres
|
2020-06-13 23:03:09 +03:00
|
|
|
import GHC.Generics ( Generic )
|
2020-06-13 16:20:04 +03:00
|
|
|
import Hedgehog ( Property, property, (===), forAll, cover, diff, evalM, PropertyT )
|
2020-06-12 20:03:52 +03:00
|
|
|
import qualified Hedgehog.Gen as Gen
|
|
|
|
import qualified Hedgehog.Range as Range
|
|
|
|
import qualified Rel8
|
|
|
|
import Test.Tasty
|
|
|
|
import Test.Tasty.Hedgehog ( testProperty )
|
|
|
|
|
|
|
|
|
|
|
|
main :: IO ()
|
|
|
|
main = defaultMain tests
|
|
|
|
|
|
|
|
|
|
|
|
tests :: TestTree
|
|
|
|
tests =
|
|
|
|
withResource startTestDatabase stopTestDatabase \getTestDatabase ->
|
2020-06-13 12:51:02 +03:00
|
|
|
testGroup "rel8"
|
|
|
|
[ testSelectTestTable getTestDatabase
|
|
|
|
, testWhere_ getTestDatabase
|
|
|
|
, testLimit getTestDatabase
|
|
|
|
, testUnion getTestDatabase
|
2020-06-13 16:26:14 +03:00
|
|
|
, testDistinct getTestDatabase
|
2020-06-13 23:03:09 +03:00
|
|
|
, testExists getTestDatabase
|
2020-06-14 13:24:57 +03:00
|
|
|
, testOptional getTestDatabase
|
2020-06-14 14:27:55 +03:00
|
|
|
, testAnd getTestDatabase
|
|
|
|
, testOr getTestDatabase
|
2020-06-13 12:51:02 +03:00
|
|
|
]
|
2020-06-12 20:03:52 +03:00
|
|
|
|
|
|
|
where
|
|
|
|
|
|
|
|
startTestDatabase = do
|
|
|
|
db <- TmpPostgres.start >>= either throwIO return
|
|
|
|
|
|
|
|
bracket (connectPostgreSQL (TmpPostgres.toConnectionString db)) close \conn -> do
|
|
|
|
execute_ conn [sql|
|
|
|
|
CREATE TABLE test_table ( column1 text not null, column2 bool not null );
|
|
|
|
|]
|
|
|
|
|
|
|
|
return (db)
|
|
|
|
|
|
|
|
stopTestDatabase = TmpPostgres.stop
|
|
|
|
|
2020-06-13 16:20:04 +03:00
|
|
|
databasePropertyTest :: TestName -> (Connection -> PropertyT IO ()) -> IO TmpPostgres.DB -> TestTree
|
2020-06-12 20:03:52 +03:00
|
|
|
databasePropertyTest testName f getTestDatabase =
|
2020-06-13 16:20:04 +03:00
|
|
|
withResource connect close $ \c ->
|
|
|
|
testProperty testName $ property do
|
|
|
|
connection <- liftIO c
|
|
|
|
rollingBack connection (f connection)
|
2020-06-12 20:03:52 +03:00
|
|
|
|
|
|
|
where
|
|
|
|
|
|
|
|
connect = connectPostgreSQL . TmpPostgres.toConnectionString =<< getTestDatabase
|
|
|
|
|
|
|
|
|
|
|
|
data TestTable f = TestTable
|
|
|
|
{ testTableColumn1 :: Rel8.Column f String
|
|
|
|
, testTableColumn2 :: Rel8.Column f Bool
|
|
|
|
}
|
|
|
|
deriving
|
|
|
|
( Generic, Rel8.HigherKindedTable )
|
|
|
|
|
|
|
|
|
|
|
|
deriving instance Eq (TestTable Rel8.Identity)
|
|
|
|
deriving instance Ord (TestTable Rel8.Identity)
|
|
|
|
deriving instance Show (TestTable Rel8.Identity)
|
|
|
|
|
|
|
|
|
|
|
|
testTableSchema :: Rel8.TableSchema ( TestTable Rel8.ColumnSchema )
|
|
|
|
testTableSchema =
|
|
|
|
Rel8.TableSchema
|
|
|
|
{ tableName = "test_table"
|
|
|
|
, tableSchema = Nothing
|
|
|
|
, tableColumns = TestTable
|
|
|
|
{ testTableColumn1 = "column1"
|
|
|
|
, testTableColumn2 = "column2"
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
testSelectTestTable :: IO TmpPostgres.DB -> TestTree
|
2020-06-13 16:20:04 +03:00
|
|
|
testSelectTestTable = databasePropertyTest "Can SELECT TestTable" \connection -> do
|
2020-06-13 12:51:02 +03:00
|
|
|
rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
|
2020-06-12 20:03:52 +03:00
|
|
|
|
2020-06-14 13:38:10 +03:00
|
|
|
liftIO do
|
|
|
|
executeMany connection
|
|
|
|
[sql| INSERT INTO test_table (column1, column2) VALUES (?, ?) |]
|
|
|
|
[ ( testTableColumn1, testTableColumn2 ) | TestTable{..} <- rows ]
|
2020-06-12 20:03:52 +03:00
|
|
|
|
2020-06-14 13:38:10 +03:00
|
|
|
selected <- Rel8.select connection do
|
|
|
|
Rel8.each testTableSchema
|
2020-06-12 20:03:52 +03:00
|
|
|
|
|
|
|
sort selected === sort rows
|
|
|
|
|
2020-06-13 12:51:02 +03:00
|
|
|
cover 1 "Empty" $ null rows
|
|
|
|
cover 1 "Singleton" $ null $ drop 1 rows
|
|
|
|
cover 1 ">1 row" $ not $ null $ drop 1 rows
|
|
|
|
|
|
|
|
|
|
|
|
testWhere_ :: IO TmpPostgres.DB -> TestTree
|
2020-06-13 16:20:04 +03:00
|
|
|
testWhere_ = databasePropertyTest "WHERE (Rel8.where_)" \connection -> do
|
2020-06-13 12:51:02 +03:00
|
|
|
rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable
|
|
|
|
|
|
|
|
magicBool <- forAll Gen.bool
|
|
|
|
|
|
|
|
let expected = filter (\t -> testTableColumn2 t == magicBool) rows
|
|
|
|
|
2020-06-14 13:38:10 +03:00
|
|
|
selected <- Rel8.select connection do
|
|
|
|
t <- Rel8.values $ Rel8.litTable <$> rows
|
|
|
|
Rel8.where_ $ testTableColumn2 t Rel8.==. Rel8.lit magicBool
|
|
|
|
return t
|
2020-06-13 12:51:02 +03:00
|
|
|
|
|
|
|
sort selected === sort expected
|
|
|
|
|
|
|
|
cover 1 "No results" $ null expected
|
|
|
|
cover 1 "Some results" $ not $ null expected
|
|
|
|
cover 1 "All results" $ expected == rows
|
|
|
|
|
|
|
|
|
|
|
|
testLimit :: IO TmpPostgres.DB -> TestTree
|
2020-06-13 16:20:04 +03:00
|
|
|
testLimit = databasePropertyTest "LIMIT (Rel8.limit)" \connection -> do
|
2020-06-13 12:51:02 +03:00
|
|
|
rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable
|
|
|
|
|
|
|
|
n <- forAll $ Gen.integral (Range.linear 0 10)
|
|
|
|
|
2020-06-14 13:38:10 +03:00
|
|
|
selected <- Rel8.select connection do
|
|
|
|
Rel8.limit n $ Rel8.values (Rel8.litTable <$> rows)
|
2020-06-13 12:51:02 +03:00
|
|
|
|
|
|
|
diff (length selected) (<=) (fromIntegral n)
|
|
|
|
|
|
|
|
for_ selected \row ->
|
|
|
|
diff row elem rows
|
|
|
|
|
|
|
|
cover 1 "n == 0" $ n == 0
|
|
|
|
cover 1 "n < length rows" $ fromIntegral n < length rows
|
|
|
|
cover 1 "n == length rows" $ fromIntegral n == length rows
|
|
|
|
cover 1 "n >= length rows" $ fromIntegral n >= length rows
|
|
|
|
|
|
|
|
|
|
|
|
testUnion :: IO TmpPostgres.DB -> TestTree
|
2020-06-13 16:20:04 +03:00
|
|
|
testUnion = databasePropertyTest "UNION (Rel8.union)" \connection -> do
|
2020-06-13 12:51:02 +03:00
|
|
|
left <- forAll $ Gen.list (Range.linear 0 10) genTestTable
|
|
|
|
right <- forAll $ Gen.list (Range.linear 0 10) genTestTable
|
|
|
|
|
2020-06-14 13:38:10 +03:00
|
|
|
selected <- Rel8.select connection do
|
|
|
|
Rel8.values (Rel8.litTable <$> left) `Rel8.union` Rel8.values (Rel8.litTable <$> right)
|
2020-06-13 12:51:02 +03:00
|
|
|
|
|
|
|
sort selected === sort (left ++ right)
|
|
|
|
|
2020-06-12 20:03:52 +03:00
|
|
|
|
2020-06-13 16:26:14 +03:00
|
|
|
testDistinct :: IO TmpPostgres.DB -> TestTree
|
|
|
|
testDistinct = databasePropertyTest "DISTINCT (Rel8.distinct)" \connection -> do
|
|
|
|
rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
|
|
|
|
|
2020-06-14 13:38:10 +03:00
|
|
|
selected <- Rel8.select connection $ Rel8.distinct do
|
|
|
|
Rel8.values (Rel8.litTable <$> rows)
|
2020-06-13 16:26:14 +03:00
|
|
|
|
|
|
|
sort selected === nub (sort rows)
|
|
|
|
|
|
|
|
cover 1 "Empty" $ null rows
|
|
|
|
cover 1 "Duplicates" $ not (null rows) && rows /= nub rows
|
|
|
|
cover 1 "No duplicates" $ not (null rows) && rows == nub rows
|
|
|
|
|
|
|
|
|
2020-06-13 23:03:09 +03:00
|
|
|
testExists :: IO TmpPostgres.DB -> TestTree
|
|
|
|
testExists = databasePropertyTest "EXISTS (Rel8.exists)" \connection -> do
|
|
|
|
rows1 <- forAll $ Gen.list (Range.linear 1 10) genTestTable
|
|
|
|
rows2 <- forAll $ Gen.maybe genTestTable
|
|
|
|
|
2020-06-14 13:38:10 +03:00
|
|
|
selected <- Rel8.select connection do
|
|
|
|
row <- Rel8.values $ Rel8.litTable <$> rows1
|
|
|
|
Rel8.exists do
|
|
|
|
Rel8.values $ Rel8.litTable <$> rows2
|
|
|
|
return row
|
2020-06-13 23:03:09 +03:00
|
|
|
|
|
|
|
case rows2 of
|
|
|
|
Nothing -> sort selected === []
|
|
|
|
Just{} -> sort selected === sort rows1
|
|
|
|
|
|
|
|
cover 1 "EXISTS = False" $ null rows2
|
|
|
|
cover 1 "EXISTS = True" $ not $ null rows2
|
|
|
|
|
2020-06-14 13:24:57 +03:00
|
|
|
|
|
|
|
testOptional :: IO TmpPostgres.DB -> TestTree
|
|
|
|
testOptional = databasePropertyTest "Rel8.optional" \connection -> do
|
|
|
|
rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
|
|
|
|
|
2020-06-14 14:14:20 +03:00
|
|
|
liftIO do
|
|
|
|
executeMany connection
|
|
|
|
[sql| INSERT INTO test_table (column1, column2) VALUES (?, ?) |]
|
|
|
|
[ ( testTableColumn1, testTableColumn2 ) | TestTable{..} <- rows ]
|
|
|
|
|
|
|
|
selected <- Rel8.select connection do
|
|
|
|
Rel8.optional $ Rel8.each testTableSchema
|
2020-06-14 13:24:57 +03:00
|
|
|
|
|
|
|
case rows of
|
|
|
|
[] -> selected === [Nothing]
|
|
|
|
_ -> sort selected === fmap Just (sort rows)
|
|
|
|
|
|
|
|
|
2020-06-14 14:27:55 +03:00
|
|
|
testAnd :: IO TmpPostgres.DB -> TestTree
|
|
|
|
testAnd = databasePropertyTest "AND (&&.)" \connection -> do
|
|
|
|
(x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool
|
|
|
|
|
|
|
|
[result] <- Rel8.select connection $ pure $
|
|
|
|
Rel8.lit x Rel8.&&. Rel8.lit y
|
|
|
|
|
|
|
|
result === (x && y)
|
|
|
|
|
|
|
|
|
|
|
|
testOr :: IO TmpPostgres.DB -> TestTree
|
|
|
|
testOr = databasePropertyTest "OR (||.)" \connection -> do
|
|
|
|
(x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool
|
|
|
|
|
|
|
|
[result] <- Rel8.select connection $ pure $
|
|
|
|
Rel8.lit x Rel8.||. Rel8.lit y
|
|
|
|
|
|
|
|
result === (x || y)
|
|
|
|
|
|
|
|
|
2020-06-12 20:03:52 +03:00
|
|
|
rollingBack
|
|
|
|
:: (MonadBaseControl IO m, MonadIO m)
|
|
|
|
=> Connection -> m a -> m a
|
|
|
|
rollingBack connection m =
|
2020-06-14 14:14:24 +03:00
|
|
|
liftBaseOp_ (withTransaction connection) do
|
|
|
|
m `finally` liftIO (rollback connection)
|
2020-06-13 12:51:02 +03:00
|
|
|
|
|
|
|
|
|
|
|
genTestTable = do
|
2020-06-13 16:26:14 +03:00
|
|
|
testTableColumn1 <- Gen.list (Range.linear 0 5) Gen.alphaNum
|
2020-06-13 12:51:02 +03:00
|
|
|
testTableColumn2 <- Gen.bool
|
|
|
|
return TestTable{..}
|