esqueleto-3.5.10.3: test/PostgreSQL/Test.hs
{-# 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.Concurrent (forkIO)
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, runReaderT)
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 qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB
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 qualified Database.Persist.Class as P
import Database.Persist.Postgresql (createPostgresqlPool, withPostgresqlConn)
import Database.PostgreSQL.Simple (ExecStatus(..), SqlError(..))
import System.Environment
import Test.Hspec
import Test.Hspec.Core.Spec (sequential)
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]
testPostgresqlLocking :: SpecDb
testPostgresqlLocking = do
describe "Monoid instance" $ do
let toText conn q =
let (tlb, _) = ES.toRawSql ES.SELECT (conn, ES.initialIdentState) q
in TLB.toLazyText tlb
itDb "concatenates postgres locking clauses" $ do
let multipleLockingQuery = do
p <- Experimental.from $ table @Person
EP.forUpdateOf p EP.skipLocked
EP.forUpdateOf p EP.skipLocked
EP.forShareOf p EP.skipLocked
conn <- ask
let res1 = toText conn multipleLockingQuery
resExpected =
TL.unlines
[
"SELECT 1"
,"FROM \"Person\""
,"FOR UPDATE OF \"Person\" SKIP LOCKED"
,"FOR UPDATE OF \"Person\" SKIP LOCKED"
,"FOR SHARE OF \"Person\" SKIP LOCKED"
]
asserting $ res1 `shouldBe` resExpected
describe "For update skip locked locking" $ sequential $ do
let mkInitialStateForLockingTest connection =
flip runSqlPool connection $ do
p1k <- insert p1
p2k <- insert p2
p3k <- insert p3
blogPosts <- mapM insert'
[ BlogPost "A" p1k
, BlogPost "B" p2k
, BlogPost "C" p3k ]
pure ([p1k, p2k, p3k], entityKey <$> blogPosts)
cleanupLockingTest connection (personKeys, blogPostKeys) =
flip runSqlPool connection $ do
forM_ blogPostKeys P.delete
forM_ personKeys P.delete
aroundWith (\testAction connection -> do
bracket (mkInitialStateForLockingTest connection) (cleanupLockingTest connection) $ \(personKeys, blogPostKeys) ->
testAction (connection, personKeys, blogPostKeys)
) $ do
it "skips locked rows for a locking select" $ \(connection, _, _) -> do
waitMainThread <- newEmptyMVar
let sideThread :: IO Expectation
sideThread = do
flip runSqlPool connection $ do
_ <- takeMVar waitMainThread
nonLockedRowsNonSpecified <-
select $ do
p <- Experimental.from $ table @Person
EP.forUpdateOf p EP.skipLocked
return p
nonLockedRowsSpecifiedTable <-
select $ do
from $ \(p `LeftOuterJoin` b) -> do
on (p ^. PersonId ==. b ^. BlogPostAuthorId)
EP.forUpdateOf p EP.skipLocked
return p
nonLockedRowsSpecifyAllTables <-
select $ do
from $ \(p `InnerJoin` b) -> do
on (p ^. PersonId ==. b ^. BlogPostAuthorId)
EP.forUpdateOf (p :& b) EP.skipLocked
return p
pure $ do
nonLockedRowsNonSpecified `shouldBe` []
nonLockedRowsSpecifiedTable `shouldBe` []
nonLockedRowsSpecifyAllTables `shouldBe` []
withAsync sideThread $ \sideThreadAsync -> do
void $ flip runSqlPool connection $ do
void $ select $ do
person <- Experimental.from $ table @Person
locking ForUpdate
pure $ person ^. PersonId
_ <- putMVar waitMainThread ()
sideThreadAsserts <- wait sideThreadAsync
nonLockedRowsAfterUpdate <- select $ do
from $ \(p `LeftOuterJoin` b) -> do
on (p ^. PersonId ==. b ^. BlogPostAuthorId)
EP.forUpdateOf p EP.skipLocked
return p
asserting sideThreadAsserts
asserting $ length nonLockedRowsAfterUpdate `shouldBe` 3
it "skips locked rows for a subselect update" $ \(connection, _, _)-> do
waitMainThread <- newEmptyMVar
let sideThread :: IO Expectation
sideThread =
flip runSqlPool connection $ do
_ <- liftIO $ takeMVar waitMainThread
nonLockedRowsSpecifiedTable <-
select $ do
from $ \(p `LeftOuterJoin` b) -> do
on (p ^. PersonId ==. b ^. BlogPostAuthorId)
EP.forUpdateOf p EP.skipLocked
return p
liftIO $ print nonLockedRowsSpecifiedTable
pure $ length nonLockedRowsSpecifiedTable `shouldBe` 2
withAsync sideThread $ \sideThreadAsync -> do
void $ flip runSqlPool connection $ do
update $ \p -> do
set p [ PersonName =. val "ChangedName1" ]
where_ $ p ^. PersonId
`in_` subList_select (do
person <- Experimental.from $ table @Person
where_ (person ^. PersonName ==. val "Rachel")
limit 1
locking ForUpdate
pure $ person ^. PersonId)
_ <- putMVar waitMainThread ()
sideThreadAsserts <- wait sideThreadAsync
nonLockedRowsAfterUpdate <- select $ do
from $ \(p `LeftOuterJoin` b) -> do
on (p ^. PersonId ==. b ^. BlogPostAuthorId)
EP.forUpdateOf p EP.skipLocked
return p
liftIO $ print nonLockedRowsAfterUpdate
asserting sideThreadAsserts
asserting $ length nonLockedRowsAfterUpdate `shouldBe` 3
it "skips locked rows for a subselect join update" $ \(connection, _, _) -> do
waitMainThread <- newEmptyMVar
let sideThread :: IO Expectation
sideThread =
flip runSqlPool connection $ do
liftIO $ takeMVar waitMainThread
lockedRows <-
select $ do
from $ \(p `LeftOuterJoin` b) -> do
on (p ^. PersonId ==. b ^. BlogPostAuthorId)
where_ (b ^. BlogPostTitle ==. val "A")
EP.forUpdateOf p EP.skipLocked
return p
nonLockedRows <-
select $ do
from $ \(p `LeftOuterJoin` b) -> do
on (p ^. PersonId ==. b ^. BlogPostAuthorId)
EP.forUpdateOf p EP.skipLocked
return p
pure $ do
lockedRows `shouldBe` []
length nonLockedRows `shouldBe` 2
withAsync sideThread $ \sideThreadAsync -> do
void $ flip runSqlPool connection $ do
update $ \p -> do
set p [ PersonName =. val "ChangedName" ]
where_ $ p ^. PersonId
`in_` subList_select (do
(people :& blogPosts) <-
Experimental.from $ table @Person
`Experimental.leftJoin` table @BlogPost
`Experimental.on` (\(people :& blogPosts) ->
just (people ^. PersonId) ==. blogPosts ?. BlogPostAuthorId)
where_ (blogPosts ?. BlogPostTitle ==. just (val "A"))
pure $ people ^. PersonId
)
liftIO $ putMVar waitMainThread ()
sideThreadAsserts <- wait sideThreadAsync
nonLockedRowsAfterUpdate <- select $ do
from $ \(p `LeftOuterJoin` b) -> do
on (p ^. PersonId ==. b ^. BlogPostAuthorId)
EP.forUpdateOf p EP.skipLocked
return p
asserting sideThreadAsserts
asserting $ length nonLockedRowsAfterUpdate `shouldBe` 3
describe "noWait" $ do
itDb "doesn't crash" $ do
select $ do
t <- Experimental.from $ table @Person
EP.forUpdateOf t EP.noWait
pure t
asserting noExceptions
-- 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) ]
testSubselectAliasingBehavior :: SpecDb
testSubselectAliasingBehavior = do
describe "Aliasing behavior" $ do
itDb "correctly realiases entities accross multiple subselects" $ do
_ <- select $ do
Experimental.from $ Experimental.from $ Experimental.from $ table @Lord
asserting noExceptions
itDb "doesnt erroneously repeat variable names when using subselect + union" $ do
let lordQuery = do
l <- Experimental.from $ table @Lord
pure (l ^. LordCounty, l ^. LordDogs)
personQuery = do
p <- Experimental.from $ table @Person
pure (p ^. PersonName, just $ p ^. PersonFavNum)
_ <- select $
Experimental.from $ do
(str, _) <- Experimental.from $ lordQuery `union_` personQuery
pure (str, val @Int 1)
asserting noExceptions
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
testSubselectAliasingBehavior
testPostgresqlLocking
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)