opaleye-0.5.3.1: Test/Test.hs
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module Main where
import qualified QuickCheck
import Opaleye (Column, Nullable, Query, QueryArr, (.==), (.>))
import qualified Opaleye as O
import qualified Opaleye.Internal.Aggregate as IA
import qualified Database.PostgreSQL.Simple as PGS
import qualified Database.PostgreSQL.Simple.Range as R
import qualified Data.Profunctor.Product.Default as D
import qualified Data.Profunctor.Product as PP
import qualified Data.Profunctor as P
import qualified Data.Ord as Ord
import qualified Data.List as L
import Data.Monoid ((<>))
import qualified Data.String as String
import qualified Data.Time as Time
import qualified Data.Aeson as Json
import qualified Data.Text as T
import System.Environment (lookupEnv)
import Control.Applicative ((<$>), (<*>), (<|>))
import qualified Control.Applicative as A
import qualified Control.Arrow as Arr
import Control.Arrow ((&&&), (***), (<<<), (>>>))
import GHC.Int (Int64)
import Test.Hspec
import qualified Configuration.Dotenv as Dotenv
{-
Status
======
The tests here are very superficial and pretty much the bare mininmum
that needs to be tested.
Future
======
The overall approach to testing should probably go as follows.
1. Test all individual units of functionality by running them on a
table and checking that they produce the expected result. This type
of testing is amenable to the QuickCheck approach if we reimplement
the individual units of functionality in Haskell.
2. Test that "the denotation is an arrow morphism" is correct. I
think in combination with 1. this is all that will be required to
demonstrate that the library is correct.
"The denotation is an arrow morphism" means that for each arrow
operation, the denotation preserves the operation. If we have
f :: QueryArr wiresa wiresb
then [f] should be something like
[f] :: a -> IO [b]
f as = runQuery (toValues as >>> f)
For example, take the operation >>>. We need to check that
[f >>> g] = [f] >>> [g]
for all f and g, where [] means the denotation. We would also want
to check that
[id] = id
and
[first f] = first [f]
I think checking these operations is sufficient because all the
other QueryArr operations are implemented in terms of them.
(Here I'm taking a slight liberty as `a -> IO [b]` is not directly
an arrow, but it could be made one straightforwardly. (For the laws
to be satisfied, perhaps we have to assume that the IO actions
commute.))
I don't think this type of testing is amenable to QuickCheck. It
seems we have to check the properties for arbitrary arrows indexed by
arbitrary types. I don't think QuickCheck supports this sort of
randomised testing.
Note
----
This seems to be equivalent to just reimplementing Opaleye in
Haskell-side terms and comparing the results of queries run in both
ways.
-}
twoIntTable :: String
-> O.Table (Column O.PGInt4, Column O.PGInt4) (Column O.PGInt4, Column O.PGInt4)
twoIntTable n = O.Table n (PP.p2 (O.required "column1", O.required "column2"))
table1 :: O.Table (Column O.PGInt4, Column O.PGInt4) (Column O.PGInt4, Column O.PGInt4)
table1 = twoIntTable "table1"
table1F :: O.Table (Column O.PGInt4, Column O.PGInt4) (Column O.PGInt4, Column O.PGInt4)
table1F = fmap (\(col1, col2) -> (col1 + col2, col1 - col2)) table1
-- This is implicitly testing our ability to handle upper case letters in table names.
table2 :: O.Table (Column O.PGInt4, Column O.PGInt4) (Column O.PGInt4, Column O.PGInt4)
table2 = twoIntTable "TABLE2"
table3 :: O.Table (Column O.PGInt4, Column O.PGInt4) (Column O.PGInt4, Column O.PGInt4)
table3 = twoIntTable "table3"
table4 :: O.Table (Column O.PGInt4, Column O.PGInt4) (Column O.PGInt4, Column O.PGInt4)
table4 = twoIntTable "table4"
table5 :: O.Table (Maybe (Column O.PGInt4), Maybe (Column O.PGInt4))
(Column O.PGInt4, Column O.PGInt4)
table5 = O.TableWithSchema "public" "table5" (PP.p2 (O.optional "column1", O.optional "column2"))
table6 :: O.Table (Column O.PGText, Column O.PGText) (Column O.PGText, Column O.PGText)
table6 = O.Table "table6" (PP.p2 (O.required "column1", O.required "column2"))
table7 :: O.Table (Column O.PGText, Column O.PGText) (Column O.PGText, Column O.PGText)
table7 = O.Table "table7" (PP.p2 (O.required "column1", O.required "column2"))
table8 :: O.Table (Column O.PGJson) (Column O.PGJson)
table8 = O.Table "table8" (O.required "column1")
table9 :: O.Table (Column O.PGJsonb) (Column O.PGJsonb)
table9 = O.Table "table9" (O.required "column1")
tableKeywordColNames :: O.Table (Column O.PGInt4, Column O.PGInt4)
(Column O.PGInt4, Column O.PGInt4)
tableKeywordColNames = O.Table "keywordtable" (PP.p2 (O.required "column", O.required "where"))
table1Q :: Query (Column O.PGInt4, Column O.PGInt4)
table1Q = O.queryTable table1
table2Q :: Query (Column O.PGInt4, Column O.PGInt4)
table2Q = O.queryTable table2
table3Q :: Query (Column O.PGInt4, Column O.PGInt4)
table3Q = O.queryTable table3
table6Q :: Query (Column O.PGText, Column O.PGText)
table6Q = O.queryTable table6
table7Q :: Query (Column O.PGText, Column O.PGText)
table7Q = O.queryTable table7
table8Q :: Query (Column O.PGJson)
table8Q = O.queryTable table8
table9Q :: Query (Column O.PGJsonb)
table9Q = O.queryTable table9
table1dataG :: Num a => [(a, a)]
table1dataG = [ (1, 100)
, (1, 100)
, (1, 200)
, (2, 300) ]
table1data :: [(Int, Int)]
table1data = table1dataG
table1columndata :: [(Column O.PGInt4, Column O.PGInt4)]
table1columndata = table1dataG
table2dataG :: Num a => [(a, a)]
table2dataG = [ (1, 100)
, (3, 400) ]
table2data :: [(Int, Int)]
table2data = table2dataG
table2columndata :: [(Column O.PGInt4, Column O.PGInt4)]
table2columndata = table2dataG
table3dataG :: Num a => [(a, a)]
table3dataG = [ (1, 50) ]
table3data :: [(Int, Int)]
table3data = table3dataG
table3columndata :: [(Column O.PGInt4, Column O.PGInt4)]
table3columndata = table3dataG
table4dataG :: Num a => [(a, a)]
table4dataG = [ (1, 10)
, (2, 20) ]
table4data :: [(Int, Int)]
table4data = table4dataG
table4columndata :: [(Column O.PGInt4, Column O.PGInt4)]
table4columndata = table4dataG
table6data :: [(String, String)]
table6data = [("xy", "a"), ("z", "a"), ("more text", "a")]
table6columndata :: [(Column O.PGText, Column O.PGText)]
table6columndata = map (\(column1, column2) -> (O.pgString column1, O.pgString column2)) table6data
table7data :: [(String, String)]
table7data = [("foo", "c"), ("bar", "a"), ("baz", "b")]
table7columndata :: [(Column O.PGText, Column O.PGText)]
table7columndata = map (O.pgString *** O.pgString) table7data
table8data :: [Json.Value]
table8data = [ Json.object
[ "a" Json..= ([10,20..100] :: [Int])
, "b" Json..= Json.object ["x" Json..= (42 :: Int)]
, "c" Json..= (21 :: Int)
]
]
table8columndata :: [Column O.PGJson]
table8columndata = map O.pgValueJSON table8data
table9columndata :: [Column O.PGJsonb]
table9columndata = map O.pgValueJSONB table8data
-- We have to quote the table names here because upper case letters in
-- table names are treated as lower case unless the name is quoted!
dropAndCreateTable :: String -> (String, [String]) -> PGS.Query
dropAndCreateTable columnType (t, cols) = String.fromString drop_
where drop_ = "DROP TABLE IF EXISTS \"public\".\"" ++ t ++ "\";"
++ "CREATE TABLE \"public\".\"" ++ t ++ "\""
++ " (" ++ commas cols ++ ");"
integer c = "\"" ++ c ++ "\"" ++ " " ++ columnType
commas = L.intercalate "," . map integer
dropAndCreateTableInt :: (String, [String]) -> PGS.Query
dropAndCreateTableInt = dropAndCreateTable "integer"
dropAndCreateTableText :: (String, [String]) -> PGS.Query
dropAndCreateTableText = dropAndCreateTable "text"
-- We have to quote the table names here because upper case letters in
-- table names are treated as lower case unless the name is quoted!
dropAndCreateTableSerial :: (String, [String]) -> PGS.Query
dropAndCreateTableSerial (t, cols) = String.fromString drop_
where drop_ = "DROP TABLE IF EXISTS \"public\".\"" ++ t ++ "\";"
++ "CREATE TABLE \"public\".\"" ++ t ++ "\""
++ " (" ++ commas cols ++ ");"
integer c = "\"" ++ c ++ "\"" ++ " SERIAL"
commas = L.intercalate "," . map integer
dropAndCreateTableJson :: (String, [String]) -> PGS.Query
dropAndCreateTableJson = dropAndCreateTable "json"
dropAndCreateTableJsonb :: (String, [String]) -> PGS.Query
dropAndCreateTableJsonb = dropAndCreateTable "jsonb"
type Table_ = (String, [String])
-- This should ideally be derived from the table definition above
columns2 :: String -> Table_
columns2 t = (t, ["column1", "column2"])
-- This should ideally be derived from the table definition above
tables :: [Table_]
tables = map columns2 ["table1", "TABLE2", "table3", "table4"]
++ [("keywordtable", ["column", "where"])]
serialTables :: [Table_]
serialTables = map columns2 ["table5"]
textTables :: [Table_]
textTables = map columns2 ["table6", "table7"]
jsonTables :: [Table_]
jsonTables = [("table8", ["column1"])]
jsonbTables :: [Table_]
jsonbTables = [("table9", ["column1"])]
dropAndCreateDB :: PGS.Connection -> IO ()
dropAndCreateDB conn = do
mapM_ execute tables
mapM_ executeTextTable textTables
mapM_ executeSerial serialTables
mapM_ executeJson jsonTables
-- Disabled until Travis supports Postgresql >= 9.4
-- mapM_ executeJsonb jsonbTables
where execute = PGS.execute_ conn . dropAndCreateTableInt
executeTextTable = PGS.execute_ conn . dropAndCreateTableText
executeSerial = PGS.execute_ conn . dropAndCreateTableSerial
executeJson = PGS.execute_ conn . dropAndCreateTableJson
-- executeJsonb = PGS.execute_ conn . dropAndCreateTableJsonb
type Test = SpecWith PGS.Connection
testH :: D.Default O.QueryRunner wires haskells =>
Query wires
-> ([haskells] -> IO expectation)
-> PGS.Connection
-> IO expectation
testH q p conn = do
result <- O.runQuery conn q
p result
queryShouldReturnSorted :: (D.Default O.QueryRunner wires haskells, Show haskells, Ord haskells) =>
Query wires
-> [haskells]
-> PGS.Connection
-> Expectation
queryShouldReturnSorted q expected = testH q (\res -> L.sort res `shouldBe` L.sort expected)
testSelect :: Test
testSelect = it "selects" $ table1Q `queryShouldReturnSorted` table1data
testProduct :: Test
testProduct = it "joins tables" $ query `queryShouldReturnSorted` (A.liftA2 (,) table1data table2data)
where query = table1Q &&& table2Q
testRestrict :: Test
testRestrict = it "restricts the rows returned" $ query `queryShouldReturnSorted` filter ((== 1) . fst) (L.sort table1data)
where query = proc () -> do
t <- table1Q -< ()
O.restrict -< fst t .== 1
Arr.returnA -< t
testExists :: Test
testExists = it "restricts the rows returned with EXISTS" $ query `queryShouldReturnSorted` filter ((== 1) . fst) (L.sort table1data)
where query = proc () -> do
t <- table1Q -< ()
() <- O.exists (proc t -> do
t' <- table1Q -< ()
O.restrict -< fst t' .> fst t) -< t
Arr.returnA -< t
testNotExists :: Test
testNotExists = it "restricts the rows returned with NOT EXISTS" $ query `queryShouldReturnSorted` filter ((== 2) . fst) (L.sort table1data)
where query = proc () -> do
t <- table1Q -< ()
() <- O.notExists (proc t -> do
t' <- table1Q -< ()
O.restrict -< fst t' .> fst t) -< t
Arr.returnA -< t
testIn :: Test
testIn = it "restricts values to a range" $ query `queryShouldReturnSorted` filter (flip elem [100, 200] . snd) (L.sort table1data)
where query = proc () -> do
t <- table1Q -< ()
O.restrict -< O.in_ [O.pgInt4 100, O.pgInt4 200] (snd t)
O.restrict -< O.not (O.in_ [] (fst t)) -- Making sure empty lists work.
Arr.returnA -< t
testNum :: Test
testNum = it "" $ query `queryShouldReturnSorted` (map op table1data)
where query :: Query (Column O.PGInt4)
query = proc () -> do
t <- table1Q -< ()
Arr.returnA -< op t
op :: Num a => (a, a) -> a
op (x, y) = abs (x - 5) * signum (x - 4) * (y * y + 1)
testDiv :: Test
testDiv = it "" $ query `queryShouldReturnSorted` (map (op . toDoubles) table1data)
where query :: Query (Column O.PGFloat8)
query = proc () -> do
t <- Arr.arr (O.doubleOfInt *** O.doubleOfInt) <<< table1Q -< ()
Arr.returnA -< op t
op :: Fractional a => (a, a) -> a
-- Choosing 0.5 here as it should be exactly representable in
-- floating point
op (x, y) = y / x * 0.5
toDoubles :: (Int, Int) -> (Double, Double)
toDoubles = fromIntegral *** fromIntegral
-- TODO: need to implement and test case_ returning tuples
testCase :: Test
testCase = it "" $ q `queryShouldReturnSorted` expected
where q :: Query (Column O.PGInt4)
q = table1Q >>> proc (i, j) -> do
Arr.returnA -< O.case_ [(j .== 100, 12), (i .== 1, 21)] 33
expected :: [Int]
expected = [12, 12, 21, 33]
-- This tests case_ with an empty list of cases, to make sure it generates valid
-- SQL.
testCaseEmpty :: Test
testCaseEmpty = it "" $ q `queryShouldReturnSorted` expected
where q :: Query (Column O.PGInt4)
q = table1Q >>> proc _ ->
Arr.returnA -< O.case_ [] 33
expected :: [Int]
expected = [33, 33, 33, 33]
testDistinct :: Test
testDistinct = it "" $ O.distinct table1Q `queryShouldReturnSorted` (L.nub table1data)
-- FIXME: the unsafeCoerceColumn is currently needed because the type
-- changes required for aggregation are not currently dealt with by
-- Opaleye.
aggregateCoerceFIXME :: QueryArr (Column O.PGInt4) (Column O.PGInt8)
aggregateCoerceFIXME = Arr.arr aggregateCoerceFIXME'
aggregateCoerceFIXME' :: Column a -> Column O.PGInt8
aggregateCoerceFIXME' = O.unsafeCoerceColumn
testAggregate :: Test
testAggregate = it "" $ (Arr.second aggregateCoerceFIXME
<<< O.aggregate (PP.p2 (O.groupBy, O.sum))
table1Q) `queryShouldReturnSorted` [(1, 400) :: (Int, Int64), (2, 300)]
testAggregate0 :: Test
testAggregate0 = it "" $ (Arr.second aggregateCoerceFIXME
<<< O.aggregate (PP.p2 (O.sum, O.sum))
(O.keepWhen (const (O.pgBool False))
<<< table1Q)) `queryShouldReturnSorted` ([] :: [(Int, Int64)])
testAggregateFunction :: Test
testAggregateFunction = it "" $ (Arr.second aggregateCoerceFIXME
<<< O.aggregate (PP.p2 (O.groupBy, O.sum))
(fmap (\(x, y) -> (x + 1, y)) table1Q))
`queryShouldReturnSorted` [(2, 400) :: (Int, Int64), (3, 300)]
testAggregateProfunctor :: Test
testAggregateProfunctor = it "" $ q `queryShouldReturnSorted` [(1, 1200) :: (Int, Int64), (2, 300)]
where q = O.aggregate (PP.p2 (O.groupBy, countsum)) table1Q
countsum = P.dimap (\x -> (x,x))
(\(x, y) -> aggregateCoerceFIXME' x * y)
(PP.p2 (O.sum, O.count))
testStringArrayAggregate :: Test
testStringArrayAggregate = it "" $ q `queryShouldReturnSorted` [(map fst table6data, minimum (map snd table6data))]
where q = O.aggregate (PP.p2 (O.arrayAgg, O.min)) table6Q
testStringAggregate :: Test
testStringAggregate = it "" $ q `queryShouldReturnSorted` expected
where q = O.aggregate (PP.p2 ((O.stringAgg . O.pgString) "_", O.groupBy)) table6Q
expected = [(
(foldl1 (\x y -> x ++ "_" ++ y) . map fst) table6data ,
head (map snd table6data))]
-- | Using aggregateOrdered applies the ordering to all aggregates.
testStringArrayAggregateOrdered :: Test
testStringArrayAggregateOrdered = it "" $ q `queryShouldReturnSorted` expected
where q = O.aggregateOrdered (O.asc snd) (PP.p2 (O.arrayAgg, O.stringAgg . O.pgString $ ",")) table7Q
expected = [( map fst sortedData
, L.intercalate "," . map snd $ sortedData
)
]
sortedData = L.sortBy (Ord.comparing snd) table7data
-- | Using orderAggregate you can apply different orderings to
-- different aggregates.
testMultipleAggregateOrdered :: Test
testMultipleAggregateOrdered = it "" $ q `queryShouldReturnSorted` expected
where q = O.aggregate ((,) <$> IA.orderAggregate (O.asc snd)
(P.lmap fst O.arrayAgg)
<*> IA.orderAggregate (O.desc snd)
(P.lmap snd (O.stringAgg . O.pgString $ ","))
) table7Q
expected = [( map fst . L.sortBy (Ord.comparing snd) $ table7data
, L.intercalate "," . map snd . L.sortBy (Ord.comparing (Ord.Down . snd)) $ table7data
)
]
-- | Applying an order to an ordered aggregate overwrites the old
-- order, just like with ordered queries.
--
testOverwriteAggregateOrdered :: Test
testOverwriteAggregateOrdered = it "" $ q `queryShouldReturnSorted` expected
where q = O.aggregate ( IA.orderAggregate (O.asc snd)
. IA.orderAggregate (O.desc snd)
$ PP.p2 (O.arrayAgg, O.max)
) table7Q
expected = [( map fst (L.sortBy (Ord.comparing snd) table7data)
, maximum (map snd table7data)
)
]
testCountRows0 :: Test
testCountRows0 = it "" $ q `queryShouldReturnSorted` [0 :: Int64]
where q = O.countRows (O.keepWhen (const (O.pgBool False)) <<< table7Q)
testCountRows3 :: Test
testCountRows3 = it "" $ q `queryShouldReturnSorted` [3 :: Int64]
where q = O.countRows table7Q
queryShouldReturnSortBy :: O.Order (Column O.PGInt4, Column O.PGInt4)
-> ((Int, Int) -> (Int, Int) -> Ordering)
-> (PGS.Connection -> Expectation)
queryShouldReturnSortBy orderQ order = testH (O.orderBy orderQ table1Q)
(L.sortBy order table1data `shouldBe`)
testOrderBy :: Test
testOrderBy = it "" $ queryShouldReturnSortBy (O.desc snd)
(flip (Ord.comparing snd))
testOrderBy2 :: Test
testOrderBy2 = it "" $ queryShouldReturnSortBy (O.desc fst <> O.asc snd)
(flip (Ord.comparing fst) <> Ord.comparing snd)
testOrderBySame :: Test
testOrderBySame = it "" $ queryShouldReturnSortBy (O.desc fst <> O.asc fst)
(flip (Ord.comparing fst) <> Ord.comparing fst)
testOrderExact :: Test
testOrderExact = it "" $ testH (O.orderBy (O.exact cols snd) table1Q) (result `shouldBe`)
where cols = map O.constant [300,200::Int]
result = [ (2::Int, 300::Int)
, (1, 200)
, (1, 100)
, (1, 100)
]
limitOrderShouldMatch :: (Query (Column O.PGInt4, Column O.PGInt4) -> Query (Column O.PGInt4, Column O.PGInt4))
-> ([(Int, Int)] -> [(Int, Int)]) -> (PGS.Connection -> Expectation)
limitOrderShouldMatch olQ ol = testH (olQ (orderQ table1Q))
(ol (order table1data) `shouldBe`)
where orderQ = O.orderBy (O.desc snd)
order = L.sortBy (flip (Ord.comparing snd))
testLimit :: Test
testLimit = it "" $ limitOrderShouldMatch (O.limit 2) (take 2)
testOffset :: Test
testOffset = it "" $ limitOrderShouldMatch (O.offset 2) (drop 2)
testLimitOffset :: Test
testLimitOffset = it "" $ limitOrderShouldMatch (O.limit 2 . O.offset 2) (take 2 . drop 2)
testOffsetLimit :: Test
testOffsetLimit = it "" $ limitOrderShouldMatch (O.offset 2 . O.limit 2) (drop 2 . take 2)
testDistinctAndAggregate :: Test
testDistinctAndAggregate = it "" $ q `queryShouldReturnSorted` expectedResult
where q = O.distinct table1Q
&&& (Arr.second aggregateCoerceFIXME
<<< O.aggregate (PP.p2 (O.groupBy, O.sum)) table1Q)
expectedResult = A.liftA2 (,) (L.nub table1data)
[(1 :: Int, 400 :: Int64), (2, 300)]
one :: Query (Column O.PGInt4)
one = Arr.arr (const (1 :: Column O.PGInt4))
-- The point of the "double" tests is to ensure that we do not
-- introduce name clashes in the operations which create new column names
testDoubleH :: (Show haskells, Eq haskells, D.Default O.QueryRunner columns haskells) =>
(QueryArr () (Column O.PGInt4) -> QueryArr () columns) -> [haskells]
-> (PGS.Connection -> Expectation)
testDoubleH q expected1 = testH (q one &&& q one) (`shouldBe` expected2)
where expected2 = A.liftA2 (,) expected1 expected1
testDoubleDistinct :: Test
testDoubleDistinct = it "" $ testDoubleH O.distinct [1 :: Int]
testDoubleAggregate :: Test
testDoubleAggregate = it "" $ testDoubleH (O.aggregate O.count) [1 :: Int64]
testDoubleLeftJoin :: Test
testDoubleLeftJoin = it "" $ testDoubleH lj [(1 :: Int, Just (1 :: Int))]
where lj :: Query (Column O.PGInt4)
-> Query (Column O.PGInt4, Column (Nullable O.PGInt4))
lj q = O.leftJoin q q (uncurry (.==))
testDoubleValues :: Test
testDoubleValues = it "" $ testDoubleH v [1 :: Int]
where v :: Query (Column O.PGInt4) -> Query (Column O.PGInt4)
v _ = O.values [1]
testDoubleUnionAll :: Test
testDoubleUnionAll = it "" $ testDoubleH u [1 :: Int, 1]
where u q = q `O.unionAll` q
aLeftJoin :: Query ((Column O.PGInt4, Column O.PGInt4),
(Column (Nullable O.PGInt4), Column (Nullable O.PGInt4)))
aLeftJoin = O.leftJoin table1Q table3Q (\(l, r) -> fst l .== fst r)
testLeftJoin :: Test
testLeftJoin = it "" $ testH aLeftJoin (`shouldBe` expected)
where expected :: [((Int, Int), (Maybe Int, Maybe Int))]
expected = [ ((1, 100), (Just 1, Just 50))
, ((1, 100), (Just 1, Just 50))
, ((1, 200), (Just 1, Just 50))
, ((2, 300), (Nothing, Nothing)) ]
testLeftJoinNullable :: Test
testLeftJoinNullable = it "" $ testH q (`shouldBe` expected)
where q :: Query ((Column O.PGInt4, Column O.PGInt4),
((Column (Nullable O.PGInt4), Column (Nullable O.PGInt4)),
(Column (Nullable O.PGInt4),
Column (Nullable O.PGInt4))))
q = O.leftJoin table3Q aLeftJoin cond
cond (x, y) = fst x .== fst (fst y)
expected :: [((Int, Int), ((Maybe Int, Maybe Int), (Maybe Int, Maybe Int)))]
expected = [ ((1, 50), ((Just 1, Just 100), (Just 1, Just 50)))
, ((1, 50), ((Just 1, Just 100), (Just 1, Just 50)))
, ((1, 50), ((Just 1, Just 200), (Just 1, Just 50))) ]
testLeftJoinF :: Test
testLeftJoinF = it "" $ testH q (`shouldBe` expected)
where q = O.leftJoinF (,)
(\x -> (x, (-1, -2)))
(\l r -> fst l .== fst r)
table1Q
table3Q
expected :: [((Int, Int), (Int, Int))]
expected = [ ((1, 100), (1, 50))
, ((1, 100), (1, 50))
, ((1, 200), (1, 50))
, ((2, 300), (-1, -2)) ]
testThreeWayProduct :: Test
testThreeWayProduct = it "" $ testH q (`shouldBe` expected)
where q = A.liftA3 (,,) table1Q table2Q table3Q
expected = A.liftA3 (,,) table1data table2data table3data
testValues :: Test
testValues = it "" $ testH (O.values values) (values' `shouldBe`)
where values :: [(Column O.PGInt4, Column O.PGInt4)]
values = [ (1, 10)
, (2, 100) ]
values' :: [(Int, Int)]
values' = [ (1, 10)
, (2, 100) ]
{- FIXME: does not yet work
testValuesDouble :: Test
testValuesDouble = testG (O.values values) (values' ==)
where values :: [(Column O.PGInt4, Column O.PGFloat8)]
values = [ (1, 10.0)
, (2, 100.0) ]
values' :: [(Int, Double)]
values' = [ (1, 10.0)
, (2, 100.0) ]
-}
testValuesEmpty :: Test
testValuesEmpty = it "" $ testH (O.values values) (values' `shouldBe`)
where values :: [Column O.PGInt4]
values = []
values' :: [Int]
values' = []
testUnionAll :: Test
testUnionAll = it "" $ (table1Q `O.unionAll` table2Q) `queryShouldReturnSorted` (table1data ++ table2data)
testTableFunctor :: Test
testTableFunctor = it "" $ testH (O.queryTable table1F) (result `shouldBe`)
where result = fmap (\(col1, col2) -> (col1 + col2, col1 - col2)) table1data
-- TODO: This is getting too complicated
testUpdate :: Test
testUpdate = it "" $ \conn -> do
_ <- O.runUpdate conn table4 update cond
result <- runQueryTable4 conn
result `shouldBe` expected
_ <- O.runDelete conn table4 condD
resultD <- runQueryTable4 conn
resultD `shouldBe` expectedD
returned <- O.runInsertManyReturning conn table4 insertT returning
_ <- O.runInsertMany conn table4 insertTMany
resultI <- runQueryTable4 conn
resultI `shouldBe` expectedI
returned `shouldBe` expectedR
where update (x, y) = (x + y, x - y)
cond (_, y) = y .> 15
condD (x, _) = x .> 20
expected :: [(Int, Int)]
expected = [ (1, 10)
, (22, -18)]
expectedD :: [(Int, Int)]
expectedD = [(1, 10)]
runQueryTable4 conn = O.runQuery conn (O.queryTable table4)
insertT :: [(Column O.PGInt4, Column O.PGInt4)]
insertT = [(1, 2), (3, 5)]
insertTMany :: [(Column O.PGInt4, Column O.PGInt4)]
insertTMany = [(20, 30), (40, 50)]
expectedI :: [(Int, Int)]
expectedI = [(1, 10), (1, 2), (3, 5), (20, 30), (40, 50)]
returning (x, y) = x - y
expectedR :: [Int]
expectedR = [-1, -2]
testKeywordColNames :: Test
testKeywordColNames = it "" $ \conn -> do
let q :: IO [(Int, Int)]
q = O.runQuery conn (O.queryTable tableKeywordColNames)
_ <- q
True `shouldBe` True
testInsertSerial :: Test
testInsertSerial = it "" $ \conn -> do
_ <- O.runInsert conn table5 (Just 10, Just 20)
_ <- O.runInsert conn table5 (Just 30, Nothing)
_ <- O.runInsert conn table5 (Nothing, Nothing)
_ <- O.runInsert conn table5 (Nothing, Just 40)
resultI <- O.runQuery conn (O.queryTable table5)
resultI `shouldBe` expected
where expected :: [(Int, Int)]
expected = [ (10, 20)
, (30, 1)
, (1, 2)
, (2, 40) ]
testInQuery :: Test
testInQuery = it "" $ \conn -> do
let q (x, e) = testH (O.inQuery x (O.queryTable table1)) (`shouldBe` [e]) conn
mapM_ (q . (\x -> (x, True))) table1dataG
mapM_ (q . (\(x, y) -> ((x, y+1), False))) table1dataG
-- and r && and s `shouldBe` True
testAtTimeZone :: Test
testAtTimeZone = it "" $ testH (A.pure (O.timestamptzAtTimeZone t (O.pgString "CET"))) (`shouldBe` [t'])
where t = O.pgUTCTime (Time.UTCTime d (Time.secondsToDiffTime 3600))
t' = Time.LocalTime d (Time.TimeOfDay 2 0 0)
d = Time.fromGregorian 2015 1 1
testArrayLiterals :: Test
testArrayLiterals = it "" $ testH (A.pure $ O.pgArray O.pgInt4 vals) (`shouldBe` [vals])
where vals = [1,2,3]
-- This test fails without the explicit cast in pgArray since postgres
-- can't determine the type of the array.
testEmptyArray :: Test
testEmptyArray = it "" $ testH (A.pure $ O.pgArray O.pgInt4 []) (`shouldBe` [[] :: [Int]])
-- This test fails without the explicit cast in pgArray since postgres
-- defaults the numbers to 'integer' but postgresql-simple expects 'float8'.
testFloatArray :: Test
testFloatArray = it "" $ testH (A.pure $ O.pgArray O.pgDouble doubles) (`shouldBe` [doubles])
where
doubles = [1 :: Double, 2]
testArrayIndex :: Test
testArrayIndex = it "correctly indexes an array" $
testH (A.pure $ O.pgArray O.pgInt4 [5,6,7] `O.index` O.pgInt4 3)
(`shouldBe` ([Just 7] :: [Maybe Int]))
testArrayIndexOOB :: Test
testArrayIndexOOB = it "returns Nothing when the index is out of bounds" $
testH (A.pure $ O.pgArray O.pgInt4 [5,6,7] `O.index` O.pgInt4 8)
(`shouldBe` ([Nothing] :: [Maybe Int]))
type JsonTest a = SpecWith (Query (Column a) -> PGS.Connection -> Expectation)
-- Test opaleye's equivalent of c1->'c'
testJsonGetFieldValue :: (O.PGIsJson a, O.QueryRunnerColumnDefault a Json.Value) => Query (Column a) -> Test
testJsonGetFieldValue dataQuery = it "" $ testH q (`shouldBe` expected)
where q = dataQuery >>> proc c1 -> do
Arr.returnA -< O.toNullable c1 O..-> O.pgStrictText "c"
expected :: [Maybe Json.Value]
expected = [Just $ Json.Number $ fromInteger 21]
-- Test opaleye's equivalent of c1->>'c'
testJsonGetFieldText :: (O.PGIsJson a) => Query (Column a) -> Test
testJsonGetFieldText dataQuery = it "" $ testH q (`shouldBe` expected)
where q = dataQuery >>> proc c1 -> do
Arr.returnA -< O.toNullable c1 O..->> O.pgStrictText "c"
expected :: [Maybe T.Text]
expected = [Just "21"]
-- Test opaleye's equivalent of c1->'a'->2
testJsonGetArrayValue :: (O.PGIsJson a, O.QueryRunnerColumnDefault a Json.Value) => Query (Column a) -> Test
testJsonGetArrayValue dataQuery = it "" $ testH q (`shouldBe` expected)
where q = dataQuery >>> proc c1 -> do
Arr.returnA -< O.toNullable c1 O..-> O.pgStrictText "a" O..-> O.pgInt4 2
expected :: [Maybe Json.Value]
expected = [Just $ Json.Number $ fromInteger 30]
-- Test opaleye's equivalent of c1->'a'->>2
testJsonGetArrayText :: (O.PGIsJson a) => Query (Column a) -> Test
testJsonGetArrayText dataQuery = it "" $ testH q (`shouldBe` expected)
where q = dataQuery >>> proc c1 -> do
Arr.returnA -< O.toNullable c1 O..-> O.pgStrictText "a" O..->> O.pgInt4 2
expected :: [Maybe T.Text]
expected = [Just "30"]
-- Test opaleye's equivalent of c1->>'missing'
-- Note that the missing field does not exist.
testJsonGetMissingField :: (O.PGIsJson a) => Query (Column a) -> Test
testJsonGetMissingField dataQuery = it "" $ testH q (`shouldBe` expected)
where q = dataQuery >>> proc c1 -> do
Arr.returnA -< O.toNullable c1 O..->> O.pgStrictText "missing"
expected :: [Maybe T.Text]
expected = [Nothing]
-- Test opaleye's equivalent of c1#>'{b,x}'
testJsonGetPathValue :: (O.PGIsJson a, O.QueryRunnerColumnDefault a Json.Value) => Query (Column a) -> Test
testJsonGetPathValue dataQuery = it "" $ testH q (`shouldBe` expected)
where q = dataQuery >>> proc c1 -> do
Arr.returnA -< O.toNullable c1 O..#> O.pgArray O.pgStrictText ["b", "x"]
expected :: [Maybe Json.Value]
expected = [Just $ Json.Number $ fromInteger 42]
-- Test opaleye's equivalent of c1#>>'{b,x}'
testJsonGetPathText :: (O.PGIsJson a) => Query (Column a) -> Test
testJsonGetPathText dataQuery = it "" $ testH q (`shouldBe` expected)
where q = dataQuery >>> proc c1 -> do
Arr.returnA -< O.toNullable c1 O..#>> O.pgArray O.pgStrictText ["b", "x"]
expected :: [Maybe T.Text]
expected = [Just "42"]
-- Test opaleye's equivalent of c1 @> '{"c":21}'::jsonb
testJsonbRightInLeft :: Test
testJsonbRightInLeft = it "" $ testH q (`shouldBe` [True])
where q = table9Q >>> proc c1 -> do
Arr.returnA -< c1 O..@> O.pgJSONB "{\"c\":21}"
-- Test opaleye's equivalent of '{"c":21}'::jsonb <@ c1
testJsonbLeftInRight :: Test
testJsonbLeftInRight = it "" $ testH q (`shouldBe` [True])
where q = table9Q >>> proc c1 -> do
Arr.returnA -< O.pgJSONB "{\"c\":21}" O..<@ c1
-- Test opaleye's equivalent of c1 ? 'b'
testJsonbContains :: Test
testJsonbContains = it "" $ testH q (`shouldBe` [True])
where q = table9Q >>> proc c1 -> do
Arr.returnA -< c1 O..? O.pgStrictText "c"
-- Test opaleye's equivalent of c1 ? 'missing'
-- Note that the missing field does not exist.
testJsonbContainsMissing :: Test
testJsonbContainsMissing = it "" $ testH q (`shouldBe` [False])
where q = table9Q >>> proc c1 -> do
Arr.returnA -< c1 O..? O.pgStrictText "missing"
-- Test opaleye's equivalent of c1 ?| array['b', 'missing']
testJsonbContainsAny :: Test
testJsonbContainsAny = it "" $ testH q (`shouldBe` [True])
where q = table9Q >>> proc c1 -> do
Arr.returnA -< c1 O..?| O.pgArray O.pgStrictText ["b", "missing"]
-- Test opaleye's equivalent of c1 ?& array['a', 'b', 'c']
testJsonbContainsAll :: Test
testJsonbContainsAll = it "" $ testH q (`shouldBe` [True])
where q = table9Q >>> proc c1 -> do
Arr.returnA -< c1 O..?& O.pgArray O.pgStrictText ["a", "b", "c"]
testRangeOverlap :: Test
testRangeOverlap = it "generates overlap" $ testH q (`shouldBe` [True])
where range :: Int -> Int -> Column (O.PGRange O.PGInt4)
range a b = O.pgRange O.pgInt4 (R.Inclusive a) (R.Inclusive b)
q = A.pure $ (range 3 7) `O.overlap` (range 4 12)
testRangeLeftOf :: Test
testRangeLeftOf = it "generates 'left of'" $ testH q (`shouldBe` [True])
where range :: Int -> Int -> Column (O.PGRange O.PGInt4)
range a b = O.pgRange O.pgInt4 (R.Inclusive a) (R.Inclusive b)
q = A.pure $ (range 1 10) O..<< (range 100 110)
testRangeRightOf :: Test
testRangeRightOf = it "generates 'right of'" $ testH q (`shouldBe` [True])
where range :: Int -> Int -> Column (O.PGRange O.PGInt4)
range a b = O.pgRange O.pgInt4 (R.Inclusive a) (R.Inclusive b)
q = A.pure $ (range 50 60) O..>> (range 20 30)
testRangeRightExtension :: Test
testRangeRightExtension = it "generates right extension" $ testH q (`shouldBe` [True])
where range :: Int -> Int -> Column (O.PGRange O.PGInt4)
range a b = O.pgRange O.pgInt4 (R.Inclusive a) (R.Inclusive b)
q = A.pure $ (range 1 20) O..&< (range 18 20)
testRangeLeftExtension :: Test
testRangeLeftExtension = it "generates left extension" $ testH q (`shouldBe` [True])
where range :: Int -> Int -> Column (O.PGRange O.PGInt4)
range a b = O.pgRange O.pgInt4 (R.Inclusive a) (R.Inclusive b)
q = A.pure $ (range 7 20) O..&> (range 5 10)
testRangeAdjacency :: Test
testRangeAdjacency = it "generates adjacency" $ testH q (`shouldBe` [True])
where range :: Int -> Int -> Column (O.PGRange O.PGInt4)
range a b = O.pgRange O.pgInt4 (R.Inclusive a) (R.Exclusive b)
q = A.pure $ (range 1 2) O..-|- (range 2 3)
-- Note: these tests are left out of allTests until Travis supports
-- Postgresql >= 9.4
jsonbTests :: [Test]
jsonbTests = [testJsonGetFieldValue table9Q,testJsonGetFieldText table9Q,
testJsonGetMissingField table9Q,testJsonGetArrayValue table9Q,
testJsonGetArrayText table9Q,testJsonGetPathValue table9Q,
testJsonGetPathText table9Q,
testJsonbRightInLeft, testJsonbLeftInRight,
testJsonbContains, testJsonbContainsMissing,
testJsonbContainsAny, testJsonbContainsAll
]
main :: IO ()
main = do
let envVarName = "POSTGRES_CONNSTRING"
connectStringEnvVar <- lookupEnv envVarName
connectStringDotEnv <- do vars <- Dotenv.parseFile ".env"
return (lookup envVarName vars)
`Dotenv.onMissingFile`
return Nothing
let connectString = connectStringEnvVar <|> connectStringDotEnv
conn <- maybe
(fail ("Set " ++ envVarName ++ " environment variable\n"
++ "For example " ++ envVarName ++ "='user=tom dbname=opaleye_test "
++ "host=localhost port=25433 password=tom'"))
(PGS.connectPostgreSQL . String.fromString)
connectString
dropAndCreateDB conn
let insert (writeable, columndata) =
mapM_ (O.runInsert conn writeable) columndata
mapM_ insert [ (table1, table1columndata)
, (table2, table2columndata)
, (table3, table3columndata)
, (table4, table4columndata) ]
insert (table6, table6columndata)
insert (table7, table7columndata)
insert (table8, table8columndata)
-- Disabled until Travis supports Postgresql >= 9.4
-- insert (table9, table9columndata)
-- Need to run quickcheck after table data has been inserted
QuickCheck.run conn
hspec $ do
before (return conn) $ do
describe "core dsl?" $ do
testSelect
testProduct
testRestrict
testExists
testNotExists
testIn
testNum
testDiv
describe "cases" $ do
testCase
testCaseEmpty
describe "aggregate" $ do
testAggregate
testAggregate0
testAggregateFunction
testAggregateProfunctor
testStringArrayAggregate
testStringAggregate
testOverwriteAggregateOrdered
testMultipleAggregateOrdered
testStringArrayAggregateOrdered
testDistinctAndAggregate
testDoubleAggregate
describe "distinct" $ do
testDistinct
describe "order" $ do
testOrderBy
testOrderBy2
testOrderBySame
testOrderExact
describe "count" $ do
testCountRows0
testCountRows3
describe "limit" $ do
testLimit
testOffset
testLimitOffset
testOffsetLimit
describe "double" $ do
testDoubleDistinct
testDoubleLeftJoin
testDoubleValues
testDoubleUnionAll
describe "arrays" $ do
testArrayLiterals
testEmptyArray
testFloatArray
testArrayIndex
testArrayIndexOOB
describe "joins" $ do
testLeftJoin
testLeftJoinNullable
testThreeWayProduct
testLeftJoinF
describe "json" $ do
testJsonGetFieldValue table8Q
testJsonGetFieldText table8Q
testJsonGetMissingField table8Q
testJsonGetArrayValue table8Q
testJsonGetArrayText table8Q
testJsonGetPathValue table8Q
testJsonGetPathText table8Q
describe "uncat" $ do
testKeywordColNames
testInsertSerial
testInQuery
testAtTimeZone
testUnionAll
testTableFunctor
testValues
testValuesEmpty
testUpdate
describe "range" $ do
testRangeOverlap
testRangeLeftOf
testRangeRightOf
testRangeRightExtension
testRangeLeftExtension
testRangeAdjacency