haskell/esqueleto
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
56e4b83e5c
esqueleto/test/Common/Test.hs
Ben Levy 56e4b83e5c
New syntax for Joins (Subquery + Union/Intersect/...) (#172) 
* It works?

* Add multiple return values back in

* Allow order by alias

* Support groupBy and count, Returning value from a fromQuery now will make it into an alias

* Eliminate Alias type, TODO: finish implementing all the functions on Value for the alias constructors

* Add entity support to subqueries

* Cleanup duplication; Cleanup warnings and finish implementing all the cases for aliased values and entities.

* Cleanup fromQuery and add comments

* Modify EValueReference to support aliased entity fields instead of having to use opaque ERaw in field access

* Implement SQL Set Operations

* Add test to show novel use of fromQuery

* Cleanup unsafe case statements

* Add type annotations to helper queries to satisfy the typechecker on older GHC

* New syntax for joins, using placeholder names with ' in them to avoid name conflict with existing join types.
New api properly enforces Maybe on outer joins and requires an on clause for all joins in their construction.

* Add some more test queries using the new syntax

* Add test to verify that delete works with the new syntax

* Add cross join and implicit cross join using comma examples to test code for new from syntax

* Comment out use of CrossJoin in common tests since postgres cant handle it with the current implementation of the CrossJoin kind

* Add typeclass machinery to support the use of the old Join data types used in the existing from clause

* Fix bug with CrossJoin and add on_ syntax sugar

* move new from syntax into Database.Esqueleto.Experimental

* Merge subqueries and unions with the new join syntax, they all seem to play nicely together

* Cleanup somehow copies of ToAlias ended up staying in Internal and a swp file made it in to the branch.

* Fix compilation errors

* Swith tuple to using a TypeOperator

* Make operator only 2 characters

* added up to 8-tuple instances for ToMaybe, ToAlias, and ToAliasReference

* Add compiler error tests for new syntax to support making better errors

* Use closed data families to allow for catching missing on statements in joins.

* Convert ToAliasReferenceT to be a closed type family matching the other classes in the Experimental module

* added Esqueleto.Experimental documentation: added introduction and several examples of old vs. new syntax

* added more usage examples to module introduction; added documentation to SqlSetOperation, From, on, from, and (:&)

* Update (^.) to only treat natural keys with more than one component as ECompositeKey. Fixes #176.

* Update article metadata test to ensure the correct response was being returned instead of just check if an exception was thrown

* Add article metadata to cleanDB before deleting all articles to fix foreign key constraint errors

* Bump version number and add changelog entry

* Fix issue with ToMaybeT for Values, Maybe was going in the wrong place compared to the rest of the library. Add test to prove that Left joining into a subquery that returns a maybe flattens the maybe properly to avoid needing to call joinV.

* Fix common test for postgres, needed to add dogCounts to the group by since postgres is strict on only agregates for non grouped columns; I really need to set up a local postgresql

* Revert ToFromT changes. Only accept functions that return a SqlExpr (Value Bool) in ToFromT

* escaped use of '@' in TypeApplications in documentation

* Add more specific type signature to `on`

per parsonsmatt review suggestion. Improves type inference significantly.

Co-Authored-By: Matt Parsons <parsonsmatt@gmail.com>

Co-authored-by: charukiewicz <c.charukiewicz@gmail.com>
Co-authored-by: Matt Parsons <parsonsmatt@gmail.com>
2020-03-29 10:40:49 -06:00

2603 lines
87 KiB
Haskell
Raw Blame History

{-# OPTIONS_GHC -fno-warn-unused-binds #-}
{-# OPTIONS_GHC -fno-warn-deprecations #-}
{-# LANGUAGE ConstraintKinds
, CPP, DerivingStrategies, StandaloneDeriving
, TypeApplications
, PartialTypeSignatures
, UndecidableInstances
, EmptyDataDecls
, FlexibleContexts
, FlexibleInstances
, DeriveGeneric
, GADTs
, GeneralizedNewtypeDeriving
, MultiParamTypeClasses
, OverloadedStrings
, QuasiQuotes
, Rank2Types
, TemplateHaskell
, TypeFamilies
, ScopedTypeVariables
, TypeSynonymInstances
#-}
module Common.Test
( tests
, testLocking
, testAscRandom
, testRandomMath
, migrateAll
, migrateUnique
, cleanDB
, cleanUniques
, RunDbMonad
, Run
, p1, p2, p3, p4, p5
, l1, l2, l3
, u1, u2, u3, u4
, insert'
, EntityField (..)
, Foo (..)
, Bar (..)
, Person (..)
, BlogPost (..)
, Lord (..)
, Deed (..)
, Follow (..)
, CcList (..)
, Frontcover (..)
, Article (..)
, Tag (..)
, ArticleTag (..)
, Article2 (..)
, Point (..)
, Circle (..)
, Numbers (..)
, OneUnique(..)
, Unique(..)
) where
import Data.Either
import Control.Monad (forM_, replicateM, replicateM_, void)
import Control.Monad.Reader (ask)
import Control.Monad.Catch (MonadCatch)
#if __GLASGOW_HASKELL__ >= 806
import Control.Monad.Fail (MonadFail)
#endif
import Control.Monad.IO.Class (MonadIO(liftIO))
import Control.Monad.Logger (MonadLogger (..), NoLoggingT, runNoLoggingT)
import Control.Monad.Trans.Reader (ReaderT)
import Data.Char (toLower, toUpper)
import Data.Monoid ((<>))
import Database.Esqueleto
import Database.Esqueleto.Experimental hiding (from, on)
import qualified Database.Esqueleto.Experimental as Experimental
import Database.Persist.TH
import Test.Hspec
import UnliftIO
import qualified Data.Attoparsec.Text as AP
import Data.Conduit (ConduitT, (.|), runConduit)
import qualified Data.Conduit.List as CL
import qualified Data.List as L
import qualified Data.Set as S
import qualified Data.Text as Text
import qualified Data.Text.Lazy.Builder as TLB
import qualified Data.Text.Internal.Lazy as TL
import qualified Database.Esqueleto.Internal.Sql as EI
import qualified UnliftIO.Resource as R
import qualified Database.Esqueleto.Internal.ExprParser as P
-- Test schema
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|
Foo
name Int
Primary name
deriving Show Eq Ord
Bar
quux FooId
deriving Show Eq Ord
Baz
blargh FooId
deriving Show Eq
Shoop
baz BazId
deriving Show Eq
Asdf
shoop ShoopId
deriving Show Eq
Another
why BazId
YetAnother
argh ShoopId
Person
name String
age Int Maybe
weight Int Maybe
favNum Int
deriving Eq Show Ord
BlogPost
title String
authorId PersonId
deriving Eq Show
Comment
body String
blog BlogPostId
deriving Eq Show
CommentReply
body String
comment CommentId
Profile
name String
person PersonId
deriving Eq Show
Reply
guy PersonId
body String
deriving Eq Show
Lord
county String maxlen=100
dogs Int Maybe
Primary county
deriving Eq Show
Deed
contract String maxlen=100
ownerId LordId maxlen=100
Primary contract
deriving Eq Show
Follow
follower PersonId
followed PersonId
deriving Eq Show
CcList
names [String]
Frontcover
number Int
title String
Primary number
deriving Eq Show
Article
title String
frontcoverNumber Int
Foreign Frontcover fkfrontcover frontcoverNumber
deriving Eq Show
ArticleMetadata
articleId ArticleId
Primary articleId
deriving Eq Show
Tag
name String maxlen=100
Primary name
deriving Eq Show
ArticleTag
articleId ArticleId
tagId TagId maxlen=100
Primary articleId tagId
deriving Eq Show
Article2
title String
frontcoverId FrontcoverId
deriving Eq Show
Point
x Int
y Int
name String
Primary x y
deriving Eq Show
Circle
centerX Int
centerY Int
name String
Foreign Point fkpoint centerX centerY
deriving Eq Show
Numbers
int Int
double Double
deriving Eq Show
JoinOne
name String
deriving Eq Show
JoinTwo
joinOne JoinOneId
name String
deriving Eq Show
JoinThree
joinTwo JoinTwoId
name String
deriving Eq Show
JoinFour
name String
joinThree JoinThreeId
deriving Eq Show
JoinOther
name String
deriving Eq Show
JoinMany
name String
joinOther JoinOtherId
joinOne JoinOneId
deriving Eq Show
|]
-- Unique Test schema
share [mkPersist sqlSettings, mkMigrate "migrateUnique"] [persistUpperCase|
OneUnique
name String
value Int
UniqueValue value
deriving Eq Show
|]
-- | this could be achieved with S.fromList, but not all lists
-- have Ord instances
sameElementsAs :: Eq a => [a] -> [a] -> Bool
sameElementsAs l1' l2' = null (l1' L.\\ l2')
-- | Helper for rounding to a specific digit
-- Prelude> map (flip roundTo 12.3456) [0..5]
-- [12.0, 12.3, 12.35, 12.346, 12.3456, 12.3456]
roundTo :: (Fractional a, RealFrac a1, Integral b) => b -> a1 -> a
roundTo n f =
(fromInteger $ round $ f * (10^n)) / (10.0^^n)
p1 :: Person
p1 = Person "John" (Just 36) Nothing 1
p2 :: Person
p2 = Person "Rachel" Nothing (Just 37) 2
p3 :: Person
p3 = Person "Mike" (Just 17) Nothing 3
p4 :: Person
p4 = Person "Livia" (Just 17) (Just 18) 4
p5 :: Person
p5 = Person "Mitch" Nothing Nothing 5
l1 :: Lord
l1 = Lord "Cornwall" (Just 36)
l2 :: Lord
l2 = Lord "Dorset" Nothing
l3 :: Lord
l3 = Lord "Chester" (Just 17)
u1 :: OneUnique
u1 = OneUnique "First" 0
u2 :: OneUnique
u2 = OneUnique "Second" 1
u3 :: OneUnique
u3 = OneUnique "Third" 0
u4 :: OneUnique
u4 = OneUnique "First" 2
testSelect :: Run -> Spec
testSelect run = do
describe "select" $ do
it "works for a single value" $
run $ do
ret <- select $ return $ val (3 :: Int)
liftIO $ ret `shouldBe` [ Value 3 ]
it "works for a pair of a single value and ()" $
run $ do
ret <- select $ return (val (3 :: Int), ())
liftIO $ ret `shouldBe` [ (Value 3, ()) ]
it "works for a single ()" $
run $ do
ret <- select $ return ()
liftIO $ ret `shouldBe` [ () ]
it "works for a single NULL value" $
run $ do
ret <- select $ return nothing
liftIO $ ret `shouldBe` [ Value (Nothing :: Maybe Int) ]
testSubSelect :: Run -> Spec
testSubSelect run = do
let
setup :: MonadIO m => SqlPersistT m ()
setup = do
_ <- insert $ Numbers 1 2
_ <- insert $ Numbers 2 4
_ <- insert $ Numbers 3 5
_ <- insert $ Numbers 6 7
pure ()
describe "subSelect" $ do
it "is safe for queries that may return multiple results" $ do
let
query =
from $ \n -> do
orderBy [asc (n ^. NumbersInt)]
pure (n ^. NumbersInt)
res <- run $ do
setup
select $ pure $ subSelect query
res `shouldBe` [Value (Just 1)]
eres <- try $ run $ do
setup
select $ pure $ sub_select query
case eres of
Left (SomeException _) ->
-- We should receive an exception, but the different database
-- libraries throw different exceptions. Hooray.
pure ()
Right v ->
-- This shouldn't happen, but in sqlite land, many things are
-- possible.
v `shouldBe` [Value 1]
it "is safe for queries that may not return anything" $ do
let
query =
from $ \n -> do
orderBy [asc (n ^. NumbersInt)]
limit 1
pure (n ^. NumbersInt)
res <- run $ select $ pure $ subSelect query
res `shouldBe` [Value Nothing]
eres <- try $ run $ do
setup
select $ pure $ sub_select query
case eres of
Left (_ :: PersistException) ->
-- We expect to receive this exception. However, sqlite evidently has
-- no problems with it, so we can't *require* that the exception is
-- thrown. Sigh.
pure ()
Right v ->
-- This shouldn't happen, but in sqlite land, many things are
-- possible.
v `shouldBe` [Value 1]
describe "subSelectList" $ do
it "is safe on empty databases as well as good databases" $ do
let
query =
from $ \n -> do
where_ $ n ^. NumbersInt `in_` do
subSelectList $
from $ \n' -> do
where_ $ n' ^. NumbersInt >=. val 3
pure (n' ^. NumbersInt)
pure n
empty <- run $ do
select query
full <- run $ do
setup
select query
empty `shouldBe` []
full `shouldSatisfy` (not . null)
describe "subSelectMaybe" $ do
it "is equivalent to joinV . subSelect" $ do
let
query
:: ( SqlQuery (SqlExpr (Value (Maybe Int)))
-> SqlExpr (Value (Maybe Int))
)
-> SqlQuery (SqlExpr (Value (Maybe Int)))
query selector =
from $ \n -> do
pure $
selector $
from $ \n' -> do
where_ $ n' ^. NumbersDouble >=. n ^. NumbersDouble
pure (max_ (n' ^. NumbersInt))
a <- run $ do
setup
select (query subSelectMaybe)
b <- run $ do
setup
select (query (joinV . subSelect))
a `shouldBe` b
describe "subSelectCount" $ do
it "is a safe way to do a countRows" $ do
xs0 <- run $ do
setup
select $
from $ \n -> do
pure $ (,) n $
subSelectCount @Int $
from $ \n' -> do
where_ $ n' ^. NumbersInt >=. n ^. NumbersInt
xs1 <- run $ do
setup
select $
from $ \n -> do
pure $ (,) n $
subSelectUnsafe $
from $ \n' -> do
where_ $ n' ^. NumbersInt >=. n ^. NumbersInt
pure (countRows :: SqlExpr (Value Int))
let getter (Entity _ a, b) = (a, b)
map getter xs0 `shouldBe` map getter xs1
describe "subSelectUnsafe" $ do
it "throws exceptions on multiple results" $ do
eres <- try $ run $ do
setup
bad <- select $
from $ \n -> do
pure $ (,) (n ^. NumbersInt) $
subSelectUnsafe $
from $ \n' -> do
pure (just (n' ^. NumbersDouble))
good <- select $
from $ \n -> do
pure $ (,) (n ^. NumbersInt) $
subSelect $
from $ \n' -> do
pure (n' ^. NumbersDouble)
pure (bad, good)
case eres of
Left (SomeException _) ->
-- Must use SomeException because the database libraries throw their
-- own errors.
pure ()
Right (bad, good) -> do
-- SQLite just takes the first element of the sub-select. lol.
--
bad `shouldBe` good
it "throws exceptions on null results" $ do
eres <- try $ run $ do
setup
select $
from $ \n -> do
pure $ (,) (n ^. NumbersInt) $
subSelectUnsafe $
from $ \n' -> do
where_ $ val False
pure (n' ^. NumbersDouble)
case eres of
Left (_ :: PersistException) ->
pure ()
Right xs ->
xs `shouldBe` []
testSelectSource :: Run -> Spec
testSelectSource run = do
describe "selectSource" $ do
it "works for a simple example" $
run $ do
let query = selectSource $
from $ \person ->
return person
p1e <- insert' p1
ret <- runConduit $ query .| CL.consume
liftIO $ ret `shouldBe` [ p1e ]
it "can run a query many times" $
run $ do
let query = selectSource $
from $ \person ->
return person
p1e <- insert' p1
ret0 <- runConduit $ query .| CL.consume
ret1 <- runConduit $ query .| CL.consume
liftIO $ ret0 `shouldBe` [ p1e ]
liftIO $ ret1 `shouldBe` [ p1e ]
it "works on repro" $ do
let selectPerson :: R.MonadResource m => String -> ConduitT () (Key Person) (SqlPersistT m) ()
selectPerson name = do
let source = selectSource $ from $ \person -> do
where_ $ person ^. PersonName ==. val name
return $ person ^. PersonId
source .| CL.map unValue
run $ do
p1e <- insert' p1
p2e <- insert' p2
r1 <- runConduit $
selectPerson (personName p1) .| CL.consume
r2 <- runConduit $
selectPerson (personName p2) .| CL.consume
liftIO $ do
r1 `shouldBe` [ entityKey p1e ]
r2 `shouldBe` [ entityKey p2e ]
testSelectFrom :: Run -> Spec
testSelectFrom run = do
describe "select/from" $ do
it "works for a simple example" $
run $ do
p1e <- insert' p1
ret <- select $
from $ \person ->
return person
liftIO $ ret `shouldBe` [ p1e ]
it "works for a simple self-join (one entity)" $
run $ do
p1e <- insert' p1
ret <- select $
from $ \(person1, person2) ->
return (person1, person2)
liftIO $ ret `shouldBe` [ (p1e, p1e) ]
it "works for a simple self-join (two entities)" $
run $ do
p1e <- insert' p1
p2e <- insert' p2
ret <- select $
from $ \(person1, person2) ->
return (person1, person2)
liftIO $ ret `shouldSatisfy` sameElementsAs [ (p1e, p1e)
, (p1e, p2e)
, (p2e, p1e)
, (p2e, p2e) ]
it "works for a self-join via sub_select" $
run $ do
p1k <- insert p1
p2k <- insert p2
_f1k <- insert (Follow p1k p2k)
_f2k <- insert (Follow p2k p1k)
ret <- select $
from $ \followA -> do
let subquery =
from $ \followB -> do
where_ $ followA ^. FollowFollower ==. followB ^. FollowFollowed
return $ followB ^. FollowFollower
where_ $ followA ^. FollowFollowed ==. sub_select subquery
return followA
liftIO $ length ret `shouldBe` 2
it "works for a self-join via exists" $
run $ do
p1k <- insert p1
p2k <- insert p2
_f1k <- insert (Follow p1k p2k)
_f2k <- insert (Follow p2k p1k)
ret <- select $
from $ \followA -> do
where_ $ exists $
from $ \followB ->
where_ $ followA ^. FollowFollower ==. followB ^. FollowFollowed
return followA
liftIO $ length ret `shouldBe` 2
it "works for a simple projection" $
run $ do
p1k <- insert p1
p2k <- insert p2
ret <- select $
from $ \p ->
return (p ^. PersonId, p ^. PersonName)
liftIO $ ret `shouldBe` [ (Value p1k, Value (personName p1))
, (Value p2k, Value (personName p2)) ]
it "works for a simple projection with a simple implicit self-join" $
run $ do
_ <- insert p1
_ <- insert p2
ret <- select $
from $ \(pa, pb) ->
return (pa ^. PersonName, pb ^. PersonName)
liftIO $ ret `shouldSatisfy` sameElementsAs
[ (Value (personName p1), Value (personName p1))
, (Value (personName p1), Value (personName p2))
, (Value (personName p2), Value (personName p1))
, (Value (personName p2), Value (personName p2)) ]
it "works with many kinds of LIMITs and OFFSETs" $
run $ do
[p1e, p2e, p3e, p4e] <- mapM insert' [p1, p2, p3, p4]
let people = from $ \p -> do
orderBy [asc (p ^. PersonName)]
return p
ret1 <- select $ do
p <- people
limit 2
limit 1
return p
liftIO $ ret1 `shouldBe` [ p1e ]
ret2 <- select $ do
p <- people
limit 1
limit 2
return p
liftIO $ ret2 `shouldBe` [ p1e, p4e ]
ret3 <- select $ do
p <- people
offset 3
offset 2
return p
liftIO $ ret3 `shouldBe` [ p3e, p2e ]
ret4 <- select $ do
p <- people
offset 3
limit 5
offset 2
limit 3
offset 1
limit 2
return p
liftIO $ ret4 `shouldBe` [ p4e, p3e ]
ret5 <- select $ do
p <- people
offset 1000
limit 1
limit 1000
offset 0
return p
liftIO $ ret5 `shouldBe` [ p1e, p4e, p3e, p2e ]
it "works with non-id primary key" $
run $ do
let fc = Frontcover number ""
number = 101
Right thePk = keyFromValues [toPersistValue number]
fcPk <- insert fc
[Entity _ ret] <- select $ from return
liftIO $ do
ret `shouldBe` fc
fcPk `shouldBe` thePk
it "works when returning a custom non-composite primary key from a query" $
run $ do
let name = "foo"
t = Tag name
Right thePk = keyFromValues [toPersistValue name]
tagPk <- insert t
[Value ret] <- select $ from $ \t' -> return (t'^.TagId)
liftIO $ do
ret `shouldBe` thePk
thePk `shouldBe` tagPk
it "works when returning a composite primary key from a query" $
run $ do
let p = Point 10 20 ""
thePk <- insert p
[Value ppk] <- select $ from $ \p' -> return (p'^.PointId)
liftIO $ ppk `shouldBe` thePk
testSelectJoin :: Run -> Spec
testSelectJoin run = do
describe "select:JOIN" $ do
it "works with a LEFT OUTER JOIN" $
run $ do
p1e <- insert' p1
p2e <- insert' p2
p3e <- insert' p3
p4e <- insert' p4
b12e <- insert' $ BlogPost "b" (entityKey p1e)
b11e <- insert' $ BlogPost "a" (entityKey p1e)
b31e <- insert' $ BlogPost "c" (entityKey p3e)
ret <- select $
from $ \(p `LeftOuterJoin` mb) -> do
on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId)
orderBy [ asc (p ^. PersonName), asc (mb ?. BlogPostTitle) ]
return (p, mb)
liftIO $ ret `shouldBe` [ (p1e, Just b11e)
, (p1e, Just b12e)
, (p4e, Nothing)
, (p3e, Just b31e)
, (p2e, Nothing) ]
it "typechecks (A LEFT OUTER JOIN (B LEFT OUTER JOIN C))" $
let _ = run $
select $
from $ \(a `LeftOuterJoin` (b `LeftOuterJoin` c)) ->
let _ = [a, b, c] :: [ SqlExpr (Entity Person) ]
in return a
in return () :: IO ()
it "typechecks ((A LEFT OUTER JOIN B) LEFT OUTER JOIN C)" $
let _ = run $
select $
from $ \((a `LeftOuterJoin` b) `LeftOuterJoin` c) ->
let _ = [a, b, c] :: [ SqlExpr (Entity Person) ]
in return a
in return () :: IO ()
it "throws an error for using on without joins" $
run (select $
from $ \(p, mb) -> do
on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId)
orderBy [ asc (p ^. PersonName), asc (mb ?. BlogPostTitle) ]
return (p, mb)
) `shouldThrow` (\(OnClauseWithoutMatchingJoinException _) -> True)
it "throws an error for using too many ons" $
run (select $
from $ \(p `FullOuterJoin` mb) -> do
on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId)
on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId)
orderBy [ asc (p ^. PersonName), asc (mb ?. BlogPostTitle) ]
return (p, mb)
) `shouldThrow` (\(OnClauseWithoutMatchingJoinException _) -> True)
it "works with ForeignKey to a non-id primary key returning one entity" $
run $ do
let fc = Frontcover number ""
article = Article "Esqueleto supports composite pks!" number
number = 101
Right thePk = keyFromValues [toPersistValue number]
fcPk <- insert fc
insert_ article
[Entity _ retFc] <- select $
from $ \(a `InnerJoin` f) -> do
on (f^.FrontcoverNumber ==. a^.ArticleFrontcoverNumber)
return f
liftIO $ do
retFc `shouldBe` fc
fcPk `shouldBe` thePk
it "allows using a primary key that is itself a key of another table" $
run $ do
let number = 101
insert_ $ Frontcover number ""
articleId <- insert $ Article "title" number
articleMetaE <- insert' (ArticleMetadata articleId)
result <- select . from $ \articleMetadata -> do
where_ $ (articleMetadata ^. ArticleMetadataId) ==. (val ((ArticleMetadataKey articleId)))
pure articleMetadata
liftIO $ [articleMetaE] `shouldBe` result
it "works with a ForeignKey to a non-id primary key returning both entities" $
run $ do
let fc = Frontcover number ""
article = Article "Esqueleto supports composite pks!" number
number = 101
Right thePk = keyFromValues [toPersistValue number]
fcPk <- insert fc
insert_ article
[(Entity _ retFc, Entity _ retArt)] <- select $
from $ \(a `InnerJoin` f) -> do
on (f^.FrontcoverNumber ==. a^.ArticleFrontcoverNumber)
return (f, a)
liftIO $ do
retFc `shouldBe` fc
retArt `shouldBe` article
fcPk `shouldBe` thePk
articleFkfrontcover retArt `shouldBe` thePk
it "works with a non-id primary key returning one entity" $
run $ do
let fc = Frontcover number ""
article = Article2 "Esqueleto supports composite pks!" thePk
number = 101
Right thePk = keyFromValues [toPersistValue number]
fcPk <- insert fc
insert_ article
[Entity _ retFc] <- select $
from $ \(a `InnerJoin` f) -> do
on (f^.FrontcoverId ==. a^.Article2FrontcoverId)
return f
liftIO $ do
retFc `shouldBe` fc
fcPk `shouldBe` thePk
it "works with a composite primary key" $
pendingWith "Persistent does not create the CircleFkPoint constructor. See: https://github.com/yesodweb/persistent/issues/341"
{-
run $ do
let p = Point x y ""
c = Circle x y ""
x = 10
y = 15
Right thePk = keyFromValues [toPersistValue x, toPersistValue y]
pPk <- insert p
insert_ c
[Entity _ ret] <- select $ from $ \(c' `InnerJoin` p') -> do
on (p'^.PointId ==. c'^.CircleFkpoint)
return p'
liftIO $ do
ret `shouldBe` p
pPk `shouldBe` thePk
-}
it "works when joining via a non-id primary key" $
run $ do
let fc = Frontcover number ""
article = Article "Esqueleto supports composite pks!" number
tag = Tag "foo"
otherTag = Tag "ignored"
number = 101
insert_ fc
insert_ otherTag
artId <- insert article
tagId <- insert tag
insert_ $ ArticleTag artId tagId
[(Entity _ retArt, Entity _ retTag)] <- select $
from $ \(a `InnerJoin` at `InnerJoin` t) -> do
on (t^.TagId ==. at^.ArticleTagTagId)
on (a^.ArticleId ==. at^.ArticleTagArticleId)
return (a, t)
liftIO $ do
retArt `shouldBe` article
retTag `shouldBe` tag
it "respects the associativity of joins" $
run $ do
void $ insert p1
ps <- select . from $
\((p :: SqlExpr (Entity Person))
`LeftOuterJoin`
((_q :: SqlExpr (Entity Person))
`InnerJoin` (_r :: SqlExpr (Entity Person)))) -> do
on (val False) -- Inner join is empty
on (val True)
return p
liftIO $ (entityVal <$> ps) `shouldBe` [p1]
testSelectSubQuery :: Run -> Spec
testSelectSubQuery run = do
describe "select subquery" $ do
it "works" $ do
run $ do
_ <- insert' p1
let q = do
p <- Experimental.from $ Table @Person
return ( p ^. PersonName, p ^. PersonAge)
ret <- select $ Experimental.from $ SelectQuery q
liftIO $ ret `shouldBe` [ (Value $ personName p1, Value $ personAge p1) ]
it "lets you order by alias" $ do
run $ do
_ <- insert' p1
_ <- insert' p3
let q = do
(name, age) <-
Experimental.from $ SubQuery $ do
p <- Experimental.from $ Table @Person
return ( p ^. PersonName, p ^. PersonAge)
orderBy [ asc age ]
pure name
ret <- select q
liftIO $ ret `shouldBe` [ Value $ personName p3, Value $ personName p1 ]
it "supports groupBy" $ do
run $ do
l1k <- insert l1
l3k <- insert l3
mapM_ (\k -> insert $ Deed k l1k) (map show [1..3 :: Int])
mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int])
let q = do
(lord :& deed) <- Experimental.from $ Table @Lord
`InnerJoin` Table @Deed
`Experimental.on` (\(lord :& deed) ->
lord ^. LordId ==. deed ^. DeedOwnerId)
return (lord ^. LordId, deed ^. DeedId)
q' = do
(lordId, deedId) <- Experimental.from $ SubQuery q
groupBy (lordId)
return (lordId, count deedId)
(ret :: [(Value (Key Lord), Value Int)]) <- select q'
liftIO $ ret `shouldMatchList` [ (Value l3k, Value 7)
, (Value l1k, Value 3) ]
it "Can count results of aggregate query" $ do
run $ do
l1k <- insert l1
l3k <- insert l3
mapM_ (\k -> insert $ Deed k l1k) (map show [1..3 :: Int])
mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int])
let q = do
(lord :& deed) <- Experimental.from $ Table @Lord
`InnerJoin` Table @Deed
`Experimental.on` (\(lord :& deed) ->
lord ^. LordId ==. deed ^. DeedOwnerId)
groupBy (lord ^. LordId)
return (lord ^. LordId, count (deed ^. DeedId))
(ret :: [(Value Int)]) <- select $ do
(lordId, deedCount) <- Experimental.from $ SubQuery q
where_ $ deedCount >. val (3 :: Int)
return (count lordId)
liftIO $ ret `shouldMatchList` [ (Value 1) ]
it "joins on subqueries" $ do
run $ do
l1k <- insert l1
l3k <- insert l3
mapM_ (\k -> insert $ Deed k l1k) (map show [1..3 :: Int])
mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int])
let q = do
(lord :& deed) <- Experimental.from $ Table @Lord
`InnerJoin` (SelectQuery $ Experimental.from $ Table @Deed)
`Experimental.on` (\(lord :& deed) ->
lord ^. LordId ==. deed ^. DeedOwnerId)
groupBy (lord ^. LordId)
return (lord ^. LordId, count (deed ^. DeedId))
(ret :: [(Value (Key Lord), Value Int)]) <- select q
liftIO $ ret `shouldMatchList` [ (Value l3k, Value 7)
, (Value l1k, Value 3) ]
it "flattens maybe values" $ do
run $ do
l1k <- insert l1
l3k <- insert l3
let q = do
(lord :& (_, dogCounts)) <- Experimental.from $ Table @Lord
`LeftOuterJoin` (SelectQuery $ do
lord <- Experimental.from $ Table @Lord
pure (lord ^. LordId, lord ^. LordDogs)
)
`Experimental.on` (\(lord :& (lordId, _)) ->
just (lord ^. LordId) ==. lordId)
groupBy (lord ^. LordId, dogCounts)
return (lord ^. LordId, dogCounts)
(ret :: [(Value (Key Lord), Value (Maybe Int))]) <- select q
liftIO $ ret `shouldMatchList` [ (Value l3k, Value (lordDogs l3))
, (Value l1k, Value (lordDogs l1)) ]
it "unions" $ do
run $ do
_ <- insert p1
_ <- insert p2
let q = Experimental.from $
(SelectQuery $ do
p <- Experimental.from $ Table @Person
where_ $ not_ $ isNothing $ p ^. PersonAge
return (p ^. PersonName))
`Union`
(SelectQuery $ do
p <- Experimental.from $ Table @Person
where_ $ isNothing $ p ^. PersonAge
return (p ^. PersonName))
`Union`
(SelectQuery $ do
p <- Experimental.from $ Table @Person
where_ $ isNothing $ p ^. PersonAge
return (p ^. PersonName))
names <- select q
liftIO $ names `shouldMatchList` [ (Value $ personName p1)
, (Value $ personName p2) ]
testSelectWhere :: Run -> Spec
testSelectWhere run = do
describe "select where_" $ do
it "works for a simple example with (==.)" $
run $ do
p1e <- insert' p1
_ <- insert' p2
_ <- insert' p3
ret <- select $
from $ \p -> do
where_ (p ^. PersonName ==. val "John")
return p
liftIO $ ret `shouldBe` [ p1e ]
it "works for a simple example with (==.) and (||.)" $
run $ do
p1e <- insert' p1
p2e <- insert' p2
_ <- insert' p3
ret <- select $
from $ \p -> do
where_ (p ^. PersonName ==. val "John" ||. p ^. PersonName ==. val "Rachel")
return p
liftIO $ ret `shouldBe` [ p1e, p2e ]
it "works for a simple example with (>.) [uses val . Just]" $
run $ do
p1e <- insert' p1
_ <- insert' p2
_ <- insert' p3
ret <- select $
from $ \p -> do
where_ (p ^. PersonAge >. val (Just 17))
return p
liftIO $ ret `shouldBe` [ p1e ]
it "works for a simple example with (>.) and not_ [uses just . val]" $
run $ do
_ <- insert' p1
_ <- insert' p2
p3e <- insert' p3
ret <- select $
from $ \p -> do
where_ (not_ $ p ^. PersonAge >. just (val 17))
return p
liftIO $ ret `shouldBe` [ p3e ]
describe "when using between" $ do
it "works for a simple example with [uses just . val]" $
run $ do
p1e <- insert' p1
_ <- insert' p2
_ <- insert' p3
ret <- select $
from $ \p -> do
where_ ((p ^. PersonAge) `between` (just $ val 20, just $ val 40))
return p
liftIO $ ret `shouldBe` [ p1e ]
it "works for a proyected fields value" $
run $ do
_ <- insert' p1 >> insert' p2 >> insert' p3
ret <-
select $
from $ \p -> do
where_ $
just (p ^. PersonFavNum)
`between`
(p ^. PersonAge, p ^. PersonWeight)
liftIO $ ret `shouldBe` []
describe "when projecting composite keys" $ do
it "works when using composite keys with val" $
run $ do
insert_ $ Point 1 2 ""
ret <-
select $
from $ \p -> do
where_ $
p ^. PointId
`between`
( val $ PointKey 1 2
, val $ PointKey 5 6 )
liftIO $ ret `shouldBe` [()]
it "works when using ECompositeKey constructor" $
run $ do
insert_ $ Point 1 2 ""
ret <-
select $
from $ \p -> do
where_ $
p ^. PointId
`between`
( EI.ECompositeKey $ const ["3", "4"]
, EI.ECompositeKey $ const ["5", "6"] )
liftIO $ ret `shouldBe` []
it "works with avg_" $
run $ do
_ <- insert' p1
_ <- insert' p2
_ <- insert' p3
_ <- insert' p4
ret <- select $
from $ \p->
return $ joinV $ avg_ (p ^. PersonAge)
let testV :: Double
testV = roundTo (4 :: Integer) $ (36 + 17 + 17) / (3 :: Double)
retV :: [Value (Maybe Double)]
retV = map (Value . fmap (roundTo (4 :: Integer)) . unValue) (ret :: [Value (Maybe Double)])
liftIO $ retV `shouldBe` [ Value $ Just testV ]
it "works with min_" $
run $ do
_ <- insert' p1
_ <- insert' p2
_ <- insert' p3
_ <- insert' p4
ret <- select $
from $ \p->
return $ joinV $ min_ (p ^. PersonAge)
liftIO $ ret `shouldBe` [ Value $ Just (17 :: Int) ]
it "works with max_" $
run $ do
_ <- insert' p1
_ <- insert' p2
_ <- insert' p3
_ <- insert' p4
ret <- select $
from $ \p->
return $ joinV $ max_ (p ^. PersonAge)
liftIO $ ret `shouldBe` [ Value $ Just (36 :: Int) ]
it "works with lower_" $
run $ do
p1e <- insert' p1
p2e@(Entity _ bob) <- insert' $ Person "bob" (Just 36) Nothing 1
-- lower(name) == 'john'
ret1 <- select $
from $ \p-> do
where_ (lower_ (p ^. PersonName) ==. val (map toLower $ personName p1))
return p
liftIO $ ret1 `shouldBe` [ p1e ]
-- name == lower('BOB')
ret2 <- select $
from $ \p-> do
where_ (p ^. PersonName ==. lower_ (val $ map toUpper $ personName bob))
return p
liftIO $ ret2 `shouldBe` [ p2e ]
it "works with round_" $
run $ do
ret <- select $ return $ round_ (val (16.2 :: Double))
liftIO $ ret `shouldBe` [ Value (16 :: Double) ]
it "works with isNothing" $
run $ do
_ <- insert' p1
p2e <- insert' p2
_ <- insert' p3
ret <- select $
from $ \p -> do
where_ $ isNothing (p ^. PersonAge)
return p
liftIO $ ret `shouldBe` [ p2e ]
it "works with not_ . isNothing" $
run $ do
p1e <- insert' p1
_ <- insert' p2
ret <- select $
from $ \p -> do
where_ $ not_ (isNothing (p ^. PersonAge))
return p
liftIO $ ret `shouldBe` [ p1e ]
it "works for a many-to-many implicit join" $
run $ do
p1e@(Entity p1k _) <- insert' p1
p2e@(Entity p2k _) <- insert' p2
_ <- insert' p3
p4e@(Entity p4k _) <- insert' p4
f12 <- insert' (Follow p1k p2k)
f21 <- insert' (Follow p2k p1k)
f42 <- insert' (Follow p4k p2k)
f11 <- insert' (Follow p1k p1k)
ret <- select $
from $ \(follower, follows, followed) -> do
where_ $ follower ^. PersonId ==. follows ^. FollowFollower &&.
followed ^. PersonId ==. follows ^. FollowFollowed
orderBy [ asc (follower ^. PersonName)
, asc (followed ^. PersonName) ]
return (follower, follows, followed)
liftIO $ ret `shouldBe` [ (p1e, f11, p1e)
, (p1e, f12, p2e)
, (p4e, f42, p2e)
, (p2e, f21, p1e) ]
it "works for a many-to-many explicit join" $
run $ do
p1e@(Entity p1k _) <- insert' p1
p2e@(Entity p2k _) <- insert' p2
_ <- insert' p3
p4e@(Entity p4k _) <- insert' p4
f12 <- insert' (Follow p1k p2k)
f21 <- insert' (Follow p2k p1k)
f42 <- insert' (Follow p4k p2k)
f11 <- insert' (Follow p1k p1k)
ret <- select $
from $ \(follower `InnerJoin` follows `InnerJoin` followed) -> do
on $ followed ^. PersonId ==. follows ^. FollowFollowed
on $ follower ^. PersonId ==. follows ^. FollowFollower
orderBy [ asc (follower ^. PersonName)
, asc (followed ^. PersonName) ]
return (follower, follows, followed)
liftIO $ ret `shouldBe` [ (p1e, f11, p1e)
, (p1e, f12, p2e)
, (p4e, f42, p2e)
, (p2e, f21, p1e) ]
it "works for a many-to-many explicit join and on order doesn't matter" $ do
run $ void $
selectRethrowingQuery $
from $ \(person `InnerJoin` blog `InnerJoin` comment) -> do
on $ person ^. PersonId ==. blog ^. BlogPostAuthorId
on $ blog ^. BlogPostId ==. comment ^. CommentBlog
pure (person, comment)
-- we only care that we don't have a SQL error
True `shouldBe` True
it "works for a many-to-many explicit join with LEFT OUTER JOINs" $
run $ do
p1e@(Entity p1k _) <- insert' p1
p2e@(Entity p2k _) <- insert' p2
p3e <- insert' p3
p4e@(Entity p4k _) <- insert' p4
f12 <- insert' (Follow p1k p2k)
f21 <- insert' (Follow p2k p1k)
f42 <- insert' (Follow p4k p2k)
f11 <- insert' (Follow p1k p1k)
ret <- select $
from $ \(follower `LeftOuterJoin` mfollows `LeftOuterJoin` mfollowed) -> do
on $ mfollowed ?. PersonId ==. mfollows ?. FollowFollowed
on $ just (follower ^. PersonId) ==. mfollows ?. FollowFollower
orderBy [ asc ( follower ^. PersonName)
, asc (mfollowed ?. PersonName) ]
return (follower, mfollows, mfollowed)
liftIO $ ret `shouldBe` [ (p1e, Just f11, Just p1e)
, (p1e, Just f12, Just p2e)
, (p4e, Just f42, Just p2e)
, (p3e, Nothing, Nothing)
, (p2e, Just f21, Just p1e) ]
it "works with a composite primary key" $
run $ do
let p = Point x y ""
x = 10
y = 15
Right thePk = keyFromValues [toPersistValue x, toPersistValue y]
pPk <- insert p
[Entity _ ret] <- select $ from $ \p' -> do
where_ (p'^.PointId ==. val pPk)
return p'
liftIO $ do
ret `shouldBe` p
pPk `shouldBe` thePk
testSelectOrderBy :: Run -> Spec
testSelectOrderBy run = do
describe "select/orderBy" $ do
it "works with a single ASC field" $
run $ do
p1e <- insert' p1
p2e <- insert' p2
p3e <- insert' p3
ret <- select $
from $ \p -> do
orderBy [asc $ p ^. PersonName]
return p
liftIO $ ret `shouldBe` [ p1e, p3e, p2e ]
it "works with a sub_select" $
run $ do
[p1k, p2k, p3k, p4k] <- mapM insert [p1, p2, p3, p4]
[b1k, b2k, b3k, b4k] <- mapM (insert . BlogPost "") [p1k, p2k, p3k, p4k]
ret <- select $
from $ \b -> do
orderBy [desc $ sub_select $
from $ \p -> do
where_ (p ^. PersonId ==. b ^. BlogPostAuthorId)
return (p ^. PersonName)
]
return (b ^. BlogPostId)
liftIO $ ret `shouldBe` (Value <$> [b2k, b3k, b4k, b1k])
it "works on a composite primary key" $
run $ do
let ps = [Point 2 1 "", Point 1 2 ""]
mapM_ insert ps
eps <- select $
from $ \p' -> do
orderBy [asc (p'^.PointId)]
return p'
liftIO $ map entityVal eps `shouldBe` reverse ps
testAscRandom :: SqlExpr (Value Double) -> Run -> Spec
testAscRandom rand' run =
describe "random_" $
it "asc random_ works" $
run $ do
_p1e <- insert' p1
_p2e <- insert' p2
_p3e <- insert' p3
_p4e <- insert' p4
rets <-
fmap S.fromList $
replicateM 11 $
select $
from $ \p -> do
orderBy [asc (rand' :: SqlExpr (Value Double))]
return (p ^. PersonId :: SqlExpr (Value PersonId))
-- There are 2^4 = 16 possible orderings. The chance
-- of 11 random samplings returning the same ordering
-- is 1/2^40, so this test should pass almost everytime.
liftIO $ S.size rets `shouldSatisfy` (>2)
testSelectDistinct :: Run -> Spec
testSelectDistinct run = do
describe "SELECT DISTINCT" $ do
let selDistTest
:: ( forall m. RunDbMonad m
=> SqlQuery (SqlExpr (Value String))
-> SqlPersistT (R.ResourceT m) [Value String])
-> IO ()
selDistTest q = run $ do
p1k <- insert p1
let (t1, t2, t3) = ("a", "b", "c")
mapM_ (insert . flip BlogPost p1k) [t1, t3, t2, t2, t1]
ret <- q $
from $ \b -> do
let title = b ^. BlogPostTitle
orderBy [asc title]
return title
liftIO $ ret `shouldBe` [ Value t1, Value t2, Value t3 ]
it "works on a simple example (select . distinct)" $
selDistTest (select . distinct)
it "works on a simple example (distinct (return ()))" $
selDistTest (\act -> select $ distinct (return ()) >> act)
testCoasleceDefault :: Run -> Spec
testCoasleceDefault run = do
describe "coalesce/coalesceDefault" $ do
it "works on a simple example" $
run $ do
mapM_ insert' [p1, p2, p3, p4, p5]
ret1 <- select $
from $ \p -> do
orderBy [asc (p ^. PersonId)]
return (coalesce [p ^. PersonAge, p ^. PersonWeight])
liftIO $ ret1 `shouldBe` [ Value (Just (36 :: Int))
, Value (Just 37)
, Value (Just 17)
, Value (Just 17)
, Value Nothing
]
ret2 <- select $
from $ \p -> do
orderBy [asc (p ^. PersonId)]
return (coalesceDefault [p ^. PersonAge, p ^. PersonWeight] (p ^. PersonFavNum))
liftIO $ ret2 `shouldBe` [ Value (36 :: Int)
, Value 37
, Value 17
, Value 17
, Value 5
]
it "works with sub-queries" $
run $ do
p1id <- insert p1
p2id <- insert p2
p3id <- insert p3
_ <- insert p4
_ <- insert p5
_ <- insert $ BlogPost "a" p1id
_ <- insert $ BlogPost "b" p2id
_ <- insert $ BlogPost "c" p3id
ret <- select $
from $ \b -> do
let sub =
from $ \p -> do
where_ (p ^. PersonId ==. b ^. BlogPostAuthorId)
return $ p ^. PersonAge
return $ coalesceDefault [sub_select sub] (val (42 :: Int))
liftIO $ ret `shouldBe` [ Value (36 :: Int)
, Value 42
, Value 17
]
testDelete :: Run -> Spec
testDelete run = do
describe "delete" $
it "works on a simple example" $
run $ do
p1e <- insert' p1
p2e <- insert' p2
p3e <- insert' p3
let getAll = select $
from $ \p -> do
orderBy [asc (p ^. PersonName)]
return p
ret1 <- getAll
liftIO $ ret1 `shouldBe` [ p1e, p3e, p2e ]
() <- delete $
from $ \p ->
where_ (p ^. PersonName ==. val (personName p1))
ret2 <- getAll
liftIO $ ret2 `shouldBe` [ p3e, p2e ]
n <- deleteCount $
from $ \p ->
return ((p :: SqlExpr (Entity Person)) `seq` ())
ret3 <- getAll
liftIO $ (n, ret3) `shouldBe` (2, [])
testUpdate :: Run -> Spec
testUpdate run = do
describe "update" $ do
it "works with a subexpression having COUNT(*)" $
run $ do
p1k <- insert p1
p2k <- insert p2
p3k <- insert p3
replicateM_ 3 (insert $ BlogPost "" p1k)
replicateM_ 7 (insert $ BlogPost "" p3k)
let blogPostsBy p =
from $ \b -> do
where_ (b ^. BlogPostAuthorId ==. p ^. PersonId)
return countRows
() <- update $ \p -> do
set p [ PersonAge =. just (sub_select (blogPostsBy p)) ]
ret <- select $
from $ \p -> do
orderBy [ asc (p ^. PersonName) ]
return p
liftIO $ ret `shouldBe` [ Entity p1k p1 { personAge = Just 3 }
, Entity p3k p3 { personAge = Just 7 }
, Entity p2k p2 { personAge = Just 0 } ]
it "works with a composite primary key" $
pendingWith "Need refactor to support composite pks on ESet"
{-
run $ do
let p = Point x y ""
x = 10
y = 15
newX = 20
newY = 25
Right newPk = keyFromValues [toPersistValue newX, toPersistValue newY]
insert_ p
() <- update $ \p' -> do
set p' [PointId =. val newPk]
[Entity _ ret] <- select $ from $ return
liftIO $ do
ret `shouldBe` Point newX newY []
-}
it "GROUP BY works with COUNT" $
run $ do
p1k <- insert p1
p2k <- insert p2
p3k <- insert p3
replicateM_ 3 (insert $ BlogPost "" p1k)
replicateM_ 7 (insert $ BlogPost "" p3k)
ret <- select $
from $ \(p `LeftOuterJoin` b) -> do
on (p ^. PersonId ==. b ^. BlogPostAuthorId)
groupBy (p ^. PersonId)
let cnt = count (b ^. BlogPostId)
orderBy [ asc cnt ]
return (p, cnt)
liftIO $ ret `shouldBe` [ (Entity p2k p2, Value (0 :: Int))
, (Entity p1k p1, Value 3)
, (Entity p3k p3, Value 7) ]
it "GROUP BY works with COUNT and InnerJoin" $
run $ do
l1k <- insert l1
l3k <- insert l3
mapM_ (\k -> insert $ Deed k l1k) (map show [1..3 :: Int])
mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int])
(ret :: [(Value (Key Lord), Value Int)]) <- select $ from $
\ ( lord `InnerJoin` deed ) -> do
on $ lord ^. LordId ==. deed ^. DeedOwnerId
groupBy (lord ^. LordId)
return (lord ^. LordId, count $ deed ^. DeedId)
liftIO $ ret `shouldMatchList` [ (Value l3k, Value 7)
, (Value l1k, Value 3) ]
it "GROUP BY works with nested tuples" $ do
run $ do
l1k <- insert l1
l3k <- insert l3
mapM_ (\k -> insert $ Deed k l1k) (map show [1..3 :: Int])
mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int])
(ret :: [(Value (Key Lord), Value Int)]) <- select $ from $
\ ( lord `InnerJoin` deed ) -> do
on $ lord ^. LordId ==. deed ^. DeedOwnerId
groupBy ((lord ^. LordId, lord ^. LordDogs), deed ^. DeedContract)
return (lord ^. LordId, count $ deed ^. DeedId)
liftIO $ length ret `shouldBe` 10
it "GROUP BY works with HAVING" $
run $ do
p1k <- insert p1
_p2k <- insert p2
p3k <- insert p3
replicateM_ 3 (insert $ BlogPost "" p1k)
replicateM_ 7 (insert $ BlogPost "" p3k)
ret <- select $
from $ \(p `LeftOuterJoin` b) -> do
on (p ^. PersonId ==. b ^. BlogPostAuthorId)
let cnt = count (b ^. BlogPostId)
groupBy (p ^. PersonId)
having (cnt >. (val 0))
orderBy [ asc cnt ]
return (p, cnt)
liftIO $ ret `shouldBe` [ (Entity p1k p1, Value (3 :: Int))
, (Entity p3k p3, Value 7) ]
-- we only care that this compiles. check that SqlWriteT doesn't fail on
-- updates.
testSqlWriteT :: MonadIO m => SqlWriteT m ()
testSqlWriteT =
update $ \p -> do
set p [ PersonAge =. just (val 6) ]
-- we only care that this compiles. checks that the SqlWriteT monad can run
-- select queries.
testSqlWriteTRead :: MonadIO m => SqlWriteT m [(Value (Key Lord), Value Int)]
testSqlWriteTRead =
select $
from $ \ ( lord `InnerJoin` deed ) -> do
on $ lord ^. LordId ==. deed ^. DeedOwnerId
groupBy (lord ^. LordId)
return (lord ^. LordId, count $ deed ^. DeedId)
-- we only care that this compiles checks that SqlReadT allows
testSqlReadT :: MonadIO m => SqlReadT m [(Value (Key Lord), Value Int)]
testSqlReadT =
select $
from $ \ ( lord `InnerJoin` deed ) -> do
on $ lord ^. LordId ==. deed ^. DeedOwnerId
groupBy (lord ^. LordId)
return (lord ^. LordId, count $ deed ^. DeedId)
testListOfValues :: Run -> Spec
testListOfValues run = do
describe "lists of values" $ do
it "IN works for valList" $
run $ do
p1k <- insert p1
p2k <- insert p2
_p3k <- insert p3
ret <- select $
from $ \p -> do
where_ (p ^. PersonName `in_` valList (personName <$> [p1, p2]))
return p
liftIO $ ret `shouldBe` [ Entity p1k p1
, Entity p2k p2 ]
it "IN works for valList (null list)" $
run $ do
_p1k <- insert p1
_p2k <- insert p2
_p3k <- insert p3
ret <- select $
from $ \p -> do
where_ (p ^. PersonName `in_` valList [])
return p
liftIO $ ret `shouldBe` []
it "IN works for subList_select" $
run $ do
p1k <- insert p1
_p2k <- insert p2
p3k <- insert p3
_ <- insert (BlogPost "" p1k)
_ <- insert (BlogPost "" p3k)
ret <- select $
from $ \p -> do
let subquery =
from $ \bp -> do
orderBy [ asc (bp ^. BlogPostAuthorId) ]
return (bp ^. BlogPostAuthorId)
where_ (p ^. PersonId `in_` subList_select subquery)
return p
liftIO $ L.sort ret `shouldBe` L.sort [Entity p1k p1, Entity p3k p3]
it "NOT IN works for subList_select" $
run $ do
p1k <- insert p1
p2k <- insert p2
p3k <- insert p3
_ <- insert (BlogPost "" p1k)
_ <- insert (BlogPost "" p3k)
ret <- select $
from $ \p -> do
let subquery =
from $ \bp ->
return (bp ^. BlogPostAuthorId)
where_ (p ^. PersonId `notIn` subList_select subquery)
return p
liftIO $ ret `shouldBe` [ Entity p2k p2 ]
it "EXISTS works for subList_select" $
run $ do
p1k <- insert p1
_p2k <- insert p2
p3k <- insert p3
_ <- insert (BlogPost "" p1k)
_ <- insert (BlogPost "" p3k)
ret <- select $
from $ \p -> do
where_ $ exists $
from $ \bp -> do
where_ (bp ^. BlogPostAuthorId ==. p ^. PersonId)
orderBy [asc (p ^. PersonName)]
return p
liftIO $ ret `shouldBe` [ Entity p1k p1
, Entity p3k p3 ]
it "EXISTS works for subList_select" $
run $ do
p1k <- insert p1
p2k <- insert p2
p3k <- insert p3
_ <- insert (BlogPost "" p1k)
_ <- insert (BlogPost "" p3k)
ret <- select $
from $ \p -> do
where_ $ notExists $
from $ \bp -> do
where_ (bp ^. BlogPostAuthorId ==. p ^. PersonId)
return p
liftIO $ ret `shouldBe` [ Entity p2k p2 ]
testListFields :: Run -> Spec
testListFields run = do
describe "list fields" $ do
-- <https://github.com/prowdsponsor/esqueleto/issues/100>
it "can update list fields" $
run $ do
cclist <- insert $ CcList []
update $ \p -> do
set p [ CcListNames =. val ["fred"]]
where_ (p ^. CcListId ==. val cclist)
testInsertsBySelect :: Run -> Spec
testInsertsBySelect run = do
describe "inserts by select" $ do
it "IN works for insertSelect" $
run $ do
_ <- insert p1
_ <- insert p2
_ <- insert p3
insertSelect $ from $ \p -> do
return $ BlogPost <# val "FakePost" <&> (p ^. PersonId)
ret <- select $ from (\(_::(SqlExpr (Entity BlogPost))) -> return countRows)
liftIO $ ret `shouldBe` [Value (3::Int)]
testInsertsBySelectReturnsCount :: Run -> Spec
testInsertsBySelectReturnsCount run = do
describe "inserts by select, returns count" $ do
it "IN works for insertSelectCount" $
run $ do
_ <- insert p1
_ <- insert p2
_ <- insert p3
cnt <- insertSelectCount $ from $ \p -> do
return $ BlogPost <# val "FakePost" <&> (p ^. PersonId)
ret <- select $ from (\(_::(SqlExpr (Entity BlogPost))) -> return countRows)
liftIO $ ret `shouldBe` [Value (3::Int)]
liftIO $ cnt `shouldBe` 3
testRandomMath :: Run -> Spec
testRandomMath run = describe "random_ math" $
it "rand returns result in random order" $
run $ do
replicateM_ 20 $ do
_ <- insert p1
_ <- insert p2
_ <- insert p3
_ <- insert p4
_ <- insert $ Person "Jane" Nothing Nothing 0
_ <- insert $ Person "Mark" Nothing Nothing 0
_ <- insert $ Person "Sarah" Nothing Nothing 0
insert $ Person "Paul" Nothing Nothing 0
ret1 <- fmap (map unValue) $ select $ from $ \p -> do
orderBy [rand]
return (p ^. PersonId)
ret2 <- fmap (map unValue) $ select $ from $ \p -> do
orderBy [rand]
return (p ^. PersonId)
liftIO $ (ret1 == ret2) `shouldBe` False
testMathFunctions :: Run -> Spec
testMathFunctions run = do
describe "Math-related functions" $ do
it "castNum works for multiplying Int and Double" $
run $ do
mapM_ insert [Numbers 2 3.4, Numbers 7 1.1]
ret <-
select $
from $ \n -> do
let r = castNum (n ^. NumbersInt) *. n ^. NumbersDouble
orderBy [asc r]
return r
liftIO $ length ret `shouldBe` 2
let [Value a, Value b] = ret
liftIO $ max (abs (a - 6.8)) (abs (b - 7.7)) `shouldSatisfy` (< 0.01)
testCase :: Run -> Spec
testCase run = do
describe "case" $ do
it "Works for a simple value based when - False" $
run $ do
ret <- select $
return $
case_
[ when_ (val False) then_ (val (1 :: Int)) ]
(else_ (val 2))
liftIO $ ret `shouldBe` [ Value 2 ]
it "Works for a simple value based when - True" $
run $ do
ret <- select $
return $
case_
[ when_ (val True) then_ (val (1 :: Int)) ]
(else_ (val 2))
liftIO $ ret `shouldBe` [ Value 1 ]
it "works for a semi-complicated query" $
run $ do
_ <- insert p1
_ <- insert p2
_ <- insert p3
_ <- insert p4
_ <- insert p5
ret <- select $
return $
case_
[ when_
(exists $ from $ \p -> do
where_ (p ^. PersonName ==. val "Mike"))
then_
(sub_select $ from $ \v -> do
let sub =
from $ \c -> do
where_ (c ^. PersonName ==. val "Mike")
return (c ^. PersonFavNum)
where_ (v ^. PersonFavNum >. sub_select sub)
return $ count (v ^. PersonName) +. val (1 :: Int)) ]
(else_ $ val (-1))
liftIO $ ret `shouldBe` [ Value (3) ]
testLocking :: WithConn (NoLoggingT IO) [TL.Text] -> Spec
testLocking withConn = do
describe "locking" $ do
-- The locking clause is the last one, so try to use many
-- others to test if it's at the right position. We don't
-- care about the text of the rest, nor with the RDBMS'
-- reaction to the clause.
let sanityCheck kind syntax = do
let complexQuery =
from $ \(p1' `InnerJoin` p2') -> do
on (p1' ^. PersonName ==. p2' ^. PersonName)
where_ (p1' ^. PersonFavNum >. val 2)
orderBy [desc (p2' ^. PersonAge)]
limit 3
offset 9
groupBy (p1' ^. PersonId)
having (countRows <. val (0 :: Int))
return (p1', p2')
queryWithClause1 = do
r <- complexQuery
locking kind
return r
queryWithClause2 = do
locking ForUpdate
r <- complexQuery
locking ForShare
locking kind
return r
queryWithClause3 = do
locking kind
complexQuery
toText conn q =
let (tlb, _) = EI.toRawSql EI.SELECT (conn, EI.initialIdentState) q
in TLB.toLazyText tlb
[complex, with1, with2, with3] <-
runNoLoggingT $ withConn $ \conn -> return $
map (toText conn) [complexQuery, queryWithClause1, queryWithClause2, queryWithClause3]
let expected = complex <> "\n" <> syntax
(with1, with2, with3) `shouldBe` (expected, expected, expected)
it "looks sane for ForUpdate" $ sanityCheck ForUpdate "FOR UPDATE"
it "looks sane for ForUpdateSkipLocked" $ sanityCheck ForUpdateSkipLocked "FOR UPDATE SKIP LOCKED"
it "looks sane for ForShare" $ sanityCheck ForShare "FOR SHARE"
it "looks sane for LockInShareMode" $ sanityCheck LockInShareMode "LOCK IN SHARE MODE"
testCountingRows :: Run -> Spec
testCountingRows run = do
describe "counting rows" $ do
forM_ [ ("count (test A)", count . (^. PersonAge), 4)
, ("count (test B)", count . (^. PersonWeight), 5)
, ("countRows", const countRows, 5)
, ("countDistinct", countDistinct . (^. PersonAge), 2) ] $
\(title, countKind, expected) ->
it (title ++ " works as expected") $
run $ do
mapM_ insert
[ Person "" (Just 1) (Just 1) 1
, Person "" (Just 2) (Just 1) 1
, Person "" (Just 2) (Just 1) 1
, Person "" (Just 2) (Just 2) 1
, Person "" Nothing (Just 3) 1]
[Value n] <- select $ from $ return . countKind
liftIO $ (n :: Int) `shouldBe` expected
testRenderSql :: Run -> Spec
testRenderSql run = do
describe "testRenderSql" $ do
it "works" $ do
(queryText, queryVals) <- run $ renderQuerySelect $
from $ \p -> do
where_ $ p ^. PersonName ==. val "Johhny Depp"
pure (p ^. PersonName, p ^. PersonAge)
-- the different backends use different quote marks, so I filter them out
-- here instead of making a duplicate test
Text.filter (\c -> c `notElem` ['`', '"']) queryText
`shouldBe`
Text.unlines
[ "SELECT Person.name, Person.age"
, "FROM Person"
, "WHERE Person.name = ?"
]
queryVals
`shouldBe`
[toPersistValue ("Johhny Depp" :: TL.Text)]
describe "renderExpr" $ do
it "renders a value" $ do
(c, expr) <- run $ do
conn <- ask
let Right c = P.mkEscapeChar conn
pure $ (,) c $ EI.renderExpr conn $
EI.EEntity (EI.I "user") ^. PersonId
==. EI.EEntity (EI.I "blog_post") ^. BlogPostAuthorId
expr
`shouldBe`
Text.intercalate (Text.singleton c) ["", "user", ".", "id", ""]
<>
" = "
<>
Text.intercalate (Text.singleton c) ["", "blog_post", ".", "authorId", ""]
it "renders ? for a val" $ do
expr <- run $ ask >>= \c -> pure $ EI.renderExpr c (val (PersonKey 0) ==. val (PersonKey 1))
expr `shouldBe` "? = ?"
describe "EEntity Ident behavior" $ do
let
render :: SqlExpr (Entity val) -> Text.Text
render (EI.EEntity (EI.I ident)) = ident
it "renders sensibly" $ do
results <- run $ do
_ <- insert $ Foo 2
_ <- insert $ Foo 3
_ <- insert $ Person "hello" Nothing Nothing 3
select $
from $ \(a `LeftOuterJoin` b) -> do
on $ a ^. FooName ==. b ^. PersonFavNum
pure (val (render a), val (render b))
head results
`shouldBe`
(Value "Foo", Value "Person")
describe "ExprParser" $ do
let parse parser = AP.parseOnly (parser '#')
describe "parseEscapedChars" $ do
let subject = parse P.parseEscapedChars
it "parses words" $ do
subject "hello world"
`shouldBe`
Right "hello world"
it "only returns a single escape-char if present" $ do
subject "i_am##identifier##"
`shouldBe`
Right "i_am#identifier#"
describe "parseEscapedIdentifier" $ do
let subject = parse P.parseEscapedIdentifier
it "parses the quotes out" $ do
subject "#it's a me, mario#"
`shouldBe`
Right "it's a me, mario"
it "requires a beginning and end quote" $ do
subject "#alas, i have no end"
`shouldSatisfy`
isLeft
describe "parseTableAccess" $ do
let subject = parse P.parseTableAccess
it "parses a table access" $ do
subject "#foo#.#bar#"
`shouldBe`
Right P.TableAccess
{ P.tableAccessTable = "foo"
, P.tableAccessColumn = "bar"
}
describe "onExpr" $ do
let subject = parse P.onExpr
it "works" $ do
subject "#foo#.#bar# = #bar#.#baz#"
`shouldBe` do
Right $ S.fromList
[ P.TableAccess
{ P.tableAccessTable = "foo"
, P.tableAccessColumn = "bar"
}
, P.TableAccess
{ P.tableAccessTable = "bar"
, P.tableAccessColumn = "baz"
}
]
it "also works with other nonsense" $ do
subject "#foo#.#bar# = 3"
`shouldBe` do
Right $ S.fromList
[ P.TableAccess
{ P.tableAccessTable = "foo"
, P.tableAccessColumn = "bar"
}
]
it "handles a conjunction" $ do
subject "#foo#.#bar# = #bar#.#baz# AND #bar#.#baz# > 10"
`shouldBe` do
Right $ S.fromList
[ P.TableAccess
{ P.tableAccessTable = "foo"
, P.tableAccessColumn = "bar"
}
, P.TableAccess
{ P.tableAccessTable = "bar"
, P.tableAccessColumn = "baz"
}
]
it "handles ? okay" $ do
subject "#foo#.#bar# = ?"
`shouldBe` do
Right $ S.fromList
[ P.TableAccess
{ P.tableAccessTable = "foo"
, P.tableAccessColumn = "bar"
}
]
it "handles degenerate cases" $ do
subject "false" `shouldBe` pure mempty
subject "true" `shouldBe` pure mempty
subject "1 = 1" `shouldBe` pure mempty
it "works even if an identifier isn't first" $ do
subject "true and #foo#.#bar# = 2"
`shouldBe` do
Right $ S.fromList
[ P.TableAccess
{ P.tableAccessTable = "foo"
, P.tableAccessColumn = "bar"
}
]
testOnClauseOrder :: Run -> Spec
testOnClauseOrder run = describe "On Clause Ordering" $ do
let
setup :: MonadIO m => SqlPersistT m ()
setup = do
ja1 <- insert (JoinOne "j1 hello")
ja2 <- insert (JoinOne "j1 world")
jb1 <- insert (JoinTwo ja1 "j2 hello")
jb2 <- insert (JoinTwo ja1 "j2 world")
jb3 <- insert (JoinTwo ja2 "j2 foo")
_ <- insert (JoinTwo ja2 "j2 bar")
jc1 <- insert (JoinThree jb1 "j3 hello")
jc2 <- insert (JoinThree jb1 "j3 world")
_ <- insert (JoinThree jb2 "j3 foo")
_ <- insert (JoinThree jb3 "j3 bar")
_ <- insert (JoinThree jb3 "j3 baz")
_ <- insert (JoinFour "j4 foo" jc1)
_ <- insert (JoinFour "j4 bar" jc2)
jd1 <- insert (JoinOther "foo")
jd2 <- insert (JoinOther "bar")
_ <- insert (JoinMany "jm foo hello" jd1 ja1)
_ <- insert (JoinMany "jm foo world" jd1 ja2)
_ <- insert (JoinMany "jm bar hello" jd2 ja1)
_ <- insert (JoinMany "jm bar world" jd2 ja2)
pure ()
describe "identical results for" $ do
it "three tables" $ do
abcs <- run $ do
setup
select $
from $ \(a `InnerJoin` b `InnerJoin` c) -> do
on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)
on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)
pure (a, b, c)
acbs <- run $ do
setup
select $
from $ \(a `InnerJoin` b `InnerJoin` c) -> do
on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)
on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)
pure (a, b, c)
listsEqualOn abcs acbs $ \(Entity _ j1, Entity _ j2, Entity _ j3) ->
(joinOneName j1, joinTwoName j2, joinThreeName j3)
it "four tables" $ do
xs0 <- run $ do
setup
select $
from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do
on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)
on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)
on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree)
pure (a, b, c, d)
xs1 <- run $ do
setup
select $
from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do
on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)
on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree)
on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)
pure (a, b, c, d)
xs2 <- run $ do
setup
select $
from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do
on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)
on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree)
on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)
pure (a, b, c, d)
xs3 <- run $ do
setup
select $
from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do
on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree)
on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)
on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)
pure (a, b, c, d)
xs4 <- run $ do
setup
select $
from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do
on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree)
on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)
on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)
pure (a, b, c, d)
let getNames (j1, j2, j3, j4) =
( joinOneName (entityVal j1)
, joinTwoName (entityVal j2)
, joinThreeName (entityVal j3)
, joinFourName (entityVal j4)
)
listsEqualOn xs0 xs1 getNames
listsEqualOn xs0 xs2 getNames
listsEqualOn xs0 xs3 getNames
listsEqualOn xs0 xs4 getNames
it "associativity of innerjoin" $ do
xs0 <- run $ do
setup
select $
from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do
on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)
on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)
on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree)
pure (a, b, c, d)
xs1 <- run $ do
setup
select $
from $ \(a `InnerJoin` b `InnerJoin` (c `InnerJoin` d)) -> do
on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)
on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)
on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree)
pure (a, b, c, d)
xs2 <- run $ do
setup
select $
from $ \(a `InnerJoin` (b `InnerJoin` c) `InnerJoin` d) -> do
on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)
on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)
on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree)
pure (a, b, c, d)
xs3 <- run $ do
setup
select $
from $ \(a `InnerJoin` (b `InnerJoin` c `InnerJoin` d)) -> do
on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)
on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)
on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree)
pure (a, b, c, d)
let getNames (j1, j2, j3, j4) =
( joinOneName (entityVal j1)
, joinTwoName (entityVal j2)
, joinThreeName (entityVal j3)
, joinFourName (entityVal j4)
)
listsEqualOn xs0 xs1 getNames
listsEqualOn xs0 xs2 getNames
listsEqualOn xs0 xs3 getNames
it "inner join on two entities" $ do
(xs0, xs1) <- run $ do
pid <- insert $ Person "hello" Nothing Nothing 3
_ <- insert $ BlogPost "good poast" pid
_ <- insert $ Profile "cool" pid
xs0 <- selectRethrowingQuery $
from $ \(p `InnerJoin` b `InnerJoin` pr) -> do
on $ p ^. PersonId ==. b ^. BlogPostAuthorId
on $ p ^. PersonId ==. pr ^. ProfilePerson
pure (p, b, pr)
xs1 <- selectRethrowingQuery $
from $ \(p `InnerJoin` b `InnerJoin` pr) -> do
on $ p ^. PersonId ==. pr ^. ProfilePerson
on $ p ^. PersonId ==. b ^. BlogPostAuthorId
pure (p, b, pr)
pure (xs0, xs1)
listsEqualOn xs0 xs1 $ \(Entity _ p, Entity _ b, Entity _ pr) ->
(personName p, blogPostTitle b, profileName pr)
it "inner join on three entities" $ do
res <- run $ do
pid <- insert $ Person "hello" Nothing Nothing 3
_ <- insert $ BlogPost "good poast" pid
_ <- insert $ BlogPost "good poast #2" pid
_ <- insert $ Profile "cool" pid
_ <- insert $ Reply pid "u wot m8"
_ <- insert $ Reply pid "how dare you"
bprr <- selectRethrowingQuery $
from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do
on $ p ^. PersonId ==. b ^. BlogPostAuthorId
on $ p ^. PersonId ==. pr ^. ProfilePerson
on $ p ^. PersonId ==. r ^. ReplyGuy
pure (p, b, pr, r)
brpr <- selectRethrowingQuery $
from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do
on $ p ^. PersonId ==. b ^. BlogPostAuthorId
on $ p ^. PersonId ==. r ^. ReplyGuy
on $ p ^. PersonId ==. pr ^. ProfilePerson
pure (p, b, pr, r)
prbr <- selectRethrowingQuery $
from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do
on $ p ^. PersonId ==. pr ^. ProfilePerson
on $ p ^. PersonId ==. b ^. BlogPostAuthorId
on $ p ^. PersonId ==. r ^. ReplyGuy
pure (p, b, pr, r)
prrb <- selectRethrowingQuery $
from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do
on $ p ^. PersonId ==. pr ^. ProfilePerson
on $ p ^. PersonId ==. r ^. ReplyGuy
on $ p ^. PersonId ==. b ^. BlogPostAuthorId
pure (p, b, pr, r)
rprb <- selectRethrowingQuery $
from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do
on $ p ^. PersonId ==. r ^. ReplyGuy
on $ p ^. PersonId ==. pr ^. ProfilePerson
on $ p ^. PersonId ==. b ^. BlogPostAuthorId
pure (p, b, pr, r)
rbpr <- selectRethrowingQuery $
from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do
on $ p ^. PersonId ==. r ^. ReplyGuy
on $ p ^. PersonId ==. b ^. BlogPostAuthorId
on $ p ^. PersonId ==. pr ^. ProfilePerson
pure (p, b, pr, r)
pure [bprr, brpr, prbr, prrb, rprb, rbpr]
forM_ (zip res (drop 1 (cycle res))) $ \(a, b) -> a `shouldBe` b
it "many-to-many" $ do
ac <- run $ do
setup
select $
from $ \(a `InnerJoin` b `InnerJoin` c) -> do
on (a ^. JoinOneId ==. b ^. JoinManyJoinOne)
on (c ^. JoinOtherId ==. b ^. JoinManyJoinOther)
pure (a, c)
ca <- run $ do
setup
select $
from $ \(a `InnerJoin` b `InnerJoin` c) -> do
on (c ^. JoinOtherId ==. b ^. JoinManyJoinOther)
on (a ^. JoinOneId ==. b ^. JoinManyJoinOne)
pure (a, c)
listsEqualOn ac ca $ \(Entity _ a, Entity _ b) ->
(joinOneName a, joinOtherName b)
it "left joins on order" $ do
ca <- run $ do
setup
select $
from $ \(a `LeftOuterJoin` b `InnerJoin` c) -> do
on (c ?. JoinOtherId ==. b ?. JoinManyJoinOther)
on (just (a ^. JoinOneId) ==. b ?. JoinManyJoinOne)
orderBy [asc $ a ^. JoinOneId, asc $ c ?. JoinOtherId]
pure (a, c)
ac <- run $ do
setup
select $
from $ \(a `LeftOuterJoin` b `InnerJoin` c) -> do
on (just (a ^. JoinOneId) ==. b ?. JoinManyJoinOne)
on (c ?. JoinOtherId ==. b ?. JoinManyJoinOther)
orderBy [asc $ a ^. JoinOneId, asc $ c ?. JoinOtherId]
pure (a, c)
listsEqualOn ac ca $ \(Entity _ a, b) ->
(joinOneName a, maybe "NULL" (joinOtherName . entityVal) b)
it "doesn't require an on for a crossjoin" $ do
void $ run $
select $
from $ \(a `CrossJoin` b) -> do
pure (a :: SqlExpr (Entity JoinOne), b :: SqlExpr (Entity JoinTwo))
it "errors with an on for a crossjoin" $ do
(void $ run $
select $
from $ \(a `CrossJoin` b) -> do
on $ a ^. JoinOneId ==. b ^. JoinTwoJoinOne
pure (a, b))
`shouldThrow` \(OnClauseWithoutMatchingJoinException _) ->
True
it "left joins associativity" $ do
ca <- run $ do
setup
select $
from $ \(a `LeftOuterJoin` (b `InnerJoin` c)) -> do
on (c ?. JoinOtherId ==. b ?. JoinManyJoinOther)
on (just (a ^. JoinOneId) ==. b ?. JoinManyJoinOne)
orderBy [asc $ a ^. JoinOneId, asc $ c ?. JoinOtherId]
pure (a, c)
ca' <- run $ do
setup
select $
from $ \(a `LeftOuterJoin` b `InnerJoin` c) -> do
on (c ?. JoinOtherId ==. b ?. JoinManyJoinOther)
on (just (a ^. JoinOneId) ==. b ?. JoinManyJoinOne)
orderBy [asc $ a ^. JoinOneId, asc $ c ?. JoinOtherId]
pure (a, c)
listsEqualOn ca ca' $ \(Entity _ a, b) ->
(joinOneName a, maybe "NULL" (joinOtherName . entityVal) b)
it "composes queries still" $ do
let
query1 =
from $ \(foo `InnerJoin` bar) -> do
on (foo ^. FooId ==. bar ^. BarQuux)
pure (foo, bar)
query2 =
from $ \(p `LeftOuterJoin` bp) -> do
on (p ^. PersonId ==. bp ^. BlogPostAuthorId)
pure (p, bp)
(a, b) <- run $ do
fid <- insert $ Foo 5
_ <- insert $ Bar fid
pid <- insert $ Person "hey" Nothing Nothing 30
_ <- insert $ BlogPost "WHY" pid
a <- select ((,) <$> query1 <*> query2)
b <- select (flip (,) <$> query1 <*> query2)
pure (a, b)
listsEqualOn a (map (\(x, y) -> (y, x)) b) id
it "works with joins in subselect" $ do
run $ void $
select $
from $ \(p `InnerJoin` r) -> do
on $ p ^. PersonId ==. r ^. ReplyGuy
pure . (,) (p ^. PersonName) $
subSelect $
from $ \(c `InnerJoin` bp) -> do
on $ bp ^. BlogPostId ==. c ^. CommentBlog
pure (c ^. CommentBody)
describe "works with nested joins" $ do
it "unnested" $ do
run $ void $
selectRethrowingQuery $
from $ \(f `InnerJoin` b `LeftOuterJoin` baz `InnerJoin` shoop) -> do
on $ f ^. FooId ==. b ^. BarQuux
on $ f ^. FooId ==. baz ^. BazBlargh
on $ baz ^. BazId ==. shoop ^. ShoopBaz
pure ( f ^. FooName)
it "leftmost nesting" $ do
run $ void $
selectRethrowingQuery $
from $ \((f `InnerJoin` b) `LeftOuterJoin` baz `InnerJoin` shoop) -> do
on $ f ^. FooId ==. b ^. BarQuux
on $ f ^. FooId ==. baz ^. BazBlargh
on $ baz ^. BazId ==. shoop ^. ShoopBaz
pure ( f ^. FooName)
describe "middle nesting" $ do
it "direct association" $ do
run $ void $
selectRethrowingQuery $
from $ \(p `InnerJoin` (bp `LeftOuterJoin` c) `LeftOuterJoin` cr) -> do
on $ p ^. PersonId ==. bp ^. BlogPostAuthorId
on $ just (bp ^. BlogPostId) ==. c ?. CommentBlog
on $ c ?. CommentId ==. cr ?. CommentReplyComment
pure (p,bp,c,cr)
it "indirect association" $ do
run $ void $
selectRethrowingQuery $
from $ \(f `InnerJoin` b `LeftOuterJoin` (baz `InnerJoin` shoop) `InnerJoin` asdf) -> do
on $ f ^. FooId ==. b ^. BarQuux
on $ f ^. FooId ==. baz ^. BazBlargh
on $ baz ^. BazId ==. shoop ^. ShoopBaz
on $ asdf ^. AsdfShoop ==. shoop ^. ShoopId
pure (f ^. FooName)
it "indirect association across" $ do
run $ void $
selectRethrowingQuery $
from $ \(f `InnerJoin` b `LeftOuterJoin` (baz `InnerJoin` shoop) `InnerJoin` asdf `InnerJoin` another `InnerJoin` yetAnother) -> do
on $ f ^. FooId ==. b ^. BarQuux
on $ f ^. FooId ==. baz ^. BazBlargh
on $ baz ^. BazId ==. shoop ^. ShoopBaz
on $ asdf ^. AsdfShoop ==. shoop ^. ShoopId
on $ another ^. AnotherWhy ==. baz ^. BazId
on $ yetAnother ^. YetAnotherArgh ==. shoop ^. ShoopId
pure (f ^. FooName)
describe "rightmost nesting" $ do
it "direct associations" $ do
run $ void $
selectRethrowingQuery $
from $ \(p `InnerJoin` bp `LeftOuterJoin` (c `LeftOuterJoin` cr)) -> do
on $ p ^. PersonId ==. bp ^. BlogPostAuthorId
on $ just (bp ^. BlogPostId) ==. c ?. CommentBlog
on $ c ?. CommentId ==. cr ?. CommentReplyComment
pure (p,bp,c,cr)
it "indirect association" $ do
run $ void $
selectRethrowingQuery $
from $ \(f `InnerJoin` b `LeftOuterJoin` (baz `InnerJoin` shoop)) -> do
on $ f ^. FooId ==. b ^. BarQuux
on $ f ^. FooId ==. baz ^. BazBlargh
on $ baz ^. BazId ==. shoop ^. ShoopBaz
pure (f ^. FooName)
testExperimentalFrom :: Run -> Spec
testExperimentalFrom run = do
describe "Experimental From" $ do
it "supports basic table queries" $ do
run $ do
p1e <- insert' p1
_ <- insert' p2
p3e <- insert' p3
peopleWithAges <- select $ do
people <- Experimental.from $ Table @Person
where_ $ not_ $ isNothing $ people ^. PersonAge
return people
liftIO $ peopleWithAges `shouldMatchList` [p1e, p3e]
it "supports inner joins" $ do
run $ do
l1e <- insert' l1
_ <- insert l2
d1e <- insert' $ Deed "1" (entityKey l1e)
d2e <- insert' $ Deed "2" (entityKey l1e)
lordDeeds <- select $ do
(lords :& deeds) <-
Experimental.from $ Table @Lord
`InnerJoin` Table @Deed
`Experimental.on` (\(l :& d) -> l ^. LordId ==. d ^. DeedOwnerId)
pure (lords, deeds)
liftIO $ lordDeeds `shouldMatchList` [ (l1e, d1e)
, (l1e, d2e)
]
it "supports outer joins" $ do
run $ do
l1e <- insert' l1
l2e <- insert' l2
d1e <- insert' $ Deed "1" (entityKey l1e)
d2e <- insert' $ Deed "2" (entityKey l1e)
lordDeeds <- select $ do
(lords :& deeds) <-
Experimental.from $ Table @Lord
`LeftOuterJoin` Table @Deed
`Experimental.on` (\(l :& d) -> just (l ^. LordId) ==. d ?. DeedOwnerId)
pure (lords, deeds)
liftIO $ lordDeeds `shouldMatchList` [ (l1e, Just d1e)
, (l1e, Just d2e)
, (l2e, Nothing)
]
it "supports delete" $ do
run $ do
insert_ l1
insert_ l2
insert_ l3
delete $ void $ Experimental.from $ Table @Lord
lords <- select $ Experimental.from $ Table @Lord
liftIO $ lords `shouldMatchList` []
it "supports implicit cross joins" $ do
run $ do
l1e <- insert' l1
l2e <- insert' l2
ret <- select $ do
lords1 <- Experimental.from $ Table @Lord
lords2 <- Experimental.from $ Table @Lord
pure (lords1, lords2)
ret2 <- select $ do
(lords1 :& lords2) <- Experimental.from $ Table @Lord `CrossJoin` Table @Lord
pure (lords1,lords2)
liftIO $ ret `shouldMatchList` ret2
liftIO $ ret `shouldMatchList` [ (l1e, l1e)
, (l1e, l2e)
, (l2e, l1e)
, (l2e, l2e)
]
it "compiles" $ do
run $ void $ do
let q = do
(persons :& profiles :& posts) <-
Experimental.from $ Table @Person
`InnerJoin` Table @Profile
`Experimental.on` (\(people :& profiles) ->
people ^. PersonId ==. profiles ^. ProfilePerson)
`LeftOuterJoin` Table @BlogPost
`Experimental.on` (\(people :& _ :& posts) ->
just (people ^. PersonId) ==. posts ?. BlogPostAuthorId)
pure (persons, posts, profiles)
--error . show =<< renderQuerySelect q
pure ()
listsEqualOn :: (Show a1, Eq a1) => [a2] -> [a2] -> (a2 -> a1) -> Expectation
listsEqualOn a b f = map f a `shouldBe` map f b
tests :: Run -> Spec
tests run = do
describe "Tests that are common to all backends" $ do
testSelect run
testSubSelect run
testSelectSource run
testSelectFrom run
testSelectJoin run
testSelectSubQuery run
testSelectWhere run
testSelectOrderBy run
testSelectDistinct run
testCoasleceDefault run
testDelete run
testUpdate run
testListOfValues run
testListFields run
testInsertsBySelect run
testMathFunctions run
testCase run
testCountingRows run
testRenderSql run
testOnClauseOrder run
testExperimentalFrom run
insert' :: ( Functor m
, BaseBackend backend ~ PersistEntityBackend val
, PersistStore backend
, MonadIO m
, PersistEntity val )
=> val -> ReaderT backend m (Entity val)
insert' v = flip Entity v <$> insert v
type RunDbMonad m = ( MonadUnliftIO m
, MonadIO m
, MonadLogger m
, MonadCatch m )
#if __GLASGOW_HASKELL__ >= 806
type Run = forall a. (forall m. (RunDbMonad m, MonadFail m) => SqlPersistT (R.ResourceT m) a) -> IO a
#else
type Run = forall a. (forall m. (RunDbMonad m) => SqlPersistT (R.ResourceT m) a) -> IO a
#endif
type WithConn m a = RunDbMonad m => (SqlBackend -> R.ResourceT m a) -> m a
-- With SQLite and in-memory databases, a separate connection implies a
-- separate database. With 'actual databases', the data is persistent and
-- thus must be cleaned after each test.
-- TODO: there is certainly a better way...
cleanDB
:: (forall m. RunDbMonad m
=> SqlPersistT (R.ResourceT m) ())
cleanDB = do
delete $ from $ \(_ :: SqlExpr (Entity Bar)) -> return ()
delete $ from $ \(_ :: SqlExpr (Entity Foo)) -> return ()
delete $ from $ \(_ :: SqlExpr (Entity Reply)) -> return ()
delete $ from $ \(_ :: SqlExpr (Entity Comment)) -> return ()
delete $ from $ \(_ :: SqlExpr (Entity Profile)) -> return ()
delete $ from $ \(_ :: SqlExpr (Entity BlogPost)) -> return ()
delete $ from $ \(_ :: SqlExpr (Entity Follow)) -> return ()
delete $ from $ \(_ :: SqlExpr (Entity Person)) -> return ()
delete $ from $ \(_ :: SqlExpr (Entity Deed)) -> return ()
delete $ from $ \(_ :: SqlExpr (Entity Lord)) -> return ()
delete $ from $ \(_ :: SqlExpr (Entity CcList)) -> return ()
delete $ from $ \(_ :: SqlExpr (Entity ArticleTag)) -> return ()
delete $ from $ \(_ :: SqlExpr (Entity ArticleMetadata)) -> return ()
delete $ from $ \(_ :: SqlExpr (Entity Article)) -> return ()
delete $ from $ \(_ :: SqlExpr (Entity Article2)) -> return ()
delete $ from $ \(_ :: SqlExpr (Entity Tag)) -> return ()
delete $ from $ \(_ :: SqlExpr (Entity Frontcover)) -> return ()
delete $ from $ \(_ :: SqlExpr (Entity Circle)) -> return ()
delete $ from $ \(_ :: SqlExpr (Entity Point)) -> return ()
delete $ from $ \(_ :: SqlExpr (Entity Numbers)) -> return ()
delete $ from $ \(_ :: SqlExpr (Entity JoinMany)) -> return ()
delete $ from $ \(_ :: SqlExpr (Entity JoinFour)) -> return ()
delete $ from $ \(_ :: SqlExpr (Entity JoinThree)) -> return ()
delete $ from $ \(_ :: SqlExpr (Entity JoinTwo)) -> return ()
delete $ from $ \(_ :: SqlExpr (Entity JoinOne)) -> return ()
delete $ from $ \(_ :: SqlExpr (Entity JoinOther)) -> return ()
cleanUniques
:: (forall m. RunDbMonad m
=> SqlPersistT (R.ResourceT m) ())
cleanUniques =
delete $ from $ \(_ :: SqlExpr (Entity OneUnique)) -> return ()
selectRethrowingQuery
:: (MonadIO m, EI.SqlSelect a r, MonadUnliftIO m)
=> SqlQuery a
-> SqlPersistT m [r]
selectRethrowingQuery query =
select query
`catch` \(SomeException e) -> do
(text, _) <- renderQuerySelect query
liftIO . throwIO . userError $ Text.unpack text <> "\n\n" <> show e
Reference in New Issue View Git Blame Copy Permalink