2a44844f75
* Add PostgreSQL-specific support of VALUES(..) scalar expression of values-list for `from` targets. * Bump version and update changelog * Align identation for Postgres `values` func * Use direct `From` data-type instead of `ToFrom` typeclass for postgres `values` expression.
1473 lines
57 KiB
Haskell
1473 lines
57 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-unused-binds #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE PartialTypeSignatures #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
|
|
module PostgreSQL.Test where
|
|
|
|
import Control.Arrow ((&&&))
|
|
import Control.Monad (void, when)
|
|
import Control.Monad.IO.Class (MonadIO(liftIO))
|
|
import Control.Monad.Logger (runNoLoggingT, runStderrLoggingT)
|
|
import Control.Monad.Trans.Reader (ReaderT, ask, mapReaderT)
|
|
import qualified Control.Monad.Trans.Resource as R
|
|
import Data.Aeson hiding (Value)
|
|
import qualified Data.Aeson as A (Value)
|
|
import Data.ByteString (ByteString)
|
|
import qualified Data.ByteString.Lazy as BSL
|
|
import qualified Data.Char as Char
|
|
import Data.Coerce
|
|
import Data.Foldable
|
|
import qualified Data.List as L
|
|
import qualified Data.List.NonEmpty as NE
|
|
import Data.Map (Map)
|
|
import qualified Data.Map.Strict as Map
|
|
import Data.Ord (comparing)
|
|
import qualified Data.Text as T
|
|
import qualified Data.Text.Encoding as TE
|
|
import Data.Time
|
|
import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime)
|
|
import Database.Esqueleto hiding (random_)
|
|
import Database.Esqueleto.Experimental hiding (from, on, random_)
|
|
import qualified Database.Esqueleto.Experimental as Experimental
|
|
import qualified Database.Esqueleto.Internal.Internal as ES
|
|
import Database.Esqueleto.PostgreSQL (random_)
|
|
import qualified Database.Esqueleto.PostgreSQL as EP
|
|
import Database.Esqueleto.PostgreSQL.JSON hiding ((-.), (?.), (||.))
|
|
import qualified Database.Esqueleto.PostgreSQL.JSON as JSON
|
|
import Database.Persist.Postgresql (withPostgresqlConn, createPostgresqlPool)
|
|
import Database.PostgreSQL.Simple (ExecStatus(..), SqlError(..))
|
|
import System.Environment
|
|
import Test.Hspec
|
|
import Test.Hspec.QuickCheck
|
|
|
|
import Common.Test
|
|
import Common.Test.Import hiding (from, on)
|
|
import PostgreSQL.MigrateJSON
|
|
|
|
returningType :: forall a m . m a -> m a
|
|
returningType a = a
|
|
|
|
testPostgresqlCoalesce :: SpecDb
|
|
testPostgresqlCoalesce = do
|
|
itDb "works on PostgreSQL and MySQL with <2 arguments" $ do
|
|
void $ returningType @[Value (Maybe Int)] $
|
|
select $
|
|
from $ \p -> do
|
|
return (coalesce [p ^. PersonAge])
|
|
asserting noExceptions
|
|
|
|
testPostgresqlTextFunctions :: SpecDb
|
|
testPostgresqlTextFunctions = do
|
|
describe "text functions" $ do
|
|
itDb "like, (%) and (++.) work on a simple example" $ do
|
|
let nameContains t =
|
|
select $
|
|
from $ \p -> do
|
|
where_
|
|
(like
|
|
(p ^. PersonName)
|
|
((%) ++. val t ++. (%)))
|
|
orderBy [asc (p ^. PersonName)]
|
|
return p
|
|
[p1e, p2e, p3e, p4e] <- mapM insert' [p1, p2, p3, p4]
|
|
h <- nameContains "h"
|
|
i <- nameContains "i"
|
|
iv <- nameContains "iv"
|
|
asserting $ do
|
|
h `shouldBe` [p1e, p2e]
|
|
i `shouldBe` [p4e, p3e]
|
|
iv `shouldBe` [p4e]
|
|
|
|
itDb "ilike, (%) and (++.) work on a simple example on PostgreSQL" $ do
|
|
[p1e, _, p3e, _, p5e] <- mapM insert' [p1, p2, p3, p4, p5]
|
|
let nameContains t = do
|
|
select $
|
|
from $ \p -> do
|
|
where_ (p ^. PersonName `ilike` (%) ++. val t ++. (%))
|
|
orderBy [asc (p ^. PersonName)]
|
|
return p
|
|
mi <- nameContains "mi"
|
|
john <- nameContains "JOHN"
|
|
asserting $ do
|
|
mi `shouldBe` [p3e, p5e]
|
|
john `shouldBe` [p1e]
|
|
|
|
testPostgresqlUpdate :: SpecDb
|
|
testPostgresqlUpdate = do
|
|
itDb "works on a simple example" $ do
|
|
p1k <- insert p1
|
|
p2k <- insert p2
|
|
p3k <- insert p3
|
|
let anon = "Anonymous"
|
|
() <- update $ \p -> do
|
|
set p [ PersonName =. val anon
|
|
, PersonAge *=. just (val 2) ]
|
|
where_ (p ^. PersonName !=. val "Mike")
|
|
n <- updateCount $ \p -> do
|
|
set p [ PersonAge +=. just (val 1) ]
|
|
where_ (p ^. PersonName !=. val "Mike")
|
|
ret <- select $
|
|
from $ \p -> do
|
|
orderBy [ asc (p ^. PersonName), asc (p ^. PersonAge) ]
|
|
return p
|
|
-- PostgreSQL: nulls are bigger than data, and update returns
|
|
-- matched rows, not actually changed rows.
|
|
asserting $ do
|
|
n `shouldBe` 2
|
|
ret `shouldBe`
|
|
[ Entity p1k (Person anon (Just 73) Nothing 1)
|
|
, Entity p2k (Person anon Nothing (Just 37) 2)
|
|
, Entity p3k p3
|
|
]
|
|
|
|
testPostgresqlRandom :: SpecDb
|
|
testPostgresqlRandom = do
|
|
itDb "works with random_" $ do
|
|
_ <- select $ return (random_ :: SqlExpr (Value Double))
|
|
asserting noExceptions
|
|
|
|
testPostgresqlSum :: SpecDb
|
|
testPostgresqlSum = do
|
|
itDb "works with sum_" $ do
|
|
_ <- insert' p1
|
|
_ <- insert' p2
|
|
_ <- insert' p3
|
|
_ <- insert' p4
|
|
ret <- select $
|
|
from $ \p->
|
|
return $ joinV $ sum_ (p ^. PersonAge)
|
|
asserting $ ret `shouldBe` [ Value $ Just (36 + 17 + 17 :: Rational ) ]
|
|
|
|
testPostgresqlTwoAscFields :: SpecDb
|
|
testPostgresqlTwoAscFields = do
|
|
itDb "works with two ASC fields (one call)" $ do
|
|
p1e <- insert' p1
|
|
p2e <- insert' p2
|
|
p3e <- insert' p3
|
|
p4e <- insert' p4
|
|
ret <- select $
|
|
from $ \p -> do
|
|
orderBy [asc (p ^. PersonAge), asc (p ^. PersonName)]
|
|
return p
|
|
-- in PostgreSQL nulls are bigger than everything
|
|
asserting $ ret `shouldBe` [ p4e, p3e, p1e , p2e ]
|
|
|
|
testPostgresqlOneAscOneDesc :: SpecDb
|
|
testPostgresqlOneAscOneDesc = do
|
|
itDb "works with one ASC and one DESC field (two calls)" $
|
|
do
|
|
p1e <- insert' p1
|
|
p2e <- insert' p2
|
|
p3e <- insert' p3
|
|
p4e <- insert' p4
|
|
ret <- select $
|
|
from $ \p -> do
|
|
orderBy [desc (p ^. PersonAge)]
|
|
orderBy [asc (p ^. PersonName)]
|
|
return p
|
|
asserting $ ret `shouldBe` [ p2e, p1e, p4e, p3e ]
|
|
|
|
testSelectDistinctOn :: SpecDb
|
|
testSelectDistinctOn = do
|
|
describe "SELECT DISTINCT ON" $ do
|
|
itDb "works on a simple example" $ do
|
|
do
|
|
[p1k, p2k, _] <- mapM insert [p1, p2, p3]
|
|
[_, bpB, bpC] <- mapM insert'
|
|
[ BlogPost "A" p1k
|
|
, BlogPost "B" p1k
|
|
, BlogPost "C" p2k ]
|
|
ret <- select $
|
|
from $ \bp ->
|
|
distinctOn [don (bp ^. BlogPostAuthorId)] $ do
|
|
orderBy [asc (bp ^. BlogPostAuthorId), desc (bp ^. BlogPostTitle)]
|
|
return bp
|
|
liftIO $ ret `shouldBe` L.sortBy (comparing (blogPostAuthorId . entityVal)) [bpB, bpC]
|
|
|
|
let slightlyLessSimpleTest q =
|
|
do
|
|
[p1k, p2k, _] <- mapM insert [p1, p2, p3]
|
|
[bpA, bpB, bpC] <- mapM insert'
|
|
[ BlogPost "A" p1k
|
|
, BlogPost "B" p1k
|
|
, BlogPost "C" p2k ]
|
|
ret <- select $
|
|
from $ \bp ->
|
|
q bp $ return bp
|
|
let cmp = (blogPostAuthorId &&& blogPostTitle) . entityVal
|
|
liftIO $ ret `shouldBe` L.sortBy (comparing cmp) [bpA, bpB, bpC]
|
|
|
|
itDb "works on a slightly less simple example (two distinctOn calls, orderBy)" $
|
|
slightlyLessSimpleTest $ \bp act ->
|
|
distinctOn [don (bp ^. BlogPostAuthorId)] $
|
|
distinctOn [don (bp ^. BlogPostTitle)] $ do
|
|
orderBy [asc (bp ^. BlogPostAuthorId), asc (bp ^. BlogPostTitle)]
|
|
act
|
|
|
|
itDb "works on a slightly less simple example (one distinctOn call, orderBy)" $ do
|
|
slightlyLessSimpleTest $ \bp act ->
|
|
distinctOn [don (bp ^. BlogPostAuthorId), don (bp ^. BlogPostTitle)] $ do
|
|
orderBy [asc (bp ^. BlogPostAuthorId), asc (bp ^. BlogPostTitle)]
|
|
act
|
|
|
|
itDb "works on a slightly less simple example (distinctOnOrderBy)" $ do
|
|
slightlyLessSimpleTest $ \bp ->
|
|
distinctOnOrderBy [asc (bp ^. BlogPostAuthorId), asc (bp ^. BlogPostTitle)]
|
|
|
|
itDb "generates correct sql with nested expression (distinctOnOrderBy)" $ do
|
|
let query = do
|
|
let orderVal = coalesce [nothing, just $ val (10 :: Int)]
|
|
distinctOnOrderBy [ asc orderVal, desc orderVal ] $ pure orderVal
|
|
select query
|
|
asserting noExceptions
|
|
|
|
|
|
|
|
|
|
testArrayAggWith :: SpecDb
|
|
testArrayAggWith = do
|
|
describe "ALL, no ORDER BY" $ do
|
|
itDb "creates sane SQL" $ do
|
|
(query, args) <- showQuery ES.SELECT $ from $ \p ->
|
|
return (EP.arrayAggWith EP.AggModeAll (p ^. PersonAge) [])
|
|
liftIO $ query `shouldBe`
|
|
"SELECT array_agg(\"Person\".\"age\")\n\
|
|
\FROM \"Person\"\n"
|
|
liftIO $ args `shouldBe` []
|
|
|
|
itDb "works on an example" $ do
|
|
let people = [p1, p2, p3, p4, p5]
|
|
mapM_ insert people
|
|
[Value (Just ret)] <-
|
|
select $ from $ \p ->
|
|
return (EP.arrayAggWith EP.AggModeAll (p ^. PersonName) [])
|
|
liftIO $ L.sort ret `shouldBe` L.sort (map personName people)
|
|
|
|
describe "DISTINCT, no ORDER BY" $ do
|
|
itDb "creates sane SQL" $ do
|
|
(query, args) <- showQuery ES.SELECT $ from $ \p ->
|
|
return (EP.arrayAggWith EP.AggModeDistinct (p ^. PersonAge) [])
|
|
liftIO $ query `shouldBe`
|
|
"SELECT array_agg(DISTINCT \"Person\".\"age\")\n\
|
|
\FROM \"Person\"\n"
|
|
liftIO $ args `shouldBe` []
|
|
|
|
itDb "works on an example" $ do
|
|
let people = [p1, p2, p3, p4, p5]
|
|
mapM_ insert people
|
|
[Value (Just ret)] <-
|
|
select $ from $ \p ->
|
|
return (EP.arrayAggWith EP.AggModeDistinct (p ^. PersonAge) [])
|
|
liftIO $ L.sort ret `shouldBe` [Nothing, Just 17, Just 36]
|
|
|
|
describe "ALL, ORDER BY" $ do
|
|
itDb "creates sane SQL" $ do
|
|
(query, args) <- showQuery ES.SELECT $ from $ \p ->
|
|
return (EP.arrayAggWith EP.AggModeAll (p ^. PersonAge)
|
|
[ asc $ p ^. PersonName
|
|
, desc $ p ^. PersonFavNum
|
|
])
|
|
liftIO $ query `shouldBe`
|
|
"SELECT array_agg(\"Person\".\"age\" \
|
|
\ORDER BY \"Person\".\"name\" ASC, \"Person\".\"favNum\" DESC)\n\
|
|
\FROM \"Person\"\n"
|
|
liftIO $ args `shouldBe` []
|
|
|
|
itDb "works on an example" $ do
|
|
let people = [p1, p2, p3, p4, p5]
|
|
mapM_ insert people
|
|
[Value (Just ret)] <-
|
|
select $ from $ \p ->
|
|
return (EP.arrayAggWith EP.AggModeAll (p ^. PersonName) [])
|
|
liftIO $ L.sort ret `shouldBe` L.sort (map personName people)
|
|
|
|
describe "DISTINCT, ORDER BY" $ do
|
|
itDb "creates sane SQL" $ do
|
|
(query, args) <- showQuery ES.SELECT $ from $ \p ->
|
|
return (EP.arrayAggWith EP.AggModeDistinct (p ^. PersonAge)
|
|
[asc $ p ^. PersonAge])
|
|
liftIO $ query `shouldBe`
|
|
"SELECT array_agg(DISTINCT \"Person\".\"age\" \
|
|
\ORDER BY \"Person\".\"age\" ASC)\n\
|
|
\FROM \"Person\"\n"
|
|
liftIO $ args `shouldBe` []
|
|
|
|
itDb "works on an example" $ do
|
|
let people = [p1, p2, p3, p4, p5]
|
|
mapM_ insert people
|
|
[Value (Just ret)] <-
|
|
select $ from $ \p ->
|
|
return (EP.arrayAggWith EP.AggModeDistinct (p ^. PersonAge)
|
|
[asc $ p ^. PersonAge])
|
|
liftIO $ ret `shouldBe` [Just 17, Just 36, Nothing]
|
|
|
|
|
|
|
|
|
|
|
|
testStringAggWith :: SpecDb
|
|
testStringAggWith = do
|
|
describe "ALL, no ORDER BY" $ do
|
|
itDb "creates sane SQL" $ do
|
|
(query, args) <- showQuery ES.SELECT $ from $ \p ->
|
|
return (EP.stringAggWith EP.AggModeAll (p ^. PersonName)
|
|
(val " ") [])
|
|
liftIO $ query `shouldBe`
|
|
"SELECT string_agg(\"Person\".\"name\", ?)\n\
|
|
\FROM \"Person\"\n"
|
|
liftIO $ args `shouldBe` [PersistText " "]
|
|
|
|
itDb "works on an example" $ do
|
|
let people = [p1, p2, p3, p4, p5]
|
|
mapM_ insert people
|
|
[Value (Just ret)] <-
|
|
select $ from $ \p ->
|
|
return (EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ")[])
|
|
liftIO $ (L.sort $ words ret) `shouldBe` L.sort (map personName people)
|
|
|
|
itDb "works with zero rows" $ do
|
|
[Value ret] <-
|
|
select $ from $ \p ->
|
|
return (EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ")[])
|
|
liftIO $ ret `shouldBe` Nothing
|
|
|
|
describe "DISTINCT, no ORDER BY" $ do
|
|
itDb "creates sane SQL" $ do
|
|
(query, args) <- showQuery ES.SELECT $ from $ \p ->
|
|
return $ EP.stringAggWith EP.AggModeDistinct (p ^. PersonName)
|
|
(val " ") []
|
|
liftIO $ query `shouldBe`
|
|
"SELECT string_agg(DISTINCT \"Person\".\"name\", ?)\n\
|
|
\FROM \"Person\"\n"
|
|
liftIO $ args `shouldBe` [PersistText " "]
|
|
|
|
itDb "works on an example" $ do
|
|
let people = [p1, p2, p3 {personName = "John"}, p4, p5]
|
|
mapM_ insert people
|
|
[Value (Just ret)] <-
|
|
select $ from $ \p ->
|
|
return $ EP.stringAggWith EP.AggModeDistinct (p ^. PersonName) (val " ")
|
|
[]
|
|
liftIO $ (L.sort $ words ret) `shouldBe`
|
|
(L.sort . L.nub $ map personName people)
|
|
|
|
describe "ALL, ORDER BY" $ do
|
|
itDb "creates sane SQL" $ do
|
|
(query, args) <- showQuery ES.SELECT $ from $ \p ->
|
|
return (EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ")
|
|
[ asc $ p ^. PersonName
|
|
, desc $ p ^. PersonFavNum
|
|
])
|
|
liftIO $ query `shouldBe`
|
|
"SELECT string_agg(\"Person\".\"name\", ? \
|
|
\ORDER BY \"Person\".\"name\" ASC, \"Person\".\"favNum\" DESC)\n\
|
|
\FROM \"Person\"\n"
|
|
liftIO $ args `shouldBe` [PersistText " "]
|
|
|
|
itDb "works on an example" $ do
|
|
let people = [p1, p2, p3, p4, p5]
|
|
mapM_ insert people
|
|
[Value (Just ret)] <-
|
|
select $ from $ \p ->
|
|
return $ EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ")
|
|
[desc $ p ^. PersonName]
|
|
liftIO $ (words ret)
|
|
`shouldBe` (L.reverse . L.sort $ map personName people)
|
|
|
|
describe "DISTINCT, ORDER BY" $ do
|
|
itDb "creates sane SQL" $ do
|
|
(query, args) <- showQuery ES.SELECT $ from $ \p ->
|
|
return $ EP.stringAggWith EP.AggModeDistinct (p ^. PersonName)
|
|
(val " ") [desc $ p ^. PersonName]
|
|
liftIO $ query `shouldBe`
|
|
"SELECT string_agg(DISTINCT \"Person\".\"name\", ? \
|
|
\ORDER BY \"Person\".\"name\" DESC)\n\
|
|
\FROM \"Person\"\n"
|
|
liftIO $ args `shouldBe` [PersistText " "]
|
|
|
|
itDb "works on an example" $ do
|
|
let people = [p1, p2, p3 {personName = "John"}, p4, p5]
|
|
mapM_ insert people
|
|
[Value (Just ret)] <-
|
|
select $ from $ \p ->
|
|
return $ EP.stringAggWith EP.AggModeDistinct (p ^. PersonName) (val " ")
|
|
[desc $ p ^. PersonName]
|
|
liftIO $ (words ret) `shouldBe`
|
|
(L.reverse . L.sort . L.nub $ map personName people)
|
|
|
|
|
|
|
|
|
|
|
|
testAggregateFunctions :: SpecDb
|
|
testAggregateFunctions = do
|
|
describe "arrayAgg" $ do
|
|
itDb "looks sane" $ do
|
|
let people = [p1, p2, p3, p4, p5]
|
|
mapM_ insert people
|
|
[Value (Just ret)] <-
|
|
select $ from $ \p -> return (EP.arrayAgg (p ^. PersonName))
|
|
liftIO $ L.sort ret `shouldBe` L.sort (map personName people)
|
|
|
|
itDb "works on zero rows" $ do
|
|
[Value ret] <-
|
|
select $ from $ \p -> return (EP.arrayAgg (p ^. PersonName))
|
|
liftIO $ ret `shouldBe` Nothing
|
|
describe "arrayAggWith" testArrayAggWith
|
|
describe "stringAgg" $ do
|
|
itDb "looks sane" $
|
|
do
|
|
let people = [p1, p2, p3, p4, p5]
|
|
mapM_ insert people
|
|
[Value (Just ret)] <-
|
|
select $
|
|
from $ \p -> do
|
|
return (EP.stringAgg (p ^. PersonName) (val " "))
|
|
liftIO $ L.sort (words ret) `shouldBe` L.sort (map personName people)
|
|
itDb "works on zero rows" $ do
|
|
[Value ret] <-
|
|
select $ from $ \p -> return (EP.stringAgg (p ^. PersonName) (val " "))
|
|
liftIO $ ret `shouldBe` Nothing
|
|
describe "stringAggWith" testStringAggWith
|
|
|
|
describe "array_remove (NULL)" $ do
|
|
itDb "removes NULL from arrays from nullable fields" $ do
|
|
mapM_ insert [ Person "1" Nothing Nothing 1
|
|
, Person "2" (Just 7) Nothing 1
|
|
, Person "3" (Nothing) Nothing 1
|
|
, Person "4" (Just 8) Nothing 2
|
|
, Person "5" (Just 9) Nothing 2
|
|
]
|
|
ret <- select $ from $ \(person :: SqlExpr (Entity Person)) -> do
|
|
groupBy (person ^. PersonFavNum)
|
|
return . EP.arrayRemoveNull . EP.maybeArray . EP.arrayAgg
|
|
$ person ^. PersonAge
|
|
liftIO $ (L.sort $ map (L.sort . unValue) ret)
|
|
`shouldBe` [[7], [8,9]]
|
|
|
|
describe "maybeArray" $ do
|
|
itDb "Coalesces NULL into an empty array" $ do
|
|
[Value ret] <-
|
|
select $ from $ \p ->
|
|
return (EP.maybeArray $ EP.arrayAgg (p ^. PersonName))
|
|
liftIO $ ret `shouldBe` []
|
|
|
|
testPostgresModule :: SpecDb
|
|
testPostgresModule = do
|
|
describe "date_trunc" $ modifyMaxSuccess (`div` 10) $ do
|
|
propDb "works" $ \run listOfDateParts -> run $ do
|
|
let
|
|
utcTimes =
|
|
map
|
|
(\(y, m, d, s) ->
|
|
fromInteger s
|
|
`addUTCTime`
|
|
UTCTime (fromGregorian (2000 + y) m d) 0
|
|
)
|
|
listOfDateParts
|
|
truncateDate
|
|
:: SqlExpr (Value String) -- ^ .e.g (val "day")
|
|
-> SqlExpr (Value UTCTime) -- ^ input field
|
|
-> SqlExpr (Value UTCTime) -- ^ truncated date
|
|
truncateDate datePart expr =
|
|
ES.unsafeSqlFunction "date_trunc" (datePart, expr)
|
|
vals =
|
|
zip (map (DateTruncTestKey . fromInteger) [1..]) utcTimes
|
|
for_ vals $ \(idx, utcTime) -> do
|
|
insertKey idx (DateTruncTest utcTime)
|
|
|
|
-- Necessary to get the test to pass; see the discussion in
|
|
-- https://github.com/bitemyapp/esqueleto/pull/180
|
|
rawExecute "SET TIME ZONE 'UTC'" []
|
|
ret <-
|
|
fmap (Map.fromList . coerce :: _ -> Map DateTruncTestId (UTCTime, UTCTime)) $
|
|
select $
|
|
from $ \dt -> do
|
|
pure
|
|
( dt ^. DateTruncTestId
|
|
, ( dt ^. DateTruncTestCreated
|
|
, truncateDate (val "day") (dt ^. DateTruncTestCreated)
|
|
)
|
|
)
|
|
|
|
asserting $ for_ vals $ \(idx, utcTime) -> do
|
|
case Map.lookup idx ret of
|
|
Nothing ->
|
|
expectationFailure "index not found"
|
|
Just (original, truncated) -> do
|
|
utcTime `shouldBe` original
|
|
if utctDay utcTime == utctDay truncated
|
|
then
|
|
utctDay utcTime `shouldBe` utctDay truncated
|
|
else
|
|
-- use this if/else to get a better error message
|
|
utcTime `shouldBe` truncated
|
|
|
|
describe "PostgreSQL module" $ do
|
|
describe "Aggregate functions" testAggregateFunctions
|
|
itDb "chr looks sane" $ do
|
|
[Value (ret :: String)] <- select $ return (EP.chr (val 65))
|
|
liftIO $ ret `shouldBe` "A"
|
|
|
|
itDb "allows unit for functions" $ do
|
|
let
|
|
fn :: SqlExpr (Value UTCTime)
|
|
fn = ES.unsafeSqlFunction "now" ()
|
|
vals <- select $ pure fn
|
|
liftIO $ vals `shouldSatisfy` ((1 ==) . length)
|
|
|
|
itDb "works with now" $
|
|
do
|
|
nowDb <- select $ return EP.now_
|
|
nowUtc <- liftIO getCurrentTime
|
|
let oneSecond = realToFrac (1 :: Double)
|
|
|
|
-- | Check the result is not null
|
|
liftIO $ nowDb `shouldSatisfy` (not . null)
|
|
|
|
-- | Unpack the now value
|
|
let (Value now: _) = nowDb
|
|
|
|
-- | Get the time diff and check it's less than a second
|
|
liftIO $ diffUTCTime nowUtc now `shouldSatisfy` (< oneSecond)
|
|
|
|
testJSONInsertions :: SpecDb
|
|
testJSONInsertions =
|
|
describe "JSON Insertions" $ do
|
|
itDb "adds scalar values" $ do
|
|
insertIt Null
|
|
insertIt $ Bool True
|
|
insertIt $ Number 1
|
|
insertIt $ String "test"
|
|
itDb "adds arrays" $ do
|
|
insertIt $ toJSON ([] :: [A.Value])
|
|
insertIt $ toJSON [Number 1, Bool True, Null]
|
|
insertIt $ toJSON [String "test",object ["a" .= Number 3.14], Null, Bool True]
|
|
itDb "adds objects" $ do
|
|
insertIt $ object ["a" .= (1 :: Int), "b" .= False]
|
|
insertIt $ object ["a" .= object ["b" .= object ["c" .= String "message"]]]
|
|
where
|
|
insertIt :: MonadIO m => A.Value -> SqlPersistT m ()
|
|
insertIt = insert_ . Json . JSONB
|
|
|
|
testJSONOperators :: SpecDb
|
|
testJSONOperators =
|
|
describe "JSON Operators" $ do
|
|
testArrowOperators
|
|
testFilterOperators
|
|
testConcatDeleteOperators
|
|
|
|
testArrowOperators :: SpecDb
|
|
testArrowOperators =
|
|
describe "Arrow Operators" $ do
|
|
testArrowJSONB
|
|
testArrowText
|
|
testHashArrowJSONB
|
|
testHashArrowText
|
|
|
|
testArrowJSONB :: SpecDb
|
|
testArrowJSONB =
|
|
describe "Single Arrow (JSONB)" $ do
|
|
itDb "creates sane SQL" $
|
|
createSaneSQL @JSONValue
|
|
(jsonbVal (object ["a" .= True]) ->. "a")
|
|
"SELECT (? -> ?)\nFROM \"Json\"\n"
|
|
[ PersistLiteralEscaped "{\"a\":true}"
|
|
, PersistText "a"
|
|
]
|
|
itDb "creates sane SQL (chained)" $ do
|
|
let obj = object ["a" .= [1 :: Int,2,3]]
|
|
createSaneSQL @JSONValue
|
|
(jsonbVal obj ->. "a" ->. 1)
|
|
"SELECT ((? -> ?) -> ?)\nFROM \"Json\"\n"
|
|
[ PersistLiteralEscaped "{\"a\":[1,2,3]}"
|
|
, PersistText "a"
|
|
, PersistInt64 1 ]
|
|
itDb "works as expected" $ do
|
|
x <- selectJSONwhere $ \v -> v ->. "b" ==. jsonbVal (Bool False)
|
|
y <- selectJSONwhere $ \v -> v ->. 1 ==. jsonbVal (Bool True)
|
|
z <- selectJSONwhere $ \v -> v ->. "a" ->. "b" ->. "c" ==. jsonbVal (String "message")
|
|
asserting $ do
|
|
length x `shouldBe` 1
|
|
length y `shouldBe` 1
|
|
length z `shouldBe` 1
|
|
|
|
testArrowText :: SpecDb
|
|
testArrowText =
|
|
describe "Single Arrow (Text)" $ do
|
|
itDb "creates sane SQL" $
|
|
createSaneSQL
|
|
(jsonbVal (object ["a" .= True]) ->>. "a")
|
|
"SELECT (? ->> ?)\nFROM \"Json\"\n"
|
|
[ PersistLiteralEscaped "{\"a\":true}"
|
|
, PersistText "a" ]
|
|
itDb "creates sane SQL (chained)" $ do
|
|
let obj = object ["a" .= [1 :: Int,2,3]]
|
|
createSaneSQL
|
|
(jsonbVal obj ->. "a" ->>. 1)
|
|
"SELECT ((? -> ?) ->> ?)\nFROM \"Json\"\n"
|
|
[ PersistLiteralEscaped "{\"a\":[1,2,3]}"
|
|
, PersistText "a"
|
|
, PersistInt64 1 ]
|
|
itDb "works as expected" $ do
|
|
x <- selectJSONwhere $ \v -> v ->>. "b" ==. just (val "false")
|
|
y <- selectJSONwhere $ \v -> v ->>. 1 ==. just (val "true")
|
|
z <- selectJSONwhere $ \v -> v ->. "a" ->. "b" ->>. "c" ==. just (val "message")
|
|
liftIO $ length x `shouldBe` 1
|
|
liftIO $ length y `shouldBe` 1
|
|
liftIO $ length z `shouldBe` 1
|
|
|
|
testHashArrowJSONB :: SpecDb
|
|
testHashArrowJSONB =
|
|
describe "Double Arrow (JSONB)" $ do
|
|
itDb "creates sane SQL" $ do
|
|
let list = ["a","b","c"]
|
|
createSaneSQL @JSONValue
|
|
(jsonbVal (object ["a" .= True]) #>. list)
|
|
"SELECT (? #> ?)\nFROM \"Json\"\n"
|
|
[ PersistLiteralEscaped "{\"a\":true}"
|
|
, persistTextArray list ]
|
|
itDb "creates sane SQL (chained)" $ do
|
|
let obj = object ["a" .= [object ["b" .= True]]]
|
|
createSaneSQL @JSONValue
|
|
(jsonbVal obj #>. ["a","1"] #>. ["b"])
|
|
"SELECT ((? #> ?) #> ?)\nFROM \"Json\"\n"
|
|
[ PersistLiteralEscaped "{\"a\":[{\"b\":true}]}"
|
|
, persistTextArray ["a","1"]
|
|
, persistTextArray ["b"] ]
|
|
itDb "works as expected" $ do
|
|
x <- selectJSONwhere $ \v -> v #>. ["a","b","c"] ==. jsonbVal (String "message")
|
|
y <- selectJSONwhere $ \v -> v #>. ["1","a"] ==. jsonbVal (Number 3.14)
|
|
z <- selectJSONwhere $ \v -> v #>. ["1"] #>. ["a"] ==. jsonbVal (Number 3.14)
|
|
liftIO $ length x `shouldBe` 1
|
|
liftIO $ length y `shouldBe` 1
|
|
liftIO $ length z `shouldBe` 1
|
|
|
|
testHashArrowText :: SpecDb
|
|
testHashArrowText =
|
|
describe "Double Arrow (Text)" $ do
|
|
itDb "creates sane SQL" $ do
|
|
let list = ["a","b","c"]
|
|
createSaneSQL
|
|
(jsonbVal (object ["a" .= True]) #>>. list)
|
|
"SELECT (? #>> ?)\nFROM \"Json\"\n"
|
|
[ PersistLiteralEscaped "{\"a\":true}"
|
|
, persistTextArray list ]
|
|
itDb "creates sane SQL (chained)" $ do
|
|
let obj = object ["a" .= [object ["b" .= True]]]
|
|
createSaneSQL
|
|
(jsonbVal obj #>. ["a","1"] #>>. ["b"])
|
|
"SELECT ((? #> ?) #>> ?)\nFROM \"Json\"\n"
|
|
[ PersistLiteralEscaped "{\"a\":[{\"b\":true}]}"
|
|
, persistTextArray ["a","1"]
|
|
, persistTextArray ["b"] ]
|
|
itDb "works as expected" $ do
|
|
x <- selectJSONwhere $ \v -> v #>>. ["a","b","c"] ==. just (val "message")
|
|
y <- selectJSONwhere $ \v -> v #>>. ["1","a"] ==. just (val "3.14")
|
|
z <- selectJSONwhere $ \v -> v #>. ["1"] #>>. ["a"] ==. just (val "3.14")
|
|
liftIO $ length x `shouldBe` 1
|
|
liftIO $ length y `shouldBe` 1
|
|
liftIO $ length z `shouldBe` 1
|
|
|
|
|
|
testFilterOperators :: SpecDb
|
|
testFilterOperators =
|
|
describe "Filter Operators" $ do
|
|
testInclusion
|
|
testQMark
|
|
testQMarkAny
|
|
testQMarkAll
|
|
|
|
testInclusion :: SpecDb
|
|
testInclusion = do
|
|
describe "@>" $ do
|
|
itDb "creates sane SQL" $ do
|
|
let obj = object ["a" .= False, "b" .= True]
|
|
encoded = BSL.toStrict $ encode obj
|
|
createSaneSQL
|
|
(jsonbVal obj @>. jsonbVal (object ["a" .= False]))
|
|
"SELECT (? @> ?)\nFROM \"Json\"\n"
|
|
[ PersistLiteralEscaped encoded
|
|
, PersistLiteralEscaped "{\"a\":false}"
|
|
]
|
|
itDb "creates sane SQL (chained)" $ do
|
|
let obj = object ["a" .= [object ["b" .= True]]]
|
|
encoded = BSL.toStrict $ encode obj
|
|
createSaneSQL
|
|
(jsonbVal obj ->. "a" @>. jsonbVal (object ["b" .= True]))
|
|
"SELECT ((? -> ?) @> ?)\nFROM \"Json\"\n"
|
|
[ PersistLiteralEscaped encoded
|
|
, PersistText "a"
|
|
, PersistLiteralEscaped "{\"b\":true}"
|
|
]
|
|
itDb "works as expected" $ do
|
|
x <- selectJSONwhere $ \v -> v @>. jsonbVal (Number 1)
|
|
y <- selectJSONwhere $ \v -> v @>. jsonbVal (toJSON [object ["a" .= Number 3.14]])
|
|
z <- selectJSONwhere $ \v -> v ->. 1 @>. jsonbVal (object ["a" .= Number 3.14])
|
|
liftIO $ length x `shouldBe` 2
|
|
liftIO $ length y `shouldBe` 1
|
|
liftIO $ length z `shouldBe` 1
|
|
describe "<@" $ do
|
|
itDb "creates sane SQL" $ do
|
|
let obj = object ["a" .= False, "b" .= True]
|
|
encoded = BSL.toStrict $ encode obj
|
|
createSaneSQL
|
|
(jsonbVal (object ["a" .= False]) <@. jsonbVal obj )
|
|
"SELECT (? <@ ?)\nFROM \"Json\"\n"
|
|
[ PersistLiteralEscaped "{\"a\":false}"
|
|
, PersistLiteralEscaped encoded
|
|
]
|
|
itDb "creates sane SQL (chained)" $ do
|
|
let obj = object ["a" .= [object ["b" .= True]]]
|
|
obj' = object ["b" .= True, "c" .= Null]
|
|
encoded = BSL.toStrict $ encode obj'
|
|
createSaneSQL
|
|
(jsonbVal obj ->. "a" <@. jsonbVal obj')
|
|
"SELECT ((? -> ?) <@ ?)\nFROM \"Json\"\n"
|
|
[ PersistLiteralEscaped "{\"a\":[{\"b\":true}]}"
|
|
, PersistText "a"
|
|
, PersistLiteralEscaped encoded
|
|
]
|
|
itDb "works as expected" $ do
|
|
x <- selectJSONwhere $ \v -> v <@. jsonbVal (toJSON [Number 1])
|
|
y <- selectJSONwhere $ \v -> v <@. jsonbVal (object ["a" .= (1 :: Int), "b" .= False, "c" .= Null])
|
|
z <- selectJSONwhere $ \v -> v #>. ["a","b"] <@. jsonbVal (object ["b" .= False, "c" .= String "message"])
|
|
liftIO $ length x `shouldBe` 2
|
|
liftIO $ length y `shouldBe` 1
|
|
liftIO $ length z `shouldBe` 1
|
|
|
|
testQMark :: SpecDb
|
|
testQMark = do
|
|
describe "Question Mark" $ do
|
|
itDb "creates sane SQL" $ do
|
|
let obj = object ["a" .= False, "b" .= True]
|
|
encoded = BSL.toStrict $ encode obj
|
|
createSaneSQL
|
|
(jsonbVal obj JSON.?. "a")
|
|
"SELECT (? ?? ?)\nFROM \"Json\"\n"
|
|
[ PersistLiteralEscaped encoded
|
|
, PersistText "a"
|
|
]
|
|
itDb "creates sane SQL (chained)" $ do
|
|
let obj = object ["a" .= [object ["b" .= True]]]
|
|
encoded = BSL.toStrict $ encode obj
|
|
createSaneSQL
|
|
(jsonbVal obj #>. ["a","0"] JSON.?. "b")
|
|
"SELECT ((? #> ?) ?? ?)\nFROM \"Json\"\n"
|
|
[ PersistLiteralEscaped encoded
|
|
, persistTextArray ["a","0"]
|
|
, PersistText "b"
|
|
]
|
|
itDb "works as expected" $ do
|
|
x <- selectJSONwhere (JSON.?. "a")
|
|
y <- selectJSONwhere (JSON.?. "test")
|
|
z <- selectJSONwhere $ \v -> v ->. "a" JSON.?. "b"
|
|
liftIO $ length x `shouldBe` 2
|
|
liftIO $ length y `shouldBe` 2
|
|
liftIO $ length z `shouldBe` 1
|
|
|
|
testQMarkAny :: SpecDb
|
|
testQMarkAny = do
|
|
describe "Question Mark (Any)" $ do
|
|
itDb "creates sane SQL" $ do
|
|
let obj = (object ["a" .= False, "b" .= True])
|
|
encoded = BSL.toStrict $ encode obj
|
|
createSaneSQL
|
|
(jsonbVal obj ?|. ["a","c"])
|
|
"SELECT (? ??| ?)\nFROM \"Json\"\n"
|
|
[ PersistLiteralEscaped encoded
|
|
, persistTextArray ["a","c"]
|
|
]
|
|
itDb "creates sane SQL (chained)" $ do
|
|
let obj = object ["a" .= [object ["b" .= True]]]
|
|
encoded = BSL.toStrict $ encode obj
|
|
createSaneSQL
|
|
(jsonbVal obj #>. ["a","0"] ?|. ["b","c"])
|
|
"SELECT ((? #> ?) ??| ?)\nFROM \"Json\"\n"
|
|
[ PersistLiteralEscaped encoded
|
|
, persistTextArray ["a","0"]
|
|
, persistTextArray ["b","c"]
|
|
]
|
|
itDb "works as expected" $ do
|
|
x <- selectJSONwhere (?|. ["b","test"])
|
|
y <- selectJSONwhere (?|. ["a"])
|
|
z <- selectJSONwhere $ \v -> v ->. (-3) ?|. ["a"]
|
|
w <- selectJSONwhere (?|. [])
|
|
liftIO $ length x `shouldBe` 3
|
|
liftIO $ length y `shouldBe` 2
|
|
liftIO $ length z `shouldBe` 1
|
|
liftIO $ length w `shouldBe` 0
|
|
|
|
testQMarkAll :: SpecDb
|
|
testQMarkAll = do
|
|
describe "Question Mark (All)" $ do
|
|
itDb "creates sane SQL" $ do
|
|
let obj = object ["a" .= False, "b" .= True]
|
|
encoded = BSL.toStrict $ encode obj
|
|
createSaneSQL
|
|
(jsonbVal obj ?&. ["a","c"])
|
|
"SELECT (? ??& ?)\nFROM \"Json\"\n"
|
|
[ PersistLiteralEscaped encoded
|
|
, persistTextArray ["a","c"]
|
|
]
|
|
itDb "creates sane SQL (chained)" $ do
|
|
let obj = object ["a" .= [object ["b" .= True]]]
|
|
encoded = BSL.toStrict $ encode obj
|
|
createSaneSQL
|
|
(jsonbVal obj #>. ["a","0"] ?&. ["b","c"])
|
|
"SELECT ((? #> ?) ??& ?)\nFROM \"Json\"\n"
|
|
[ PersistLiteralEscaped encoded
|
|
, persistTextArray ["a","0"]
|
|
, persistTextArray ["b","c"]
|
|
]
|
|
itDb "works as expected" $ do
|
|
x <- selectJSONwhere (?&. ["test"])
|
|
y <- selectJSONwhere (?&. ["a","b"])
|
|
z <- selectJSONwhere $ \v -> v ->. "a" ?&. ["b"]
|
|
w <- selectJSONwhere (?&. [])
|
|
liftIO $ length x `shouldBe` 2
|
|
liftIO $ length y `shouldBe` 1
|
|
liftIO $ length z `shouldBe` 1
|
|
liftIO $ length w `shouldBe` 9
|
|
|
|
testConcatDeleteOperators :: SpecDb
|
|
testConcatDeleteOperators = do
|
|
describe "Concatenation Operator" testConcatenationOperator
|
|
describe "Deletion Operators" $ do
|
|
testMinusOperator
|
|
testMinusOperatorV10
|
|
testHashMinusOperator
|
|
|
|
testConcatenationOperator :: SpecDb
|
|
testConcatenationOperator = do
|
|
describe "Concatenation" $ do
|
|
itDb "creates sane SQL" $ do
|
|
let objAB = object ["a" .= False, "b" .= True]
|
|
objC = object ["c" .= Null]
|
|
createSaneSQL @JSONValue
|
|
(jsonbVal objAB
|
|
JSON.||. jsonbVal objC)
|
|
"SELECT (? || ?)\nFROM \"Json\"\n"
|
|
[ PersistLiteralEscaped $ BSL.toStrict $ encode objAB
|
|
, PersistLiteralEscaped $ BSL.toStrict $ encode objC
|
|
]
|
|
itDb "creates sane SQL (chained)" $ do
|
|
let obj = object ["a" .= [object ["b" .= True]]]
|
|
encoded = BSL.toStrict $ encode obj
|
|
createSaneSQL @JSONValue
|
|
(jsonbVal obj ->. "a" JSON.||. jsonbVal (toJSON [Null]))
|
|
"SELECT ((? -> ?) || ?)\nFROM \"Json\"\n"
|
|
[ PersistLiteralEscaped encoded
|
|
, PersistText "a"
|
|
, PersistLiteralEscaped "[null]"
|
|
]
|
|
itDb "works as expected" $ do
|
|
x <- selectJSON $ \v -> do
|
|
where_ $ v @>. jsonbVal (object [])
|
|
where_ $ v JSON.||. jsonbVal (object ["x" .= True])
|
|
@>. jsonbVal (object ["x" .= True])
|
|
y <- selectJSONwhere $ \v ->
|
|
v JSON.||. jsonbVal (toJSON [String "a", String "b"])
|
|
->>. 4 ==. just (val "b")
|
|
z <- selectJSONwhere $ \v ->
|
|
v JSON.||. jsonbVal (toJSON [Bool False])
|
|
->. 0 JSON.@>. jsonbVal (Number 1)
|
|
w <- selectJSON $ \v -> do
|
|
where_ . not_ $ v @>. jsonbVal (object [])
|
|
where_ $ jsonbVal (String "test1") JSON.||. v ->>. 0 ==. just (val "test1")
|
|
liftIO $ length x `shouldBe` 2
|
|
liftIO $ length y `shouldBe` 1
|
|
liftIO $ length z `shouldBe` 2
|
|
liftIO $ length w `shouldBe` 7
|
|
|
|
testMinusOperator :: SpecDb
|
|
testMinusOperator =
|
|
describe "Minus Operator" $ do
|
|
itDb "creates sane SQL" $ do
|
|
let obj = object ["a" .= False, "b" .= True]
|
|
encoded = BSL.toStrict $ encode obj
|
|
createSaneSQL @JSONValue
|
|
(jsonbVal obj JSON.-. "a")
|
|
"SELECT (? - ?)\nFROM \"Json\"\n"
|
|
[ PersistLiteralEscaped encoded
|
|
, PersistText "a"
|
|
]
|
|
itDb "creates sane SQL (chained)" $ do
|
|
let obj = object ["a" .= [object ["b" .= True]]]
|
|
encoded = BSL.toStrict $ encode obj
|
|
createSaneSQL @JSONValue
|
|
(jsonbVal obj ->. "a" JSON.-. 0)
|
|
"SELECT ((? -> ?) - ?)\nFROM \"Json\"\n"
|
|
[ PersistLiteralEscaped encoded
|
|
, PersistText "a"
|
|
, PersistInt64 0
|
|
]
|
|
itDb "works as expected" $ do
|
|
x <- selectJSON $ \v -> do
|
|
where_ $ v @>. jsonbVal (toJSON ([] :: [Int]))
|
|
where_ $ v JSON.-. 0 @>. jsonbVal (toJSON [Bool True])
|
|
y <- selectJSON $ \v -> do
|
|
where_ $ v @>. jsonbVal (toJSON ([] :: [Int]))
|
|
where_ $ v JSON.-. (-1) @>. jsonbVal (toJSON [Null])
|
|
z <- selectJSON_ $ \v -> v JSON.-. "b" ?&. ["a", "b"]
|
|
w <- selectJSON_ $ \v -> do
|
|
v JSON.-. "test" @>. jsonbVal (toJSON [String "test"])
|
|
liftIO $ length x `shouldBe` 2
|
|
liftIO $ length y `shouldBe` 1
|
|
liftIO $ length z `shouldBe` 0
|
|
liftIO $ length w `shouldBe` 0
|
|
sqlFailWith "22023" $ selectJSONwhere $ \v ->
|
|
v JSON.-. 0 @>. jsonbVal (toJSON ([] :: [Int]))
|
|
where
|
|
selectJSON_ f = selectJSON $ \v -> do
|
|
where_
|
|
$ v @>. jsonbVal (object [])
|
|
||. v @>. jsonbVal (toJSON ([] :: [Int]))
|
|
where_ $ f v
|
|
|
|
testMinusOperatorV10 :: SpecDb
|
|
testMinusOperatorV10 = do
|
|
describe "Minus Operator (PSQL >= v10)" $ do
|
|
itDb "creates sane SQL" $ do
|
|
let obj = object ["a" .= False, "b" .= True]
|
|
encoded = BSL.toStrict $ encode obj
|
|
createSaneSQL @JSONValue
|
|
(jsonbVal obj --. ["a","b"])
|
|
"SELECT (? - ?)\nFROM \"Json\"\n"
|
|
[ PersistLiteralEscaped encoded
|
|
, persistTextArray ["a","b"]
|
|
]
|
|
itDb "creates sane SQL (chained)" $ do
|
|
let obj = object ["a" .= [object ["b" .= True]]]
|
|
encoded = BSL.toStrict $ encode obj
|
|
createSaneSQL @JSONValue
|
|
(jsonbVal obj #>. ["a","0"] --. ["b"])
|
|
"SELECT ((? #> ?) - ?)\nFROM \"Json\"\n"
|
|
[ PersistLiteralEscaped encoded
|
|
, persistTextArray ["a","0"]
|
|
, persistTextArray ["b"]
|
|
]
|
|
itDb "works as expected" $ do
|
|
x <- selectJSON $ \v -> do
|
|
where_ $ v @>. jsonbVal (toJSON ([] :: [Int]))
|
|
where_ $ v --. ["test","a"] @>. jsonbVal (toJSON [String "test"])
|
|
y <- selectJSON $ \v -> do
|
|
where_ $ v @>. jsonbVal (object [])
|
|
where_ $ v --. ["a","b"] <@. jsonbVal (object [])
|
|
z <- selectJSON_ $ \v -> v --. ["b"] <@. jsonbVal (object ["a" .= (1 :: Int)])
|
|
w <- selectJSON_ $ \v -> do
|
|
v --. ["test"] @>. jsonbVal (toJSON [String "test"])
|
|
liftIO $ length x `shouldBe` 0
|
|
liftIO $ length y `shouldBe` 2
|
|
liftIO $ length z `shouldBe` 1
|
|
liftIO $ length w `shouldBe` 0
|
|
sqlFailWith "22023" $ selectJSONwhere $ \v ->
|
|
v --. ["a"] @>. jsonbVal (toJSON ([] :: [Int]))
|
|
where
|
|
selectJSON_ f = selectJSON $ \v -> do
|
|
where_ $ v @>. jsonbVal (object [])
|
|
||. v @>. jsonbVal (toJSON ([] :: [Int]))
|
|
where_ $ f v
|
|
|
|
testHashMinusOperator :: SpecDb
|
|
testHashMinusOperator =
|
|
describe "Hash-Minus Operator" $ do
|
|
itDb "creates sane SQL" $
|
|
createSaneSQL @JSONValue
|
|
(jsonbVal (object ["a" .= False, "b" .= True]) #-. ["a"])
|
|
"SELECT (? #- ?)\nFROM \"Json\"\n"
|
|
[ PersistLiteralEscaped (BSL.toStrict $ encode $ object ["a" .= False, "b" .= True])
|
|
, persistTextArray ["a"] ]
|
|
itDb "creates sane SQL (chained)" $ do
|
|
let obj = object ["a" .= [object ["b" .= True]]]
|
|
createSaneSQL @JSONValue
|
|
(jsonbVal obj ->. "a" #-. ["0","b"])
|
|
"SELECT ((? -> ?) #- ?)\nFROM \"Json\"\n"
|
|
[ PersistLiteralEscaped (BSL.toStrict $ encode obj)
|
|
, PersistText "a"
|
|
, persistTextArray ["0","b"] ]
|
|
itDb "works as expected" $ do
|
|
x <- selectJSON $ \v -> do
|
|
where_ $ v @>. jsonbVal (toJSON ([] :: [Int]))
|
|
where_ $ v #-. ["1","a"] @>. jsonbVal (toJSON [object []])
|
|
y <- selectJSON $ \v -> do
|
|
where_ $ v @>. jsonbVal (toJSON ([] :: [Int]))
|
|
where_ $ v #-. ["-3","a"] @>. jsonbVal (toJSON [object []])
|
|
z <- selectJSON_ $ \v -> v #-. ["a","b","c"]
|
|
@>. jsonbVal (object ["a" .= object ["b" .= object ["c" .= String "message"]]])
|
|
w <- selectJSON_ $ \v -> v #-. ["a","b"] JSON.?. "b"
|
|
liftIO $ length x `shouldBe` 1
|
|
liftIO $ length y `shouldBe` 1
|
|
liftIO $ length z `shouldBe` 0
|
|
liftIO $ length w `shouldBe` 1
|
|
sqlFailWith "22023" $ selectJSONwhere $ \v ->
|
|
v #-. ["0"] @>. jsonbVal (toJSON ([] :: [Int]))
|
|
where selectJSON_ f = selectJSON $ \v -> do
|
|
where_ $ v @>. jsonbVal (object [])
|
|
where_ $ f v
|
|
|
|
testInsertUniqueViolation :: SpecDb
|
|
testInsertUniqueViolation =
|
|
describe "Unique Violation on Insert" $
|
|
itDb "Unique throws exception" $ do
|
|
eres <-
|
|
try $ do
|
|
_ <- insert u1
|
|
_ <- insert u2
|
|
insert u3
|
|
liftIO $ case eres of
|
|
Left err | err == exception ->
|
|
pure ()
|
|
_ ->
|
|
expectationFailure $ "Expected a SQL exception, got: " <>
|
|
show eres
|
|
|
|
where
|
|
exception = SqlError {
|
|
sqlState = "23505",
|
|
sqlExecStatus = FatalError,
|
|
sqlErrorMsg = "duplicate key value violates unique constraint \"UniqueValue\"",
|
|
sqlErrorDetail = "Key (value)=(0) already exists.",
|
|
sqlErrorHint = ""}
|
|
|
|
testUpsert :: SpecDb
|
|
testUpsert =
|
|
describe "Upsert test" $ do
|
|
itDb "Upsert can insert like normal" $ do
|
|
u1e <- EP.upsert u1 [OneUniqueName =. val "fifth"]
|
|
liftIO $ entityVal u1e `shouldBe` u1
|
|
itDb "Upsert performs update on collision" $ do
|
|
u1e <- EP.upsert u1 [OneUniqueName =. val "fifth"]
|
|
liftIO $ entityVal u1e `shouldBe` u1
|
|
u2e <- EP.upsert u2 [OneUniqueName =. val "fifth"]
|
|
liftIO $ entityVal u2e `shouldBe` u2
|
|
u3e <- EP.upsert u3 [OneUniqueName =. val "fifth"]
|
|
liftIO $ entityVal u3e `shouldBe` u1{oneUniqueName="fifth"}
|
|
|
|
testInsertSelectWithConflict :: SpecDb
|
|
testInsertSelectWithConflict =
|
|
describe "insertSelectWithConflict test" $ do
|
|
itDb "Should do Nothing when no updates set" $ do
|
|
_ <- insert p1
|
|
_ <- insert p2
|
|
_ <- insert p3
|
|
n1 <- EP.insertSelectWithConflictCount UniqueValue (
|
|
from $ \p -> return $ OneUnique <# val "test" <&> (p ^. PersonFavNum)
|
|
)
|
|
(\current excluded -> [])
|
|
uniques1 <- select $ from $ \u -> return u
|
|
n2 <- EP.insertSelectWithConflictCount UniqueValue (
|
|
from $ \p -> return $ OneUnique <# val "test" <&> (p ^. PersonFavNum)
|
|
)
|
|
(\current excluded -> [])
|
|
uniques2 <- select $ from $ \u -> return u
|
|
liftIO $ n1 `shouldBe` 3
|
|
liftIO $ n2 `shouldBe` 0
|
|
let test = map (OneUnique "test" . personFavNum) [p1,p2,p3]
|
|
liftIO $ map entityVal uniques1 `shouldBe` test
|
|
liftIO $ map entityVal uniques2 `shouldBe` test
|
|
itDb "Should update a value if given an update on conflict" $ do
|
|
_ <- insert p1
|
|
_ <- insert p2
|
|
_ <- insert p3
|
|
-- Note, have to sum 4 so that the update does not conflicts again with another row.
|
|
n1 <- EP.insertSelectWithConflictCount UniqueValue (
|
|
from $ \p -> return $ OneUnique <# val "test" <&> (p ^. PersonFavNum)
|
|
)
|
|
(\current excluded -> [OneUniqueValue =. val 4 +. (current ^. OneUniqueValue) +. (excluded ^. OneUniqueValue)])
|
|
uniques1 <- select $ from $ \u -> return u
|
|
n2 <- EP.insertSelectWithConflictCount UniqueValue (
|
|
from $ \p -> return $ OneUnique <# val "test" <&> (p ^. PersonFavNum)
|
|
)
|
|
(\current excluded -> [OneUniqueValue =. val 4 +. (current ^. OneUniqueValue) +. (excluded ^. OneUniqueValue)])
|
|
uniques2 <- select $ from $ \u -> return u
|
|
liftIO $ n1 `shouldBe` 3
|
|
liftIO $ n2 `shouldBe` 3
|
|
let test = map (OneUnique "test" . personFavNum) [p1,p2,p3]
|
|
test2 = map (OneUnique "test" . (+4) . (*2) . personFavNum) [p1,p2,p3]
|
|
liftIO $ map entityVal uniques1 `shouldBe` test
|
|
liftIO $ map entityVal uniques2 `shouldBe` test2
|
|
|
|
testFilterWhere :: SpecDb
|
|
testFilterWhere =
|
|
describe "filterWhere" $ do
|
|
itDb "adds a filter clause to count aggregation" $ do
|
|
-- Person "John" (Just 36) Nothing 1
|
|
_ <- insert p1
|
|
-- Person "Rachel" Nothing (Just 37) 2
|
|
_ <- insert p2
|
|
-- Person "Mike" (Just 17) Nothing 3
|
|
_ <- insert p3
|
|
-- Person "Livia" (Just 17) (Just 18) 4
|
|
_ <- insert p4
|
|
-- Person "Mitch" Nothing Nothing 5
|
|
_ <- insert p5
|
|
|
|
usersByAge <- fmap coerce <$> do
|
|
select $ from $ \users -> do
|
|
groupBy $ users ^. PersonAge
|
|
return
|
|
( users ^. PersonAge :: SqlExpr (Value (Maybe Int))
|
|
-- Nothing: [Rachel { favNum = 2 }, Mitch { favNum = 5 }] = 2
|
|
-- Just 36: [John { favNum = 1 } (excluded)] = 0
|
|
-- Just 17: [Mike { favNum = 3 }, Livia { favNum = 4 }] = 2
|
|
, count (users ^. PersonId) `EP.filterWhere` (users ^. PersonFavNum >=. val 2)
|
|
:: SqlExpr (Value Int)
|
|
-- Nothing: [Rachel { favNum = 2 } (excluded), Mitch { favNum = 5 } (excluded)] = 0
|
|
-- Just 36: [John { favNum = 1 }] = 1
|
|
-- Just 17: [Mike { favNum = 3 } (excluded), Livia { favNum = 4 } (excluded)] = 0
|
|
, count (users ^. PersonFavNum) `EP.filterWhere` (users ^. PersonFavNum <. val 2)
|
|
:: SqlExpr (Value Int)
|
|
)
|
|
|
|
liftIO $ usersByAge `shouldMatchList`
|
|
( [ (Nothing, 2, 0)
|
|
, (Just 36, 0, 1)
|
|
, (Just 17, 2, 0)
|
|
] :: [(Maybe Int, Int, Int)]
|
|
)
|
|
|
|
itDb "adds a filter clause to sum aggregation" $ do
|
|
-- Person "John" (Just 36) Nothing 1
|
|
_ <- insert p1
|
|
-- Person "Rachel" Nothing (Just 37) 2
|
|
_ <- insert p2
|
|
-- Person "Mike" (Just 17) Nothing 3
|
|
_ <- insert p3
|
|
-- Person "Livia" (Just 17) (Just 18) 4
|
|
_ <- insert p4
|
|
-- Person "Mitch" Nothing Nothing 5
|
|
_ <- insert p5
|
|
|
|
usersByAge <- fmap (\(Value a, Value b, Value c) -> (a, b, c)) <$> do
|
|
select $ from $ \users -> do
|
|
groupBy $ users ^. PersonAge
|
|
return
|
|
( users ^. PersonAge
|
|
-- Nothing: [Rachel { favNum = 2 }, Mitch { favNum = 5 }] = Just 7
|
|
-- Just 36: [John { favNum = 1 } (excluded)] = Nothing
|
|
-- Just 17: [Mike { favNum = 3 }, Livia { favNum = 4 }] = Just 7
|
|
, sum_ (users ^. PersonFavNum) `EP.filterWhere` (users ^. PersonFavNum >=. val 2)
|
|
-- Nothing: [Rachel { favNum = 2 } (excluded), Mitch { favNum = 5 } (excluded)] = Nothing
|
|
-- Just 36: [John { favNum = 1 }] = Just 1
|
|
-- Just 17: [Mike { favNum = 3 } (excluded), Livia { favNum = 4 } (excluded)] = Nothing
|
|
, sum_ (users ^. PersonFavNum) `EP.filterWhere` (users ^. PersonFavNum <. val 2)
|
|
)
|
|
|
|
liftIO $ usersByAge `shouldMatchList`
|
|
( [ (Nothing, Just 7, Nothing)
|
|
, (Just 36, Nothing, Just 1)
|
|
, (Just 17, Just 7, Nothing)
|
|
] :: [(Maybe Int, Maybe Rational, Maybe Rational)]
|
|
)
|
|
|
|
testCommonTableExpressions :: SpecDb
|
|
testCommonTableExpressions = do
|
|
describe "You can run them" $ do
|
|
itDb "will run" $ do
|
|
void $ select $ do
|
|
limitedLordsCte <-
|
|
Experimental.with $ do
|
|
lords <- Experimental.from $ Experimental.table @Lord
|
|
limit 10
|
|
pure lords
|
|
lords <- Experimental.from limitedLordsCte
|
|
orderBy [asc $ lords ^. LordId]
|
|
pure lords
|
|
|
|
asserting noExceptions
|
|
|
|
itDb "can do multiple recursive queries" $ do
|
|
let
|
|
oneToTen =
|
|
Experimental.withRecursive
|
|
(pure $ val (1 :: Int))
|
|
Experimental.unionAll_
|
|
(\self -> do
|
|
v <- Experimental.from self
|
|
where_ $ v <. val 10
|
|
pure $ v +. val 1
|
|
)
|
|
|
|
vals <- select $ do
|
|
cte <- oneToTen
|
|
cte2 <- oneToTen
|
|
res1 <- Experimental.from cte
|
|
res2 <- Experimental.from cte2
|
|
pure (res1, res2)
|
|
asserting $ vals `shouldBe` (((,) <$> fmap Value [1..10] <*> fmap Value [1..10]))
|
|
|
|
itDb "passing previous query works" $ do
|
|
let
|
|
oneToTen =
|
|
Experimental.withRecursive
|
|
(pure $ val (1 :: Int))
|
|
Experimental.unionAll_
|
|
(\self -> do
|
|
v <- Experimental.from self
|
|
where_ $ v <. val 10
|
|
pure $ v +. val 1
|
|
)
|
|
|
|
oneMore q =
|
|
Experimental.with $ do
|
|
v <- Experimental.from q
|
|
pure $ v +. val 1
|
|
vals <- select $ do
|
|
cte <- oneToTen
|
|
cte2 <- oneMore cte
|
|
res <- Experimental.from cte2
|
|
pure res
|
|
asserting $ vals `shouldBe` fmap Value [2..11]
|
|
|
|
-- Since lateral queries arent supported in Sqlite or older versions of mysql
|
|
-- the test is in the Postgres module
|
|
testLateralQuery :: SpecDb
|
|
testLateralQuery = do
|
|
describe "Lateral queries" $ do
|
|
itDb "supports CROSS JOIN LATERAL" $ do
|
|
_ <- do
|
|
select $ do
|
|
l :& c <-
|
|
Experimental.from $ table @Lord
|
|
`CrossJoin` \lord -> do
|
|
deed <- Experimental.from $ table @Deed
|
|
where_ $ lord ^. LordId ==. deed ^. DeedOwnerId
|
|
pure $ countRows @Int
|
|
pure (l, c)
|
|
liftIO $ True `shouldBe` True
|
|
|
|
itDb "supports INNER JOIN LATERAL" $ do
|
|
let subquery lord = do
|
|
deed <- Experimental.from $ table @Deed
|
|
where_ $ lord ^. LordId ==. deed ^. DeedOwnerId
|
|
pure $ countRows @Int
|
|
res <- select $ do
|
|
l :& c <- Experimental.from $ table @Lord
|
|
`InnerJoin` subquery
|
|
`Experimental.on` (const $ val True)
|
|
pure (l, c)
|
|
|
|
let _ = res :: [(Entity Lord, Value Int)]
|
|
asserting noExceptions
|
|
|
|
itDb "supports LEFT JOIN LATERAL" $ do
|
|
res <- select $ do
|
|
l :& c <- Experimental.from $ table @Lord
|
|
`LeftOuterJoin` (\lord -> do
|
|
deed <- Experimental.from $ table @Deed
|
|
where_ $ lord ^. LordId ==. deed ^. DeedOwnerId
|
|
pure $ countRows @Int)
|
|
`Experimental.on` (const $ val True)
|
|
pure (l, c)
|
|
|
|
let _ = res :: [(Entity Lord, Value (Maybe Int))]
|
|
asserting noExceptions
|
|
|
|
testValuesExpression :: SpecDb
|
|
testValuesExpression = do
|
|
describe "(VALUES (..)) query" $ do
|
|
itDb "works with joins and other sql expressions" $ do
|
|
p1k <- insert p1
|
|
p2k <- insert p2
|
|
p3k <- insert p3
|
|
let exprs :: NE.NonEmpty (SqlExpr (Value Int), SqlExpr (Value Text))
|
|
exprs = (val 10, val "ten")
|
|
NE.:| [ (val 20, val "twenty")
|
|
, (val 30, val "thirty") ]
|
|
query = do
|
|
(bound, boundName) :& person <- Experimental.from $
|
|
EP.values exprs
|
|
`Experimental.InnerJoin` table @Person
|
|
`Experimental.on` (\((bound, boundName) :& person) -> person^.PersonAge >=. just bound)
|
|
groupBy bound
|
|
orderBy [ asc bound ]
|
|
pure (bound, count @Int $ person^.PersonName)
|
|
result <- select query
|
|
liftIO $ result `shouldBe` [ (Value 10, Value 2)
|
|
, (Value 20, Value 1)
|
|
, (Value 30, Value 1) ]
|
|
|
|
itDb "supports single-column query" $ do
|
|
let query = do
|
|
vInt <- Experimental.from $ EP.values $ val 1 NE.:| [ val 2, val 3 ]
|
|
pure (vInt :: SqlExpr (Value Int))
|
|
result <- select query
|
|
asserting noExceptions
|
|
liftIO $ result `shouldBe` [ Value 1, Value 2, Value 3 ]
|
|
|
|
itDb "supports multi-column query (+ nested simple expression and null)" $ do
|
|
let query = do
|
|
(vInt, vStr, vDouble) <- Experimental.from
|
|
$ EP.values $ (val 1, val "str1", coalesce [just $ val 1.0, nothing])
|
|
NE.:| [ (val 2, val "str2", just $ val 2.5)
|
|
, (val 3, val "str3", nothing) ]
|
|
pure ( vInt :: SqlExpr (Value Int)
|
|
, vStr :: SqlExpr (Value Text)
|
|
, vDouble :: SqlExpr (Value (Maybe Double)) )
|
|
result <- select query
|
|
asserting noExceptions
|
|
liftIO $ result `shouldBe` [ (Value 1, Value "str1", Value $ Just 1.0)
|
|
, (Value 2, Value "str2", Value $ Just 2.5)
|
|
, (Value 3, Value "str3", Value Nothing) ]
|
|
|
|
type JSONValue = Maybe (JSONB A.Value)
|
|
|
|
createSaneSQL :: (PersistField a, MonadIO m) => SqlExpr (Value a) -> T.Text -> [PersistValue] -> SqlPersistT m ()
|
|
createSaneSQL act q vals = do
|
|
(query, args) <- showQuery ES.SELECT $ fromValue act
|
|
liftIO $ do
|
|
query `shouldBe` q
|
|
args `shouldBe` vals
|
|
|
|
fromValue :: (PersistField a) => SqlExpr (Value a) -> SqlQuery (SqlExpr (Value a))
|
|
fromValue act = from $ \x -> do
|
|
let _ = x :: SqlExpr (Entity Json)
|
|
return act
|
|
|
|
persistTextArray :: [T.Text] -> PersistValue
|
|
persistTextArray = PersistArray . fmap PersistText
|
|
|
|
sqlFailWith
|
|
:: (HasCallStack, MonadUnliftIO m, Show a)
|
|
=> ByteString
|
|
-> SqlPersistT m a
|
|
-> SqlPersistT m ()
|
|
sqlFailWith errState f = do
|
|
eres <- try f
|
|
case eres of
|
|
Left err ->
|
|
success err
|
|
Right a ->
|
|
liftIO $ expectationFailure $ mconcat
|
|
[ "should fail with error code: "
|
|
, T.unpack errStateT
|
|
, ", but got: "
|
|
, show a
|
|
]
|
|
where
|
|
success SqlError{sqlState}
|
|
| sqlState == errState =
|
|
pure ()
|
|
| otherwise = do
|
|
liftIO $ expectationFailure $ T.unpack $ T.concat
|
|
[ "should fail with: ", errStateT
|
|
, ", but received: ", TE.decodeUtf8 sqlState
|
|
]
|
|
errStateT =
|
|
TE.decodeUtf8 errState
|
|
|
|
selectJSONwhere
|
|
:: MonadIO m
|
|
=> (JSONBExpr A.Value -> SqlExpr (Value Bool))
|
|
-> SqlPersistT m [Entity Json]
|
|
selectJSONwhere f = selectJSON $ where_ . f
|
|
|
|
selectJSON
|
|
:: MonadIO m
|
|
=> (JSONBExpr A.Value -> SqlQuery ())
|
|
-> SqlPersistT m [Entity Json]
|
|
selectJSON f = select $ from $ \v -> do
|
|
f $ just (v ^. JsonValue)
|
|
return v
|
|
|
|
--------------- JSON --------------- JSON --------------- JSON ---------------
|
|
--------------- JSON --------------- JSON --------------- JSON ---------------
|
|
--------------- JSON --------------- JSON --------------- JSON ---------------
|
|
|
|
|
|
|
|
spec :: Spec
|
|
spec = beforeAll mkConnectionPool $ do
|
|
tests
|
|
|
|
describe "PostgreSQL specific tests" $ do
|
|
testAscRandom random_
|
|
testRandomMath
|
|
testSelectDistinctOn
|
|
testPostgresModule
|
|
testPostgresqlOneAscOneDesc
|
|
testPostgresqlTwoAscFields
|
|
testPostgresqlSum
|
|
testPostgresqlRandom
|
|
testPostgresqlUpdate
|
|
testPostgresqlCoalesce
|
|
testPostgresqlTextFunctions
|
|
testInsertUniqueViolation
|
|
testUpsert
|
|
testInsertSelectWithConflict
|
|
testFilterWhere
|
|
testCommonTableExpressions
|
|
setDatabaseState insertJsonValues cleanJSON
|
|
$ describe "PostgreSQL JSON tests" $ do
|
|
testJSONInsertions
|
|
testJSONOperators
|
|
testLateralQuery
|
|
testValuesExpression
|
|
|
|
insertJsonValues :: SqlPersistT IO ()
|
|
insertJsonValues = do
|
|
insertIt Null
|
|
insertIt $ Bool True
|
|
insertIt $ Number 1
|
|
insertIt $ String "test"
|
|
insertIt $ toJSON ([] :: [A.Value])
|
|
insertIt $ toJSON [Number 1, Bool True, Null]
|
|
insertIt $ toJSON [String "test",object ["a" .= Number 3.14], Null, Bool True]
|
|
insertIt $ object ["a" .= (1 :: Int), "b" .= False]
|
|
insertIt $ object ["a" .= object ["b" .= object ["c" .= String "message"]]]
|
|
where
|
|
insertIt :: MonadIO m => A.Value -> SqlPersistT m ()
|
|
insertIt = insert_ . Json . JSONB
|
|
|
|
verbose :: Bool
|
|
verbose = False
|
|
|
|
migrateIt :: _ => SqlPersistT m ()
|
|
migrateIt = mapReaderT runNoLoggingT $ do
|
|
void $ runMigrationSilent $ do
|
|
migrateAll
|
|
migrateUnique
|
|
migrateJSON
|
|
cleanDB
|
|
cleanUniques
|
|
|
|
mkConnectionPool :: IO ConnectionPool
|
|
mkConnectionPool = do
|
|
verbose' <- lookupEnv "VERBOSE" >>= \case
|
|
Nothing ->
|
|
return verbose
|
|
Just x
|
|
| map Char.toLower x == "true" -> return True
|
|
| null x -> return True
|
|
| otherwise -> return False
|
|
pool <- if verbose'
|
|
then
|
|
runStderrLoggingT $
|
|
createPostgresqlPool
|
|
"host=localhost port=5432 user=esqutest password=esqutest dbname=esqutest"
|
|
4
|
|
else
|
|
runNoLoggingT $
|
|
createPostgresqlPool
|
|
"host=localhost port=5432 user=esqutest password=esqutest dbname=esqutest"
|
|
4
|
|
flip runSqlPool pool $ do
|
|
migrateIt
|
|
pure pool
|
|
|
|
-- | Show the SQL generated by a query
|
|
showQuery :: (Monad m, ES.SqlSelect a r, BackendCompatible SqlBackend backend)
|
|
=> ES.Mode -> SqlQuery a -> ReaderT backend m (T.Text, [PersistValue])
|
|
showQuery mode query = do
|
|
backend <- ask
|
|
let (builder, values) = ES.toRawSql mode (backend, ES.initialIdentState) query
|
|
return (ES.builderToText builder, values)
|