esqueleto-3.5.13.2: 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.forNoKeyUpdateOf p EP.skipLocked
EP.forShareOf p EP.skipLocked
EP.forKeyShareOf 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 NO KEY UPDATE OF \"Person\" SKIP LOCKED"
,"FOR SHARE OF \"Person\" SKIP LOCKED"
,"FOR KEY 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
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
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)