esqueleto 3.5.0.0 → 3.5.1.0
raw patch · 15 files changed
+4365/−4391 lines, 15 filesdep +QuickCheckdep +hspec-coredep −postgresql-libpqdep −vectordep ~attoparsecdep ~conduitdep ~persistentPVP ok
version bump matches the API change (PVP)
Dependencies added: QuickCheck, hspec-core
Dependencies removed: postgresql-libpq, vector
Dependency ranges changed: attoparsec, conduit, persistent, resourcet, tagged, text, time, transformers, unordered-containers
API changes (from Hackage documentation)
+ Database.Esqueleto: selectOne :: (SqlSelect a r, MonadIO m) => SqlQuery a -> SqlReadT m (Maybe r)
+ Database.Esqueleto.Experimental: selectOne :: (SqlSelect a r, MonadIO m) => SqlQuery a -> SqlReadT m (Maybe r)
+ Database.Esqueleto.Internal.Internal: selectOne :: (SqlSelect a r, MonadIO m) => SqlQuery a -> SqlReadT m (Maybe r)
+ Database.Esqueleto.Legacy: selectOne :: (SqlSelect a r, MonadIO m) => SqlQuery a -> SqlReadT m (Maybe r)
Files
- changelog.md +6/−0
- esqueleto.cabal +23/−79
- src/Database/Esqueleto.hs +1/−0
- src/Database/Esqueleto/Experimental.hs +1/−0
- src/Database/Esqueleto/Internal/Internal.hs +29/−0
- src/Database/Esqueleto/Legacy.hs +1/−0
- test/Common/Test.hs +2412/−2584
- test/Common/Test/Import.hs +87/−0
- test/Common/Test/Models.hs +189/−0
- test/Common/Test/Select.hs +22/−0
- test/MySQL/Test.hs +51/−99
- test/PostgreSQL/MigrateJSON.hs +5/−8
- test/PostgreSQL/Test.hs +1399/−1467
- test/SQLite/Test.hs +117/−154
- test/Spec.hs +22/−0
changelog.md view
@@ -1,3 +1,9 @@+3.5.1.0+=======+- @ibarrae+ - [#265](https://github.com/bitemyapp/esqueleto/pull/265)+ - Added `selectOne`+ 3.5.0.0 ======= - @belevy
esqueleto.cabal view
@@ -1,7 +1,7 @@ cabal-version: 1.12 name: esqueleto-version: 3.5.0.0+version: 3.5.1.0 synopsis: Type-safe EDSL for SQL queries on persistent backends. description: @esqueleto@ is a bare bones, type-safe EDSL for SQL queries that works with unmodified @persistent@ SQL backends. Its language closely resembles SQL, so you don't have to learn new concepts, just new syntax, and it's fairly easy to predict the generated SQL and optimize it for your backend. Most kinds of errors committed when writing SQL are caught as compile-time errors---although it is possible to write type-checked @esqueleto@ queries that fail at runtime. .@@ -77,50 +77,22 @@ -Widentities -Wcpp-undef -Wcpp-undef- -Wmonomorphism-restriction default-language: Haskell2010 -test-suite mysql- type: exitcode-stdio-1.0- main-is: MySQL/Test.hs- other-modules:- Common.Test- Paths_esqueleto- hs-source-dirs:- test- ghc-options: -Wall- build-depends:- base >=4.8 && <5.0- , attoparsec- , blaze-html- , bytestring- , conduit >=1.3- , containers- , esqueleto- , exceptions- , hspec- , monad-logger- , mtl- , mysql- , mysql-simple- , persistent- , persistent-mysql- , resourcet >=1.2- , tagged >=0.2- , text >=0.11 && <1.3- , time- , transformers >=0.2- , unliftio- , unordered-containers >=0.2- default-language: Haskell2010--test-suite postgresql+test-suite specs type: exitcode-stdio-1.0- main-is: PostgreSQL/Test.hs+ main-is: Spec.hs other-modules: Common.Test+ Common.Test.Models+ Common.Test.Import+ Common.Test.Select PostgreSQL.MigrateJSON- Paths_esqueleto+ SQLite.Test+ PostgreSQL.Test+ MySQL.Test+ default-extensions:+ RankNTypes hs-source-dirs: test ghc-options: -Wall -threaded@@ -130,55 +102,27 @@ , attoparsec , blaze-html , bytestring- , conduit >=1.3+ , conduit , containers , esqueleto , exceptions , hspec+ , hspec-core , monad-logger , mtl+ , mysql+ , mysql-simple , persistent+ , persistent-mysql , persistent-postgresql- , postgresql-libpq- , postgresql-simple- , resourcet >=1.2- , tagged >=0.2- , text >=0.11 && <1.3- , time- , transformers >=0.2- , unliftio- , unordered-containers >=0.2- , vector- default-language: Haskell2010--test-suite sqlite- type: exitcode-stdio-1.0- main-is: SQLite/Test.hs- other-modules:- Common.Test- Paths_esqueleto- hs-source-dirs:- test- ghc-options: -Wall -threaded- build-depends:- base >=4.8 && <5.0- , attoparsec- , blaze-html- , bytestring- , conduit >=1.3- , containers- , esqueleto- , exceptions- , hspec- , monad-logger- , mtl- , persistent , persistent-sqlite- , resourcet >=1.2- , tagged >=0.2- , text >=0.11 && <1.3+ , postgresql-simple+ , QuickCheck+ , resourcet+ , tagged+ , text , time- , transformers >=0.2+ , transformers , unliftio- , unordered-containers >=0.2+ , unordered-containers default-language: Haskell2010
src/Database/Esqueleto.hs view
@@ -97,6 +97,7 @@ , SqlExpr , SqlEntity , select+ , selectOne , selectSource , delete , deleteCount
src/Database/Esqueleto/Experimental.hs view
@@ -190,6 +190,7 @@ , SqlExpr , SqlEntity , select+ , selectOne , selectSource , delete , deleteCount
src/Database/Esqueleto/Internal/Internal.hs view
@@ -2539,6 +2539,35 @@ conn <- R.ask liftIO $ with res $ flip R.runReaderT conn . runSource +-- | Execute an @esqueleto@ @SELECT@ query inside @persistent@'s+-- 'SqlPersistT' monad and return the first entry wrapped in a @Maybe@.+-- @since 3.5.1.0+--+-- === __Example usage__+--+-- @+-- firstPerson :: MonadIO m => SqlPersistT m (Maybe (Entity Person))+-- firstPerson =+-- 'selectOne' $ do+-- person <- 'from' $ 'table' @Person+-- return person+-- @+--+-- The above query is equivalent to a 'select' combined with 'limit' but you+-- would still have to transform the results from a list:+--+-- @+-- firstPerson :: MonadIO m => SqlPersistT m [Entity Person]+-- firstPerson =+-- 'select' $ do+-- person <- 'from' $ 'table' @Person+-- 'limit' 1+-- return person+-- @++selectOne :: (SqlSelect a r, MonadIO m) => SqlQuery a -> SqlReadT m (Maybe r)+selectOne query = fmap Maybe.listToMaybe $ select $ limit 1 >> query+ -- | (Internal) Run a 'C.Source' of rows. runSource :: Monad m
src/Database/Esqueleto/Legacy.hs view
@@ -98,6 +98,7 @@ , SqlExpr , SqlEntity , select+ , selectOne , selectSource , delete , deleteCount
test/Common/Test.hs view
@@ -1,2585 +1,2413 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PartialTypeSignatures #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE UndecidableInstances #-}--{-# OPTIONS_GHC -fno-warn-unused-binds #-}-{-# OPTIONS_GHC -fno-warn-deprecations #-}-module Common.Test- ( tests- , testLocking- , testAscRandom- , testRandomMath- , migrateAll- , migrateUnique- , cleanDB- , cleanUniques- , RunDbMonad- , Run- , updateRethrowingQuery- , selectRethrowingQuery- , 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(..)- , DateTruncTest(..)- , DateTruncTestId- , Key(..)- ) where--import Control.Monad (forM_, replicateM, replicateM_, void)-import Control.Monad.Catch (MonadCatch)-import Control.Monad.Reader (ask)-import Data.Either-import Data.Time-#if __GLASGOW_HASKELL__ >= 806-import Control.Monad.Fail (MonadFail)-#endif-import Control.Monad.IO.Class (MonadIO(liftIO))-import Control.Monad.Logger (MonadLoggerIO(..), MonadLogger(..), NoLoggingT, runNoLoggingT)-import Control.Monad.Trans.Reader (ReaderT)-import qualified Data.Attoparsec.Text as AP-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 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.Internal.Lazy as TL-import qualified Data.Text.Lazy.Builder as TLB-import qualified Database.Esqueleto.Internal.ExprParser as P-import qualified Database.Esqueleto.Internal.Internal as EI-import qualified UnliftIO.Resource as R---- 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-- DateTruncTest- created UTCTime- deriving Eq Show-|]---- Unique Test schema-share [mkPersist sqlSettings, mkMigrate "migrateUnique"] [persistUpperCase|- OneUnique- name String- value Int- UniqueValue value- deriving Eq Show-|]---instance ToBaseId ArticleMetadata where- type BaseEnt ArticleMetadata = Article- toBaseIdWitness articleId = ArticleMetadataKey articleId---- | 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" $ run $ 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 <- select query-- full <- do- setup- select query-- liftIO $ do- 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 "allows joining between a primary key that is itself a key of another table, using ToBaseId" $ do- run $ do- let number = 101- insert_ $ Frontcover number ""- articleE@(Entity articleId _) <- insert' $ Article "title" number- articleMetaE <- insert' (ArticleMetadata articleId)-- articlesAndMetadata <- select $- from $ \(article `InnerJoin` articleMetadata) -> do- on (toBaseId (articleMetadata ^. ArticleMetadataId) ==. article ^. ArticleId)- return (article, articleMetadata)- liftIO $ [(articleE, articleMetaE)] `shouldBe` articlesAndMetadata-- 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 = describe "select subquery" $ do- it "works" $ run $ do- _ <- insert' p1- let q = do- p <- Experimental.from $ Table @Person- return ( p ^. PersonName, p ^. PersonAge)- ret <- select $ Experimental.from q- liftIO $ ret `shouldBe` [ (Value $ personName p1, Value $ personAge p1) ]-- it "supports sub-selecting Maybe entities" $ run $ do- l1e <- insert' l1- l3e <- insert' l3- l1Deeds <- mapM (\k -> insert' $ Deed k (entityKey l1e)) (map show [1..3 :: Int])- let l1WithDeeds = do d <- l1Deeds- pure (l1e, Just d)- let q = Experimental.from $ do- (lords :& deeds) <-- Experimental.from $ Table @Lord- `LeftOuterJoin` Table @Deed- `Experimental.on` (\(l :& d) -> just (l ^. LordId) ==. d ?. DeedOwnerId)- pure (lords, deeds)-- ret <- select q- liftIO $ ret `shouldMatchList` ((l3e, Nothing) : l1WithDeeds)-- it "lets you order by alias" $ 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" $ 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" $ 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" $ 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` (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" $ run $ do- l1k <- insert l1- l3k <- insert l3- let q = do- (lord :& (_, dogCounts)) <- Experimental.from $ Table @Lord- `LeftOuterJoin` 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" $ run $ do- _ <- insert p1- _ <- insert p2- let q = Experimental.from $- (do- p <- Experimental.from $ Table @Person- where_ $ not_ $ isNothing $ p ^. PersonAge- return (p ^. PersonName))- `union_`- (do- p <- Experimental.from $ Table @Person- where_ $ isNothing $ p ^. PersonAge- return (p ^. PersonName))- `union_`- (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 = 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 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 = 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 (\a -> select $ distinct a)-- it "works on a simple example (distinct (return ()))" $- selDistTest (\act -> select $ distinct (return ()) >> act)----testCoasleceDefault :: Run -> Spec-testCoasleceDefault run = 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 = describe "delete" $ do- 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 = 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 composite primary key" $ run $ do- p1k <- insert $ Point 1 2 "asdf"- p2k <- insert $ Point 2 3 "asdf"- ret <-- selectRethrowingQuery $- from $ \point -> do- where_ $ point ^. PointName ==. val "asdf"- groupBy (point ^. PointId)- pure (point ^. PointId)- liftIO $ do- ret `shouldMatchList`- map Value [p1k, p2k]---- 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" $ 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 = 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 = 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- let user = EI.unsafeSqlEntity (EI.I "user")- blogPost = EI.unsafeSqlEntity (EI.I "blog_post")- pure $ (,) c $ EI.renderExpr conn $- user ^. PersonId ==. blogPost ^. 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 "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 ()-- it "can call functions on aliased values" $ do- run $ do- insert_ p1- insert_ p3- -- Pretend this isnt all posts- upperNames <- select $ do- author <- Experimental.from $ SelectQuery $ Experimental.from $ Table @Person- pure $ upper_ $ author ^. PersonName-- liftIO $ upperNames `shouldMatchList` [ Value "JOHN"- , Value "MIKE"- ]--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- , MonadLoggerIO 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 ()-- delete $ from $ \(_ :: SqlExpr (Entity DateTruncTest)) -> pure ()---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--updateRethrowingQuery- ::- ( MonadUnliftIO m- , PersistEntity val- , BackendCompatible SqlBackend (PersistEntityBackend val)- )- => (SqlExpr (Entity val) -> SqlQuery ())- -> SqlWriteT m ()-updateRethrowingQuery k =- update k- `catch` \(SomeException e) -> do- (text, _) <- renderQueryUpdate (from k)- liftIO . throwIO . userError $ Text.unpack text <> "\n\n" <> show e+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -fno-warn-unused-binds #-}+{-# OPTIONS_GHC -fno-warn-deprecations #-}+module Common.Test+ ( tests+ , testLocking+ , testAscRandom+ , testRandomMath+ , migrateAll+ , migrateUnique+ , cleanDB+ , cleanUniques+ , updateRethrowingQuery+ , selectRethrowingQuery+ , 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(..)+ , DateTruncTest(..)+ , DateTruncTestId+ , Key(..)+ ) where++import Common.Test.Import hiding (from, on)++import Control.Monad (forM_, replicateM, replicateM_, void)+import Data.Either+import qualified Data.Attoparsec.Text as AP+import Data.Char (toLower, toUpper)+import Data.Monoid ((<>))+import Database.Esqueleto+import qualified Database.Esqueleto.Experimental as Experimental++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.Internal.Lazy as TL+import qualified Data.Text.Lazy.Builder as TLB+import qualified Database.Esqueleto.Internal.ExprParser as P+import qualified Database.Esqueleto.Internal.Internal as EI+import qualified UnliftIO.Resource as R++import Common.Test.Select++-- Test schema+-- | 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++testSubSelect :: SpecDb+testSubSelect = 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+ itDb "is safe for queries that may return multiple results" $ do+ let query =+ from $ \n -> do+ orderBy [asc (n ^. NumbersInt)]+ pure (n ^. NumbersInt)+ setup+ res <- select $ pure $ subSelect query+ eres <- try $ do+ select $ pure $ sub_select query+ asserting $ do+ res `shouldBe` [Value (Just 1)]+ 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]++ itDb "is safe for queries that may not return anything" $ do+ let query =+ from $ \n -> do+ orderBy [asc (n ^. NumbersInt)]+ limit 1+ pure (n ^. NumbersInt)+ setup+ res <- select $ pure $ subSelect query+ transactionUndo++ eres <- try $ do+ select $ pure $ sub_select query++ asserting $ do+ res `shouldBe` [Value $ Just 1]+ case eres of+ Left (_ :: PersistException) ->+ -- We expect to receive this exception. However, sqlite evidently has+ -- no problems with itDb, 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+ itDb "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 <- select query++ full <- do+ setup+ select query++ asserting $ do+ empty `shouldBe` []+ full `shouldSatisfy` (not . null)++ describe "subSelectMaybe" $ do+ itDb "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))++ setup+ a <- select (query subSelectMaybe)+ b <- select (query (joinV . subSelect))+ asserting $ a `shouldBe` b++ describe "subSelectCount" $ do+ itDb "is a safe way to do a countRows" $ do+ setup+ xs0 <-+ select $+ from $ \n -> do+ pure $ (,) n $+ subSelectCount @Int $+ from $ \n' -> do+ where_ $ n' ^. NumbersInt >=. n ^. NumbersInt++ xs1 <-+ 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)+ asserting $+ map getter xs0 `shouldBe` map getter xs1++ describe "subSelectUnsafe" $ do+ itDb "throws exceptions on multiple results" $ do+ setup+ eres <- try $ do+ 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)+ asserting $ 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++ itDb "throws exceptions on null results" $ do+ setup+ eres <- try $ do+ select $+ from $ \n -> do+ pure $ (,) (n ^. NumbersInt) $+ subSelectUnsafe $+ from $ \n' -> do+ where_ $ val False+ pure (n' ^. NumbersDouble)+ asserting $ case eres of+ Left (_ :: PersistException) ->+ pure ()+ Right xs ->+ xs `shouldBe` []++testSelectOne :: SpecDb+testSelectOne =+ describe "selectOne" $ do+ let personQuery =+ selectOne $ do+ person <- Experimental.from $ Experimental.table @Person+ where_ $ person ^. PersonFavNum >=. val 1+ orderBy [asc (person ^. PersonId)]+ return $ person ^. PersonId+ itDb "returns Just" $ do+ person <- insert' p1+ _ <- insert' p2+ res <- personQuery+ asserting $+ res `shouldBe` Just (Value $ entityKey person)++ itDb "returns Nothing" $ do+ res <- personQuery+ asserting $+ res `shouldBe` (Nothing :: Maybe (Value PersonId))++testSelectSource :: SpecDb+testSelectSource = do+ describe "selectSource" $ do+ itDb "works for a simple example" $ do+ let query+ :: ConduitT () (Entity Person) (SqlPersistT (R.ResourceT IO)) ()+ query =+ selectSource $+ from $ \person ->+ return person+ p1e <- insert' p1+ ret <- mapReaderT R.runResourceT $ runConduit $ query .| CL.consume+ asserting $ ret `shouldBe` [ p1e ]++ itDb "can run a query many times" $ do+ let query+ :: ConduitT () (Entity Person) (SqlPersistT (R.ResourceT IO)) ()+ query =+ selectSource $+ from $ \person ->+ return person+ p1e <- insert' p1+ ret0 <- mapReaderT R.runResourceT $ runConduit $ query .| CL.consume+ ret1 <- mapReaderT R.runResourceT $ runConduit $ query .| CL.consume+ asserting $ do+ ret0 `shouldBe` [ p1e ]+ ret1 `shouldBe` [ p1e ]++ itDb "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+ p1e <- insert' p1+ p2e <- insert' p2+ r1 <- mapReaderT R.runResourceT $ runConduit $ selectPerson (personName p1) .| CL.consume+ r2 <- mapReaderT R.runResourceT $ runConduit $ selectPerson (personName p2) .| CL.consume+ asserting $ do+ r1 `shouldBe` [ entityKey p1e ]+ r2 `shouldBe` [ entityKey p2e ]++testSelectFrom :: SpecDb+testSelectFrom = do+ describe "select/from" $ do+ itDb "works for a simple example" $ do+ p1e <- insert' p1+ ret <-+ select $+ from $ \person ->+ return person+ asserting $ ret `shouldBe` [ p1e ]++ itDb "works for a simple self-join (one entity)" $ do+ p1e <- insert' p1+ ret <-+ select $+ from $ \(person1, person2) ->+ return (person1, person2)+ asserting $ ret `shouldBe` [ (p1e, p1e) ]++ itDb "works for a simple self-join (two entities)" $ do+ p1e <- insert' p1+ p2e <- insert' p2+ ret <-+ select $+ from $ \(person1, person2) ->+ return (person1, person2)+ asserting $+ ret+ `shouldSatisfy`+ sameElementsAs+ [ (p1e, p1e)+ , (p1e, p2e)+ , (p2e, p1e)+ , (p2e, p2e)+ ]++ itDb "works for a self-join via sub_select" $ 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+ asserting $ length ret `shouldBe` 2++ itDb "works for a self-join via exists" $ 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+ asserting $ length ret `shouldBe` 2+++ itDb "works for a simple projection" $ do+ p1k <- insert p1+ p2k <- insert p2+ ret <- select $+ from $ \p ->+ return (p ^. PersonId, p ^. PersonName)+ asserting $ ret `shouldBe` [ (Value p1k, Value (personName p1))+ , (Value p2k, Value (personName p2)) ]++ itDb "works for a simple projection with a simple implicit self-join" $ do+ _ <- insert p1+ _ <- insert p2+ ret <- select $+ from $ \(pa, pb) ->+ return (pa ^. PersonName, pb ^. PersonName)+ asserting $ 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)) ]++ itDb "works with many kinds of LIMITs and OFFSETs" $ 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+ asserting $ ret1 `shouldBe` [ p1e ]+ ret2 <-+ select $ do+ p <- people+ limit 1+ limit 2+ return p+ asserting $ ret2 `shouldBe` [ p1e, p4e ]+ ret3 <-+ select $ do+ p <- people+ offset 3+ offset 2+ return p+ asserting $ ret3 `shouldBe` [ p3e, p2e ]+ ret4 <-+ select $ do+ p <- people+ offset 3+ limit 5+ offset 2+ limit 3+ offset 1+ limit 2+ return p+ asserting $ ret4 `shouldBe` [ p4e, p3e ]+ ret5 <-+ select $ do+ p <- people+ offset 1000+ limit 1+ limit 1000+ offset 0+ return p+ asserting $ ret5 `shouldBe` [ p1e, p4e, p3e, p2e ]++ itDb "works with non-id primary key" $ do+ let fc = Frontcover number ""+ number = 101 :: Int+ Right thePk = keyFromValues [toPersistValue number]+ fcPk <- insert fc+ [Entity _ ret] <- select $ from return+ asserting $ do+ ret `shouldBe` fc+ fcPk `shouldBe` thePk++ itDb "works when returning a custom non-composite primary key from a query" $ do+ let name = "foo"+ t = Tag name+ Right thePk = keyFromValues [toPersistValue name]+ tagPk <- insert t+ [Value ret] <- select $ from $ \t' -> return (t'^.TagId)+ asserting $ do+ ret `shouldBe` thePk+ thePk `shouldBe` tagPk++ itDb "works when returning a composite primary key from a query" $ do+ let p = Point 10 20 ""+ thePk <- insert p+ [Value ppk] <- select $ from $ \p' -> return (p'^.PointId)+ asserting $ ppk `shouldBe` thePk++testSelectJoin :: SpecDb+testSelectJoin = do+ describe "select:JOIN" $ do+ itDb "works with a LEFT OUTER JOIN" $+ 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)+ asserting $ ret `shouldBe` [ (p1e, Just b11e)+ , (p1e, Just b12e)+ , (p4e, Nothing)+ , (p3e, Just b31e)+ , (p2e, Nothing) ]++ itDb "typechecks (A LEFT OUTER JOIN (B LEFT OUTER JOIN C))" $+ let+ _x :: SqlPersistT IO _+ _x =+ select $+ from $ \(a `LeftOuterJoin` (b `LeftOuterJoin` c)) ->+ let _ = [a, b, c] :: [ SqlExpr (Entity Person) ]+ in return a+ in asserting noExceptions++ itDb "typechecks ((A LEFT OUTER JOIN B) LEFT OUTER JOIN C)" $+ let _x :: SqlPersistT IO _+ _x =+ select $+ from $ \((a `LeftOuterJoin` b) `LeftOuterJoin` c) ->+ let _ = [a, b, c] :: [ SqlExpr (Entity Person) ]+ in return a+ in asserting noExceptions++ itDb "throws an error for using on without joins" $ do+ eres <- try $ select $+ from $ \(p, mb) -> do+ on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId)+ orderBy [ asc (p ^. PersonName), asc (mb ?. BlogPostTitle) ]+ return (p, mb)+ asserting $ shouldBeOnClauseWithoutMatchingJoinException eres++ itDb "throws an error for using too many ons" $ do+ eres <- try $ 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)+ asserting $ shouldBeOnClauseWithoutMatchingJoinException eres++ itDb "works with ForeignKey to a non-id primary key returning one entity" $+ 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+ asserting $ do+ retFc `shouldBe` fc+ fcPk `shouldBe` thePk+ itDb "allows using a primary key that is itself a key of another table" $+ 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+ asserting $ [articleMetaE] `shouldBe` result+ itDb "allows joining between a primary key that is itself a key of another table, using ToBaseId" $ do+ do+ let number = 101+ insert_ $ Frontcover number ""+ articleE@(Entity articleId _) <- insert' $ Article "title" number+ articleMetaE <- insert' (ArticleMetadata articleId)++ articlesAndMetadata <- select $+ from $ \(article `InnerJoin` articleMetadata) -> do+ on (toBaseId (articleMetadata ^. ArticleMetadataId) ==. article ^. ArticleId)+ return (article, articleMetadata)+ asserting $ [(articleE, articleMetaE)] `shouldBe` articlesAndMetadata++ itDb "works with a ForeignKey to a non-id primary key returning both entities" $+ 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)+ asserting $ do+ retFc `shouldBe` fc+ retArt `shouldBe` article+ fcPk `shouldBe` thePk+ articleFkfrontcover retArt `shouldBe` thePk++ itDb "works with a non-id primary key returning one entity" $+ 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+ asserting $ 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"+ {-+ 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'+ asserting $ do+ ret `shouldBe` p+ pPk `shouldBe` thePk+ -}++ itDb "works when joining via a non-id primary key" $+ 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)+ asserting $ do+ retArt `shouldBe` article+ retTag `shouldBe` tag++ itDb "respects the associativity of joins" $+ 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+ asserting $ (entityVal <$> ps) `shouldBe` [p1]++testSelectSubQuery :: SpecDb+testSelectSubQuery = describe "select subquery" $ do+ itDb "works" $ do+ _ <- insert' p1+ let q = do+ p <- Experimental.from $ Table @Person+ return ( p ^. PersonName, p ^. PersonAge)+ ret <- select $ Experimental.from q+ asserting $ ret `shouldBe` [ (Value $ personName p1, Value $ personAge p1) ]++ itDb "supports sub-selecting Maybe entities" $ do+ l1e <- insert' l1+ l3e <- insert' l3+ l1Deeds <- mapM (\k -> insert' $ Deed k (entityKey l1e)) (map show [1..3 :: Int])+ let l1WithDeeds = do d <- l1Deeds+ pure (l1e, Just d)+ let q = Experimental.from $ do+ (lords :& deeds) <-+ Experimental.from $ Table @Lord+ `LeftOuterJoin` Table @Deed+ `Experimental.on` (\(l :& d) -> just (l ^. LordId) ==. d ?. DeedOwnerId)+ pure (lords, deeds)++ ret <- select q+ asserting $ ret `shouldMatchList` ((l3e, Nothing) : l1WithDeeds)++ itDb "lets you order by alias" $ 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+ asserting $ ret `shouldBe` [ Value $ personName p3, Value $ personName p1 ]++ itDb "supports groupBy" $ 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'++ asserting $ ret `shouldMatchList` [ (Value l3k, Value 7)+ , (Value l1k, Value 3) ]++ itDb "Can count results of aggregate query" $ 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)++ asserting $ ret `shouldMatchList` [ (Value 1) ]++ itDb "joins on subqueries" $ 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` (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+ asserting $ ret `shouldMatchList` [ (Value l3k, Value 7)+ , (Value l1k, Value 3) ]++ itDb "flattens maybe values" $ do+ l1k <- insert l1+ l3k <- insert l3+ let q = do+ (lord :& (_, dogCounts)) <- Experimental.from $ Table @Lord+ `LeftOuterJoin` 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+ asserting $ ret `shouldMatchList` [ (Value l3k, Value (lordDogs l3))+ , (Value l1k, Value (lordDogs l1)) ]+ itDb "unions" $ do+ _ <- insert p1+ _ <- insert p2+ let q = Experimental.from $+ (do+ p <- Experimental.from $ Table @Person+ where_ $ not_ $ isNothing $ p ^. PersonAge+ return (p ^. PersonName))+ `union_`+ (do+ p <- Experimental.from $ Table @Person+ where_ $ isNothing $ p ^. PersonAge+ return (p ^. PersonName))+ `union_`+ (do+ p <- Experimental.from $ Table @Person+ where_ $ isNothing $ p ^. PersonAge+ return (p ^. PersonName))+ names <- select q+ asserting $ names `shouldMatchList` [ (Value $ personName p1)+ , (Value $ personName p2) ]+testSelectWhere :: SpecDb+testSelectWhere = describe "select where_" $ do+ itDb "works for a simple example with (==.)" $ do+ p1e <- insert' p1+ _ <- insert' p2+ _ <- insert' p3+ ret <- select $+ from $ \p -> do+ where_ (p ^. PersonName ==. val "John")+ return p+ asserting $ ret `shouldBe` [ p1e ]++ itDb "works for a simple example with (==.) and (||.)" $ 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+ asserting $ ret `shouldBe` [ p1e, p2e ]++ itDb "works for a simple example with (>.) [uses val . Just]" $ do+ p1e <- insert' p1+ _ <- insert' p2+ _ <- insert' p3+ ret <- select $+ from $ \p -> do+ where_ (p ^. PersonAge >. val (Just 17))+ return p+ asserting $ ret `shouldBe` [ p1e ]++ itDb "works for a simple example with (>.) and not_ [uses just . val]" $ do+ _ <- insert' p1+ _ <- insert' p2+ p3e <- insert' p3+ ret <- select $+ from $ \p -> do+ where_ (not_ $ p ^. PersonAge >. just (val 17))+ return p+ asserting $ ret `shouldBe` [ p3e ]++ describe "when using between" $ do+ itDb "works for a simple example with [uses just . val]" $ 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+ asserting $ ret `shouldBe` [ p1e ]+ itDb "works for a proyected fields value" $ do+ _ <- insert' p1 >> insert' p2 >> insert' p3+ ret <-+ select $+ from $ \p -> do+ where_ $+ just (p ^. PersonFavNum)+ `between`+ (p ^. PersonAge, p ^. PersonWeight)+ asserting $ ret `shouldBe` []+ describe "when projecting composite keys" $ do+ itDb "works when using composite keys with val" $ do+ insert_ $ Point 1 2 ""+ ret <-+ select $+ from $ \p -> do+ where_ $+ p ^. PointId+ `between`+ ( val $ PointKey 1 2+ , val $ PointKey 5 6 )+ asserting $ ret `shouldBe` [()]++ itDb "works with avg_" $ 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)])+ asserting $ retV `shouldBe` [ Value $ Just testV ]++ itDb "works with min_" $+ do+ _ <- insert' p1+ _ <- insert' p2+ _ <- insert' p3+ _ <- insert' p4+ ret <- select $+ from $ \p->+ return $ joinV $ min_ (p ^. PersonAge)+ asserting $ ret `shouldBe` [ Value $ Just (17 :: Int) ]++ itDb "works with max_" $ do+ _ <- insert' p1+ _ <- insert' p2+ _ <- insert' p3+ _ <- insert' p4+ ret <- select $+ from $ \p->+ return $ joinV $ max_ (p ^. PersonAge)+ asserting $ ret `shouldBe` [ Value $ Just (36 :: Int) ]++ itDb "works with lower_" $ 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+ asserting $ ret1 `shouldBe` [ p1e ]++ -- name == lower('BOB')+ ret2 <- select $+ from $ \p-> do+ where_ (p ^. PersonName ==. lower_ (val $ map toUpper $ personName bob))+ return p+ asserting $ ret2 `shouldBe` [ p2e ]++ itDb "works with round_" $ do+ ret <- select $ return $ round_ (val (16.2 :: Double))+ asserting $ ret `shouldBe` [ Value (16 :: Double) ]++ itDb "works with isNothing" $ do+ _ <- insert' p1+ p2e <- insert' p2+ _ <- insert' p3+ ret <- select $+ from $ \p -> do+ where_ $ isNothing (p ^. PersonAge)+ return p+ asserting $ ret `shouldBe` [ p2e ]++ itDb "works with not_ . isNothing" $ do+ p1e <- insert' p1+ _ <- insert' p2+ ret <- select $+ from $ \p -> do+ where_ $ not_ (isNothing (p ^. PersonAge))+ return p+ asserting $ ret `shouldBe` [ p1e ]++ itDb "works for a many-to-many implicit join" $+ 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)+ asserting $ ret `shouldBe` [ (p1e, f11, p1e)+ , (p1e, f12, p2e)+ , (p4e, f42, p2e)+ , (p2e, f21, p1e) ]++ itDb "works for a many-to-many explicit join" $ 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)+ asserting $ ret `shouldBe` [ (p1e, f11, p1e)+ , (p1e, f12, p2e)+ , (p4e, f42, p2e)+ , (p2e, f21, p1e) ]++ itDb "works for a many-to-many explicit join and on order doesn't matter" $ do+ 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+ asserting noExceptions++ itDb "works for a many-to-many explicit join with LEFT OUTER JOINs" $ 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)+ asserting $ 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) ]++ itDb "works with a composite primary key" $ 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'+ asserting $ do+ ret `shouldBe` p+ pPk `shouldBe` thePk++testSelectOrderBy :: SpecDb+testSelectOrderBy = describe "select/orderBy" $ do+ itDb "works with a single ASC field" $ do+ p1e <- insert' p1+ p2e <- insert' p2+ p3e <- insert' p3+ ret <- select $+ from $ \p -> do+ orderBy [asc $ p ^. PersonName]+ return p+ asserting $ ret `shouldBe` [ p1e, p3e, p2e ]++ itDb "works with a sub_select" $ 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)+ asserting $ ret `shouldBe` (Value <$> [b2k, b3k, b4k, b1k])++ itDb "works on a composite primary key" $ do+ let ps = [Point 2 1 "", Point 1 2 ""]+ mapM_ insert ps+ eps <- select $+ from $ \p' -> do+ orderBy [asc (p'^.PointId)]+ return p'+ asserting $ map entityVal eps `shouldBe` reverse ps++testAscRandom :: SqlExpr (Value Double) -> SpecDb+testAscRandom rand' = describe "random_" $+ itDb "asc random_ works" $ 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.+ asserting $ S.size rets `shouldSatisfy` (>2)++testSelectDistinct :: SpecDb+testSelectDistinct = do+ describe "SELECT DISTINCT" $ do+ let selDistTest+ ::+ ( SqlQuery (SqlExpr (Value String))+ -> SqlPersistT IO [Value String]+ )+ -> SqlPersistT IO ()+ selDistTest q = 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+ asserting $ ret `shouldBe` [ Value t1, Value t2, Value t3 ]++ itDb "works on a simple example (select . distinct)" $+ selDistTest (\a -> select $ distinct a)++ itDb "works on a simple example (distinct (return ()))" $+ selDistTest (\act -> select $ distinct (return ()) >> act)++++testCoasleceDefault :: SpecDb+testCoasleceDefault = describe "coalesce/coalesceDefault" $ do+ itDb "works on a simple example" $ do+ mapM_ insert' [p1, p2, p3, p4, p5]+ ret1 <- select $+ from $ \p -> do+ orderBy [asc (p ^. PersonId)]+ return (coalesce [p ^. PersonAge, p ^. PersonWeight])+ asserting $ 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))+ asserting $ ret2 `shouldBe` [ Value (36 :: Int)+ , Value 37+ , Value 17+ , Value 17+ , Value 5+ ]++ itDb "works with sub-queries" $ 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))+ asserting $ ret `shouldBe` [ Value (36 :: Int)+ , Value 42+ , Value 17+ ]+++testDelete :: SpecDb+testDelete = describe "delete" $ do+ itDb "works on a simple example" $ do+ p1e <- insert' p1+ p2e <- insert' p2+ p3e <- insert' p3+ let getAll = select $+ from $ \p -> do+ orderBy [asc (p ^. PersonName)]+ return p+ ret1 <- getAll+ asserting $ ret1 `shouldBe` [ p1e, p3e, p2e ]+ () <- delete $+ from $ \p ->+ where_ (p ^. PersonName ==. val (personName p1))+ ret2 <- getAll+ asserting $ ret2 `shouldBe` [ p3e, p2e ]+ n <- deleteCount $+ from $ \p ->+ return ((p :: SqlExpr (Entity Person)) `seq` ())+ ret3 <- getAll+ asserting $ (n, ret3) `shouldBe` (2, [])++testUpdate :: SpecDb+testUpdate = describe "update" $ do+ itDb "works with a subexpression having COUNT(*)" $ 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+ asserting $ 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"+ {-+ 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+ asserting $ do+ ret `shouldBe` Point newX newY []+ -}++ itDb "GROUP BY works with COUNT" $ 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)+ asserting $ ret `shouldBe` [ (Entity p2k p2, Value (0 :: Int))+ , (Entity p1k p1, Value 3)+ , (Entity p3k p3, Value 7) ]++ itDb "GROUP BY works with composite primary key" $ do+ p1k <- insert $ Point 1 2 "asdf"+ p2k <- insert $ Point 2 3 "asdf"+ ret <-+ selectRethrowingQuery $+ from $ \point -> do+ where_ $ point ^. PointName ==. val "asdf"+ groupBy (point ^. PointId)+ pure (point ^. PointId)+ asserting $ do+ ret `shouldMatchList`+ map Value [p1k, p2k]++++ itDb "GROUP BY works with COUNT and InnerJoin" $ 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)+ asserting $ ret `shouldMatchList` [ (Value l3k, Value 7)+ , (Value l1k, Value 3) ]++ itDb "GROUP BY works with nested tuples" $ 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)+ asserting $ length ret `shouldBe` 10++ itDb "GROUP BY works with HAVING" $ 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)+ asserting $ 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 :: SpecDb+testListOfValues = describe "lists of values" $ do+ itDb "IN works for valList" $ 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+ asserting $ ret `shouldBe` [ Entity p1k p1+ , Entity p2k p2 ]++ itDb "IN works for valList (null list)" $ do+ _p1k <- insert p1+ _p2k <- insert p2+ _p3k <- insert p3+ ret <- select $+ from $ \p -> do+ where_ (p ^. PersonName `in_` valList [])+ return p+ asserting $ ret `shouldBe` []++ itDb "IN works for subList_select" $ 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+ asserting $ L.sort ret `shouldBe` L.sort [Entity p1k p1, Entity p3k p3]++ itDb "NOT IN works for subList_select" $ 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+ asserting $ ret `shouldBe` [ Entity p2k p2 ]++ itDb "EXISTS works for subList_select" $ 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+ asserting $ ret `shouldBe` [ Entity p1k p1+ , Entity p3k p3 ]++ itDb "EXISTS works for subList_select" $ 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+ asserting $ ret `shouldBe` [ Entity p2k p2 ]++testListFields :: SpecDb+testListFields = describe "list fields" $ do+ -- <https://github.com/prowdsponsor/esqueleto/issues/100>+ itDb "can update list fields" $ do+ cclist <- insert $ CcList []+ update $ \p -> do+ set p [ CcListNames =. val ["fred"]]+ where_ (p ^. CcListId ==. val cclist)+ asserting noExceptions++testInsertsBySelect :: SpecDb+testInsertsBySelect = do+ describe "inserts by select" $ do+ itDb "IN works for insertSelect" $+ 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)+ asserting $ ret `shouldBe` [Value (3::Int)]++++++testInsertsBySelectReturnsCount :: SpecDb+testInsertsBySelectReturnsCount = do+ describe "inserts by select, returns count" $ do+ itDb "IN works for insertSelectCount" $+ 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)+ asserting $ ret `shouldBe` [Value (3::Int)]+ asserting $ cnt `shouldBe` 3+++++testRandomMath :: SpecDb+testRandomMath = describe "random_ math" $+ itDb "rand returns result in random order" $+ 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)++ asserting $ (ret1 == ret2) `shouldBe` False++testMathFunctions :: SpecDb+testMathFunctions = do+ describe "Math-related functions" $ do+ itDb "castNum works for multiplying Int and Double" $+ 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+ asserting $ length ret `shouldBe` 2+ let [Value a, Value b] = ret+ asserting $ max (abs (a - 6.8)) (abs (b - 7.7)) `shouldSatisfy` (< 0.01)++++++testCase :: SpecDb+testCase = do+ describe "case" $ do+ itDb "Works for a simple value based when - False" $+ do+ ret <- select $+ return $+ case_+ [ when_ (val False) then_ (val (1 :: Int)) ]+ (else_ (val 2))++ asserting $ ret `shouldBe` [ Value 2 ]++ itDb "Works for a simple value based when - True" $+ do+ ret <- select $+ return $+ case_+ [ when_ (val True) then_ (val (1 :: Int)) ]+ (else_ (val 2))++ asserting $ ret `shouldBe` [ Value 1 ]++ itDb "works for a semi-complicated query" $+ 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))++ asserting $ ret `shouldBe` [ Value (3) ]++++++testLocking :: SpecDb+testLocking = 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+ conn <- ask+ [complex, with1, with2, with3] <-+ return $+ map (toText conn) [complexQuery, queryWithClause1, queryWithClause2, queryWithClause3]+ let expected = complex <> "\n" <> syntax+ asserting $+ (with1, with2, with3) `shouldBe` (expected, expected, expected)++ itDb "looks sane for ForUpdate" $ sanityCheck ForUpdate "FOR UPDATE"+ itDb "looks sane for ForUpdateSkipLocked" $ sanityCheck ForUpdateSkipLocked "FOR UPDATE SKIP LOCKED"+ itDb "looks sane for ForShare" $ sanityCheck ForShare "FOR SHARE"+ itDb "looks sane for LockInShareMode" $ sanityCheck LockInShareMode "LOCK IN SHARE MODE"++++++testCountingRows :: SpecDb+testCountingRows = 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) ->+ itDb (title ++ " works as expected") $+ 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+ asserting $ (n :: Int) `shouldBe` expected++testRenderSql :: SpecDb+testRenderSql = do+ describe "testRenderSql" $ do+ itDb "works" $ do+ (queryText, queryVals) <- 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+ asserting $ do+ 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+ itDb "renders a value" $ do+ (c, expr) <- do+ conn <- ask+ let Right c = P.mkEscapeChar conn+ let user = EI.unsafeSqlEntity (EI.I "user")+ blogPost = EI.unsafeSqlEntity (EI.I "blog_post")+ pure $ (,) c $ EI.renderExpr conn $+ user ^. PersonId ==. blogPost ^. BlogPostAuthorId+ asserting $ do+ expr+ `shouldBe`+ Text.intercalate (Text.singleton c) ["", "user", ".", "id", ""]+ <>+ " = "+ <>+ Text.intercalate (Text.singleton c) ["", "blog_post", ".", "authorId", ""]++ itDb "renders ? for a val" $ do+ expr <- ask >>= \c -> pure $ EI.renderExpr c (val (PersonKey 0) ==. val (PersonKey 1))+ asserting $ expr `shouldBe` "? = ?"++ beforeWith (\_ -> pure ()) $ 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 :: SpecDb+testOnClauseOrder = 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+ itDb "three tables" $ do+ setup+ abcs <-+ select $+ from $ \(a `InnerJoin` b `InnerJoin` c) -> do+ on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)+ on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)+ pure (a, b, c)+ acbs <-+ select $+ from $ \(a `InnerJoin` b `InnerJoin` c) -> do+ on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)+ on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)+ pure (a, b, c)++ asserting $ do+ listsEqualOn abcs acbs $ \(Entity _ j1, Entity _ j2, Entity _ j3) ->+ (joinOneName j1, joinTwoName j2, joinThreeName j3)++ itDb "four tables" $ do+ setup+ xs0 <-+ 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 <-+ 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 <-+ 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 <-+ 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 <-+ 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)+ )+ asserting $ do+ listsEqualOn xs0 xs1 getNames+ listsEqualOn xs0 xs2 getNames+ listsEqualOn xs0 xs3 getNames+ listsEqualOn xs0 xs4 getNames++ itDb "associativity of innerjoin" $ do+ setup+ xs0 <-+ 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 <-+ 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 <-+ 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 <-+ 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)+ )+ asserting $ do+ listsEqualOn xs0 xs1 getNames+ listsEqualOn xs0 xs2 getNames+ listsEqualOn xs0 xs3 getNames++ itDb "inner join on two entities" $ do+ (xs0, xs1) <- 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)+ asserting $ listsEqualOn xs0 xs1 $ \(Entity _ p, Entity _ b, Entity _ pr) ->+ (personName p, blogPostTitle b, profileName pr)+ itDb "inner join on three entities" $ do+ res <- 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]+ asserting $ forM_ (zip res (drop 1 (cycle res))) $ \(a, b) -> a `shouldBe` b++ itDb "many-to-many" $ do+ setup+ ac <-+ select $+ from $ \(a `InnerJoin` b `InnerJoin` c) -> do+ on (a ^. JoinOneId ==. b ^. JoinManyJoinOne)+ on (c ^. JoinOtherId ==. b ^. JoinManyJoinOther)+ pure (a, c)++ ca <-+ select $+ from $ \(a `InnerJoin` b `InnerJoin` c) -> do+ on (c ^. JoinOtherId ==. b ^. JoinManyJoinOther)+ on (a ^. JoinOneId ==. b ^. JoinManyJoinOne)+ pure (a, c)++ asserting $ listsEqualOn ac ca $ \(Entity _ a, Entity _ b) ->+ (joinOneName a, joinOtherName b)++ itDb "left joins on order" $ do+ setup+ ca <-+ 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 <-+ 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)++ asserting $ listsEqualOn ac ca $ \(Entity _ a, b) ->+ (joinOneName a, maybe "NULL" (joinOtherName . entityVal) b)++ itDb "doesn't require an on for a crossjoin" $ do+ void $+ select $+ from $ \(a `CrossJoin` b) -> do+ pure (a :: SqlExpr (Entity JoinOne), b :: SqlExpr (Entity JoinTwo))+ asserting noExceptions++ itDb "errors with an on for a crossjoin" $ do+ eres <-+ try $+ select $+ from $ \(a `CrossJoin` b) -> do+ on $ a ^. JoinOneId ==. b ^. JoinTwoJoinOne+ pure (a, b)+ asserting $+ case eres of+ Left (OnClauseWithoutMatchingJoinException _) ->+ pure ()+ Right _ ->+ expectationFailure "Expected OnClause exception"++ itDb "left joins associativity" $ do+ setup+ ca <-+ 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' <-+ 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)++ asserting $ listsEqualOn ca ca' $ \(Entity _ a, b) ->+ (joinOneName a, maybe "NULL" (joinOtherName . entityVal) b)++ itDb "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)+ 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)+ asserting $ listsEqualOn a (map (\(x, y) -> (y, x)) b) id++ itDb "works with joins in subselect" $ do+ 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)+ asserting noExceptions++ describe "works with nested joins" $ do+ itDb "unnested" $ do+ 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)+ asserting noExceptions++ itDb "leftmost nesting" $ do+ 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)+ asserting noExceptions+ describe "middle nesting" $ do+ itDb "direct association" $ do+ 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)+ asserting noExceptions+ itDb "indirect association" $ do+ 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)+ asserting noExceptions+ itDb "indirect association across" $ do+ 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)+ asserting noExceptions++ describe "rightmost nesting" $ do+ itDb "direct associations" $ do+ 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)+ asserting noExceptions++ itDb "indirect association" $ do+ 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)+ asserting noExceptions++testExperimentalFrom :: SpecDb+testExperimentalFrom = do+ describe "Experimental From" $ do+ itDb "supports basic table queries" $ do+ p1e <- insert' p1+ _ <- insert' p2+ p3e <- insert' p3+ peopleWithAges <- select $ do+ people <- Experimental.from $ Table @Person+ where_ $ not_ $ isNothing $ people ^. PersonAge+ return people+ asserting $ peopleWithAges `shouldMatchList` [p1e, p3e]++ itDb "supports inner joins" $ 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)+ asserting $ lordDeeds `shouldMatchList` [ (l1e, d1e)+ , (l1e, d2e)+ ]++ itDb "supports outer joins" $ 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)+ asserting $ lordDeeds `shouldMatchList` [ (l1e, Just d1e)+ , (l1e, Just d2e)+ , (l2e, Nothing)+ ]+ itDb "supports delete" $ do+ insert_ l1+ insert_ l2+ insert_ l3+ delete $ void $ Experimental.from $ Table @Lord+ lords <- select $ Experimental.from $ Table @Lord+ asserting $ lords `shouldMatchList` []++ itDb "supports implicit cross joins" $ 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)+ asserting $ ret `shouldMatchList` ret2+ asserting $ ret `shouldMatchList` [ (l1e, l1e)+ , (l1e, l2e)+ , (l2e, l1e)+ , (l2e, l2e)+ ]+++ itDb "compiles" $ 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)+ asserting noExceptions++ itDb "can call functions on aliased values" $ do+ insert_ p1+ insert_ p3+ -- Pretend this isnt all posts+ upperNames <- select $ do+ author <- Experimental.from $ SelectQuery $ Experimental.from $ Table @Person+ pure $ upper_ $ author ^. PersonName++ asserting $ upperNames `shouldMatchList` [ Value "JOHN"+ , Value "MIKE"+ ]++listsEqualOn :: (HasCallStack, Show a1, Eq a1) => [a2] -> [a2] -> (a2 -> a1) -> Expectation+listsEqualOn a b f = map f a `shouldBe` map f b++tests :: SpecDb+tests =+ describe "Esqueleto" $ do+ testSelect+ testSubSelect+ testSelectOne+ testSelectSource+ testSelectFrom+ testSelectJoin+ testSelectSubQuery+ testSelectWhere+ testSelectOrderBy+ testSelectDistinct+ testCoasleceDefault+ testDelete+ testUpdate+ testListOfValues+ testListFields+ testInsertsBySelect+ testMathFunctions+ testCase+ testCountingRows+ testRenderSql+ testOnClauseOrder+ testExperimentalFrom+ testLocking++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+++-- 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. _+ => SqlPersistT 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 ()++ delete $ from $ \(_ :: SqlExpr (Entity DateTruncTest)) -> pure ()+++cleanUniques+ :: forall m. MonadIO m+ => SqlPersistT 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++updateRethrowingQuery+ ::+ ( MonadUnliftIO m+ , PersistEntity val+ , BackendCompatible SqlBackend (PersistEntityBackend val)+ )+ => (SqlExpr (Entity val) -> SqlQuery ())+ -> SqlWriteT m ()+updateRethrowingQuery k =+ update k+ `catch` \(SomeException e) -> do+ (text, _) <- renderQueryUpdate (from k)+ liftIO . throwIO . userError $ Text.unpack text <> "\n\n" <> show e++shouldBeOnClauseWithoutMatchingJoinException+ :: (HasCallStack, Show a)+ => Either SomeException a+ -> Expectation+shouldBeOnClauseWithoutMatchingJoinException ea =+ case ea of+ Left (fromException -> Just OnClauseWithoutMatchingJoinException {}) ->+ pure ()+ _ ->+ expectationFailure $ "Expected OnClauseWithMatchingJoinException, got: " <> show ea
+ test/Common/Test/Import.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE CPP, AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}++module Common.Test.Import+ ( module Common.Test.Import+ , module X+ ) where++import System.Environment+import Control.Applicative+import Common.Test.Models as X+import Database.Esqueleto.Experimental as X hiding (random_)+import Test.Hspec as X+import UnliftIO as X+import Control.Monad+import Test.QuickCheck+import Data.Text as X (Text)+import Control.Monad.Trans.Reader as X (ReaderT, mapReaderT, ask)++type SpecDb = SpecWith ConnectionPool++asserting :: MonadIO f => IO () -> SqlPersistT f ()+asserting a = liftIO a++noExceptions :: Expectation+noExceptions = pure ()++itDb+ :: (HasCallStack)+ => String+ -> SqlPersistT IO x+ -> SpecDb+itDb message action = do+ it message $ \connection -> do+ void $ testDb connection action++propDb+ :: (HasCallStack, Testable a)+ => String+ -> ((SqlPersistT IO () -> IO ()) -> a )+ -> SpecDb+propDb message action = do+ it message $ \connection -> do+ property (action (testDb connection))++testDb :: ConnectionPool -> SqlPersistT IO a -> IO a+testDb conn action =+ liftIO $ flip runSqlPool conn $ do+ a <- action+ transactionUndo+ pure a++setDatabaseState+ :: SqlPersistT IO a+ -> SqlPersistT IO ()+ -> SpecWith ConnectionPool+ -> SpecWith ConnectionPool+setDatabaseState create clean test =+ beforeWith (\conn -> runSqlPool create conn >> pure conn) $+ after (\conn -> runSqlPool clean conn) $+ test++isCI :: IO Bool+isCI = do+ env <- getEnvironment+ return $ case lookup "TRAVIS" env <|> lookup "CI" env of+ Just "true" -> True+ _ -> False
+ test/Common/Test/Models.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}++module Common.Test.Models where++import Data.Time+import Database.Esqueleto.Experimental+import Database.Persist.Sql+import Database.Persist.TH++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++ DateTruncTest+ created UTCTime+ deriving Eq Show+|]++-- Unique Test schema+share [mkPersist sqlSettings, mkMigrate "migrateUnique"] [persistUpperCase|+ OneUnique+ name String+ value Int+ UniqueValue value+ deriving Eq Show+|]+++instance ToBaseId ArticleMetadata where+ type BaseEnt ArticleMetadata = Article+ toBaseIdWitness articleId = ArticleMetadataKey articleId+
+ test/Common/Test/Select.hs view
@@ -0,0 +1,22 @@+module Common.Test.Select where++import Common.Test.Import++testSelect :: SpecDb+testSelect = do+ describe "select" $ do+ itDb "works for a single value" $ do+ ret <- select $ return $ val (3 :: Int)+ asserting $ ret `shouldBe` [ Value 3 ]++ itDb "works for a pair of a single value and ()" $ do+ ret <- select $ return (val (3 :: Int), ())+ asserting $ ret `shouldBe` [ (Value 3, ()) ]++ itDb "works for a single ()" $ do+ ret <- select $ return ()+ asserting $ ret `shouldBe` [ () ]++ itDb "works for a single NULL value" $ do+ ret <- select $ return nothing+ asserting $ ret `shouldBe` [ Value (Nothing :: Maybe Int) ]
test/MySQL/Test.hs view
@@ -4,13 +4,15 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -module Main (main) where+module MySQL.Test where +import Common.Test.Import hiding (from, on)+ import Control.Applicative import Control.Monad (void) import Control.Monad.IO.Class (MonadIO(liftIO)) import Control.Monad.Logger (runNoLoggingT, runStderrLoggingT)-import Control.Monad.Trans.Reader (ReaderT)+import Control.Monad.Trans.Reader (ReaderT, mapReaderT) import qualified Control.Monad.Trans.Resource as R import Database.Esqueleto import Database.Esqueleto.Experimental hiding (from, on)@@ -23,30 +25,16 @@ , connectUser , defaultConnectInfo , withMySQLConn+ , createMySQLPool ) -import System.Environment import Test.Hspec import Common.Test ---- testMysqlRandom :: Spec--- testMysqlRandom = do--- -- This is known not to work until--- -- we can differentiate behavior by database--- it "works with random_" $--- run $ do--- _ <- select $ return (random_ :: SqlExpr (Value Double))--- return ()-----testMysqlSum :: Spec+testMysqlSum :: SpecDb testMysqlSum = do- it "works with sum_" $- run $ do+ itDb "works with sum_" $ do _ <- insert' p1 _ <- insert' p2 _ <- insert' p3@@ -56,13 +44,9 @@ return $ joinV $ sum_ (p ^. PersonAge) liftIO $ ret `shouldBe` [ Value $ Just (36 + 17 + 17 :: Double ) ] ----testMysqlTwoAscFields :: Spec+testMysqlTwoAscFields :: SpecDb testMysqlTwoAscFields = do- it "works with two ASC fields (one call)" $- run $ do+ itDb "works with two ASC fields (one call)" $ do p1e <- insert' p1 p2e <- insert' p2 p3e <- insert' p3@@ -73,13 +57,9 @@ return p liftIO $ ret `shouldBe` [ p2e, p4e, p3e, p1e ] ----testMysqlOneAscOneDesc :: Spec+testMysqlOneAscOneDesc :: SpecDb testMysqlOneAscOneDesc = do- it "works with one ASC and one DESC field (two calls)" $- run $ do+ itDb "works with one ASC and one DESC field (two calls)" $ do p1e <- insert' p1 p2e <- insert' p2 p3e <- insert' p3@@ -94,10 +74,9 @@ -testMysqlCoalesce :: Spec+testMysqlCoalesce :: SpecDb testMysqlCoalesce = do- it "works on PostgreSQL and MySQL with <2 arguments" $- run $ do+ itDb "works on PostgreSQL and MySQL with <2 arguments" $ do _ :: [Value (Maybe Int)] <- select $ from $ \p -> do@@ -107,10 +86,9 @@ -testMysqlUpdate :: Spec+testMysqlUpdate :: SpecDb testMysqlUpdate = do- it "works on a simple example" $- run $ do+ itDb "works on a simple example" $ do p1k <- insert p1 p2k <- insert p2 p3k <- insert p3@@ -133,20 +111,13 @@ , Entity p1k (Person anon (Just 73) Nothing 1) , Entity p3k p3 ] ----nameContains :: (BaseBackend backend ~ SqlBackend,- BackendCompatible SqlBackend backend,- MonadIO m, SqlString s,- IsPersistBackend backend, PersistQueryRead backend,- PersistUniqueRead backend)+nameContains :: (SqlString s) => (SqlExpr (Value [Char]) -> SqlExpr (Value s) -> SqlExpr (Value Bool)) -> s -> [Entity Person]- -> ReaderT backend m ()+ -> SqlPersistT IO () nameContains f t expected = do ret <- select $ from $ \p -> do@@ -158,22 +129,20 @@ liftIO $ ret `shouldBe` expected -testMysqlTextFunctions :: Spec+testMysqlTextFunctions :: SpecDb testMysqlTextFunctions = do describe "text functions" $ do- it "like, (%) and (++.) work on a simple example" $- run $ do+ itDb "like, (%) and (++.) work on a simple example" $ do [p1e, p2e, p3e, p4e] <- mapM insert' [p1, p2, p3, p4] nameContains like "h" [p1e, p2e] nameContains like "i" [p4e, p3e] nameContains like "iv" [p4e] -testMysqlUnionWithLimits :: Spec+testMysqlUnionWithLimits :: SpecDb testMysqlUnionWithLimits = do describe "MySQL Union" $ do- it "supports limit/orderBy by parenthesizing" $ do- run $ do+ itDb "supports limit/orderBy by parenthesizing" $ do mapM_ (insert . Foo) [1..6] let q1 = do@@ -194,55 +163,32 @@ ret <- select $ Experimental.from $ q1 `union_` q2 liftIO $ ret `shouldMatchList` [Value 1, Value 2, Value 4, Value 5] --main :: IO ()-main = do- hspec $ do- tests run-- describe "Test MySQL locking" $ do- testLocking withConn+spec :: Spec+spec = beforeAll mkConnectionPool $ do+ tests describe "MySQL specific tests" $ do- -- definitely doesn't work at the moment- -- testMysqlRandom- testMysqlSum- testMysqlTwoAscFields- testMysqlOneAscOneDesc- testMysqlCoalesce- testMysqlUpdate- testMysqlTextFunctions- testMysqlUnionWithLimits-----run, runSilent, runVerbose :: Run-runSilent act = runNoLoggingT $ run_worker act-runVerbose act = runStderrLoggingT $ run_worker act-run =- if verbose- then runVerbose- else runSilent-+ -- definitely doesn't work at the moment+ -- testMysqlRandom+ testMysqlSum+ testMysqlTwoAscFields+ testMysqlOneAscOneDesc+ testMysqlCoalesce+ testMysqlUpdate+ testMysqlTextFunctions+ testMysqlUnionWithLimits verbose :: Bool verbose = False --run_worker :: RunDbMonad m => SqlPersistT (R.ResourceT m) a -> m a-run_worker act = withConn $ runSqlConn (migrateIt >> act)---migrateIt :: RunDbMonad m => SqlPersistT (R.ResourceT m) ()+migrateIt :: R.MonadUnliftIO m => SqlPersistT m () migrateIt = do- void $ runMigrationSilent migrateAll+ mapReaderT R.runResourceT $ void $ runMigrationSilent migrateAll cleanDB --withConn :: RunDbMonad m => (SqlBackend -> R.ResourceT m a) -> m a-withConn f = do- ci <- liftIO isCI+mkConnectionPool :: IO ConnectionPool+mkConnectionPool = do+ ci <- isCI let connInfo | ci = defaultConnectInfo@@ -260,12 +206,18 @@ , connectDatabase = "esqutest" , connectPort = 3306 }- R.runResourceT $ withMySQLConn connInfo f+ pool <-+ if verbose+ then+ runStderrLoggingT $+ createMySQLPool connInfo 4+ else+ runNoLoggingT $+ createMySQLPool connInfo 4 -isCI :: IO Bool-isCI = do- env <- getEnvironment- return $ case lookup "TRAVIS" env <|> lookup "CI" env of- Just "true" -> True- _ -> False + flip runSqlPool pool $ do+ migrateIt+ cleanDB++ pure pool
test/PostgreSQL/MigrateJSON.hs view
@@ -16,16 +16,13 @@ module PostgreSQL.MigrateJSON where -import Control.Monad.Trans.Resource (ResourceT)+import Common.Test.Import hiding (Value, from, on)+ import Data.Aeson (Value)-import Database.Esqueleto (SqlExpr, delete, from)+import Database.Esqueleto.Legacy (from) import Database.Esqueleto.PostgreSQL.JSON (JSONB)-import Database.Persist (Entity)-import Database.Persist.Sql (SqlPersistT) import Database.Persist.TH -import Common.Test (RunDbMonad)- -- JSON Table for PostgreSQL share [mkPersist sqlSettings, mkMigrate "migrateJSON"] [persistUpperCase| Json@@ -34,6 +31,6 @@ |] cleanJSON- :: (forall m. RunDbMonad m- => SqlPersistT (ResourceT m) ())+ :: forall m. MonadIO m+ => SqlPersistT m () cleanJSON = delete $ from $ \(_ :: SqlExpr (Entity Json)) -> return ()
test/PostgreSQL/Test.hs view
@@ -8,1473 +8,1405 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}-module Main (main) where--import Control.Arrow ((&&&))-import Control.Monad (void, when)-import Control.Monad.Catch-import Control.Monad.IO.Class (MonadIO(liftIO))-import Control.Monad.Logger (runNoLoggingT, runStderrLoggingT)-import Control.Monad.Trans.Reader (ReaderT, ask)-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 Data.Map (Map)-import qualified Data.Map.Strict as Map-import Data.Ord (comparing)-import qualified Data.Text as T-import qualified Data.Text.Encoding as TE-import Data.Time-import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime)-import Database.Esqueleto hiding (random_)-import Database.Esqueleto.Experimental hiding (from, on, random_)-import qualified Database.Esqueleto.Experimental as Experimental-import qualified Database.Esqueleto.Internal.Internal as ES-import Database.Esqueleto.PostgreSQL (random_)-import qualified Database.Esqueleto.PostgreSQL as EP-import Database.Esqueleto.PostgreSQL.JSON hiding ((-.), (?.), (||.))-import qualified Database.Esqueleto.PostgreSQL.JSON as JSON-import Database.Persist.Postgresql (withPostgresqlConn)-import Database.PostgreSQL.Simple (ExecStatus(..), SqlError(..))-import System.Environment-import Test.Hspec-import Test.Hspec.QuickCheck--import Common.Test-import PostgreSQL.MigrateJSON----testPostgresqlCoalesce :: Spec-testPostgresqlCoalesce = do- it "works on PostgreSQL and MySQL with <2 arguments" $- run $ do- _ :: [Value (Maybe Int)] <-- select $- from $ \p -> do- return (coalesce [p ^. PersonAge])- return ()--nameContains :: (BaseBackend backend ~ SqlBackend,- BackendCompatible SqlBackend backend,- MonadIO m, SqlString s,- IsPersistBackend backend, PersistQueryRead backend,- PersistUniqueRead backend)- => (SqlExpr (Value [Char])- -> SqlExpr (Value s)- -> SqlExpr (Value Bool))- -> s- -> [Entity Person]- -> ReaderT backend m ()-nameContains f t expected = do- ret <- select $- from $ \p -> do- where_ (f- (p ^. PersonName)- ((%) ++. val t ++. (%)))- orderBy [asc (p ^. PersonName)]- return p- liftIO $ ret `shouldBe` expected---testPostgresqlTextFunctions :: Spec-testPostgresqlTextFunctions = do- describe "text functions" $ do- it "like, (%) and (++.) work on a simple example" $- run $ do- [p1e, p2e, p3e, p4e] <- mapM insert' [p1, p2, p3, p4]- nameContains like "h" [p1e, p2e]- nameContains like "i" [p4e, p3e]- nameContains like "iv" [p4e]-- it "ilike, (%) and (++.) work on a simple example on PostgreSQL" $- run $ do- [p1e, _, p3e, _, p5e] <- mapM insert' [p1, p2, p3, p4, p5]- let nameContains' t expected = do- ret <- select $- from $ \p -> do- where_ (p ^. PersonName `ilike` (%) ++. val t ++. (%))- orderBy [asc (p ^. PersonName)]- return p- liftIO $ ret `shouldBe` expected- nameContains' "mi" [p3e, p5e]- nameContains' "JOHN" [p1e]------testPostgresqlUpdate :: Spec-testPostgresqlUpdate = do- it "works on a simple example" $- run $ 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.- liftIO $ n `shouldBe` 2- liftIO $ ret `shouldBe` [ Entity p1k (Person anon (Just 73) Nothing 1)- , Entity p2k (Person anon Nothing (Just 37) 2)- , Entity p3k p3 ]------testPostgresqlRandom :: Spec-testPostgresqlRandom = do- it "works with random_" $- run $ do- _ <- select $ return (random_ :: SqlExpr (Value Double))- return ()------testPostgresqlSum :: Spec-testPostgresqlSum = do- it "works with sum_" $- run $ do- _ <- insert' p1- _ <- insert' p2- _ <- insert' p3- _ <- insert' p4- ret <- select $- from $ \p->- return $ joinV $ sum_ (p ^. PersonAge)- liftIO $ ret `shouldBe` [ Value $ Just (36 + 17 + 17 :: Rational ) ]------testPostgresqlTwoAscFields :: Spec-testPostgresqlTwoAscFields = do- it "works with two ASC fields (one call)" $- run $ 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- liftIO $ ret `shouldBe` [ p4e, p3e, p1e , p2e ]------testPostgresqlOneAscOneDesc :: Spec-testPostgresqlOneAscOneDesc = do- it "works with one ASC and one DESC field (two calls)" $- run $ 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- liftIO $ ret `shouldBe` [ p2e, p1e, p4e, p3e ]------testSelectDistinctOn :: Spec-testSelectDistinctOn = do- describe "SELECT DISTINCT ON" $ do- it "works on a simple example" $ do- run $ 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 =- run $ 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]-- it "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-- it "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-- it "works on a slightly less simple example (distinctOnOrderBy)" $ do- slightlyLessSimpleTest $ \bp ->- distinctOnOrderBy [asc (bp ^. BlogPostAuthorId), asc (bp ^. BlogPostTitle)]------testArrayAggWith :: Spec-testArrayAggWith = do- describe "ALL, no ORDER BY" $ do- it "creates sane SQL" $ run $ 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` []-- it "works on an example" $ run $ 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- it "creates sane SQL" $ run $ 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` []-- it "works on an example" $ run $ 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- it "creates sane SQL" $ run $ 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` []-- it "works on an example" $ run $ 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- it "creates sane SQL" $ run $ 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` []-- it "works on an example" $ run $ 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 :: Spec-testStringAggWith = do- describe "ALL, no ORDER BY" $ do- it "creates sane SQL" $ run $ 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 " "]-- it "works on an example" $ run $ 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)-- it "works with zero rows" $ run $ do- [Value ret] <-- select $ from $ \p ->- return (EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ")[])- liftIO $ ret `shouldBe` Nothing-- describe "DISTINCT, no ORDER BY" $ do- it "creates sane SQL" $ run $ 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 " "]-- it "works on an example" $ run $ 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- it "creates sane SQL" $ run $ 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 " "]-- it "works on an example" $ run $ 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- it "creates sane SQL" $ run $ 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 " "]-- it "works on an example" $ run $ 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 :: Spec-testAggregateFunctions = do- describe "arrayAgg" $ do- it "looks sane" $ run $ 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)-- it "works on zero rows" $ run $ do- [Value ret] <-- select $ from $ \p -> return (EP.arrayAgg (p ^. PersonName))- liftIO $ ret `shouldBe` Nothing- describe "arrayAggWith" testArrayAggWith- describe "stringAgg" $ do- it "looks sane" $- run $ 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)- it "works on zero rows" $ run $ do- [Value ret] <-- select $ from $ \p -> return (EP.stringAgg (p ^. PersonName) (val " "))- liftIO $ ret `shouldBe` Nothing- describe "stringAggWith" testStringAggWith-- describe "array_remove (NULL)" $ do- it "removes NULL from arrays from nullable fields" $ run $ 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- it "Coalesces NULL into an empty array" $ run $ do- [Value ret] <-- select $ from $ \p ->- return (EP.maybeArray $ EP.arrayAgg (p ^. PersonName))- liftIO $ ret `shouldBe` []------testPostgresModule :: Spec-testPostgresModule = do- describe "date_trunc" $ modifyMaxSuccess (`div` 10) $ do- prop "works" $ \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)- )- )-- liftIO $ 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- it "chr looks sane" $- run $ do- [Value (ret :: String)] <- select $ return (EP.chr (val 65))- liftIO $ ret `shouldBe` "A"-- it "allows unit for functions" $ do- vals <- run $ do- let- fn :: SqlExpr (Value UTCTime)- fn = ES.unsafeSqlFunction "now" ()- select $ pure fn- vals `shouldSatisfy` ((1 ==) . length)-- it "works with now" $- run $ 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 :: Spec-testJSONInsertions =- describe "JSON Insertions" $ do- it "adds scalar values" $ do- run $ do- insertIt Null- insertIt $ Bool True- insertIt $ Number 1- insertIt $ String "test"- it "adds arrays" $ do- run $ do- insertIt $ toJSON ([] :: [A.Value])- insertIt $ toJSON [Number 1, Bool True, Null]- insertIt $ toJSON [String "test",object ["a" .= Number 3.14], Null, Bool True]- it "adds objects" $ do- run $ 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 :: Spec-testJSONOperators =- describe "JSON Operators" $ do- testArrowOperators- testFilterOperators- testConcatDeleteOperators--testArrowOperators :: Spec-testArrowOperators =- describe "Arrow Operators" $ do- testArrowJSONB- testArrowText- testHashArrowJSONB- testHashArrowText--testArrowJSONB :: Spec-testArrowJSONB =- describe "Single Arrow (JSONB)" $ do- it "creates sane SQL" $- createSaneSQL @JSONValue- (jsonbVal (object ["a" .= True]) ->. "a")- "SELECT (? -> ?)\nFROM \"Json\"\n"- [ PersistLiteralEscaped "{\"a\":true}"- , PersistText "a" ]- it "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 ]- it "works as expected" $ run $ 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")- liftIO $ length x `shouldBe` 1- liftIO $ length y `shouldBe` 1- liftIO $ length z `shouldBe` 1--testArrowText :: Spec-testArrowText =- describe "Single Arrow (Text)" $ do- it "creates sane SQL" $- createSaneSQL- (jsonbVal (object ["a" .= True]) ->>. "a")- "SELECT (? ->> ?)\nFROM \"Json\"\n"- [ PersistLiteralEscaped "{\"a\":true}"- , PersistText "a" ]- it "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 ]- it "works as expected" $ run $ 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 :: Spec-testHashArrowJSONB =- describe "Double Arrow (JSONB)" $ do- it "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 ]- it "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"] ]- it "works as expected" $ run $ 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 :: Spec-testHashArrowText =- describe "Double Arrow (Text)" $ do- it "creates sane SQL" $ do- let list = ["a","b","c"]- createSaneSQL- (jsonbVal (object ["a" .= True]) #>>. list)- "SELECT (? #>> ?)\nFROM \"Json\"\n"- [ PersistLiteralEscaped "{\"a\":true}"- , persistTextArray list ]- it "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"] ]- it "works as expected" $ run $ 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 :: Spec-testFilterOperators =- describe "Filter Operators" $ do- testInclusion- testQMark- testQMarkAny- testQMarkAll--testInclusion :: Spec-testInclusion = do- describe "@>" $ do- it "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}"- ]- it "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}"- ]- it "works as expected" $ run $ 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- it "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- ]- it "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- ]- it "works as expected" $ run $ 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 :: Spec-testQMark = do- describe "Question Mark" $ do- it "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"- ]- it "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"- ]- it "works as expected" $ run $ 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 :: Spec-testQMarkAny = do- describe "Question Mark (Any)" $ do- it "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"]- ]- it "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"]- ]- it "works as expected" $ run $ 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 :: Spec-testQMarkAll = do- describe "Question Mark (All)" $ do- it "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"]- ]- it "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"]- ]- it "works as expected" $ run $ 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 :: Spec-testConcatDeleteOperators = do- describe "Concatenation Operator" testConcatenationOperator- describe "Deletion Operators" $ do- testMinusOperator- testMinusOperatorV10- testHashMinusOperator--testConcatenationOperator :: Spec-testConcatenationOperator = do- describe "Concatenation" $ do- it "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- ]- it "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]"- ]- it "works as expected" $ run $ 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 :: Spec-testMinusOperator =- describe "Minus Operator" $ do- it "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"- ]- it "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- ]- it "works as expected" $ run $ 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 :: Spec-testMinusOperatorV10 = do- describe "Minus Operator (PSQL >= v10)" $ do- it "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"]- ]- it "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"]- ]- it "works as expected" $ run $ 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 :: Spec-testHashMinusOperator =- describe "Hash-Minus Operator" $ do- it "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"] ]- it "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"] ]- it "works as expected" $ run $ 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 :: Spec-testInsertUniqueViolation =- describe "Unique Violation on Insert" $- it "Unique throws exception" $ run (do- _ <- insert u1- _ <- insert u2- insert u3) `shouldThrow` (==) exception- where- exception = SqlError {- sqlState = "23505",- sqlExecStatus = FatalError,- sqlErrorMsg = "duplicate key value violates unique constraint \"UniqueValue\"",- sqlErrorDetail = "Key (value)=(0) already exists.",- sqlErrorHint = ""}--testUpsert :: Spec-testUpsert =- describe "Upsert test" $ do- it "Upsert can insert like normal" $ run $ do- u1e <- EP.upsert u1 [OneUniqueName =. val "fifth"]- liftIO $ entityVal u1e `shouldBe` u1- it "Upsert performs update on collision" $ run $ 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 :: Spec-testInsertSelectWithConflict =- describe "insertSelectWithConflict test" $ do- it "Should do Nothing when no updates set" $ run $ 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- it "Should update a value if given an update on conflict" $ run $ 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 :: Spec-testFilterWhere =- describe "filterWhere" $ do- it "adds a filter clause to count aggregation" $ run $ 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)]- )-- it "adds a filter clause to sum aggregation" $ run $ 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 :: Spec-testCommonTableExpressions = do- describe "You can run them" $ do- it "will run" $ do- 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-- True `shouldBe` True-- it "can do multiple recursive queries" $ do- vals <- run $ 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- )-- select $ do- cte <- oneToTen- cte2 <- oneToTen- res1 <- Experimental.from cte- res2 <- Experimental.from cte2- pure (res1, res2)- vals `shouldBe` (((,) <$> fmap Value [1..10] <*> fmap Value [1..10]))-- it "passing previous query works" $- 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- in do- vals <- run $ do-- select $ do- cte <- oneToTen- cte2 <- oneMore cte- res <- Experimental.from cte2- pure res- vals `shouldBe` fmap Value [2..11]---- Since lateral queries arent supported in Sqlite or older versions of mysql--- the test is in the Postgres module-testLateralQuery :: Spec-testLateralQuery = do- describe "Lateral queries" $ do- it "supports CROSS JOIN LATERAL" $ do- _ <- run $ 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)- True `shouldBe` True-- it "supports INNER JOIN LATERAL" $ do- run $ 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)]- pure ()- True `shouldBe` True-- it "supports LEFT JOIN LATERAL" $ do- run $ 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))]- pure ()- True `shouldBe` True-- {--- it "compile error on RIGHT JOIN LATERAL" $ do- run $ do- res <- select $ do- l :& c <- Experimental.from $ table @Lord- `RightOuterJoin` (\lord -> do- deed <- Experimental.from $ table @Deed- where_ $ lord ?. LordId ==. just (deed ^. DeedOwnerId)- pure $ countRows @Int)- `Experimental.on` (const $ val True)- pure (l, c)-- let _ = res :: [(Maybe (Entity Lord), Value Int)]- pure ()- it "compile error on FULL OUTER JOIN LATERAL" $ do- run $ do- res <- select $ do- l :& c <- Experimental.from $ table @Lord- `FullOuterJoin` (\lord -> do- deed <- Experimental.from $ table @Deed- where_ $ lord ?. LordId ==. just (deed ^. DeedOwnerId)- pure $ countRows @Int)- `Experimental.on` (const $ val True)- pure (l, c)-- let _ = res :: [(Maybe (Entity Lord), Value (Maybe Int))]- pure ()- --}--type JSONValue = Maybe (JSONB A.Value)--createSaneSQL :: (PersistField a) => SqlExpr (Value a) -> T.Text -> [PersistValue] -> IO ()-createSaneSQL act q vals = run $ do- (query, args) <- showQuery ES.SELECT $ fromValue act- liftIO $ query `shouldBe` q- liftIO $ 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, MonadCatch m, MonadIO m, Show a) => ByteString -> SqlPersistT (R.ResourceT m) a -> SqlPersistT (R.ResourceT 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 -------------------main :: IO ()-main = do- hspec $ do- tests run-- describe "Test PostgreSQL locking" $ do- testLocking withConn-- describe "PostgreSQL specific tests" $ do- testAscRandom random_ run- testRandomMath run- testSelectDistinctOn- testPostgresModule- testPostgresqlOneAscOneDesc- testPostgresqlTwoAscFields- testPostgresqlSum- testPostgresqlRandom- testPostgresqlUpdate- testPostgresqlCoalesce- testPostgresqlTextFunctions- testInsertUniqueViolation- testUpsert- testInsertSelectWithConflict- testFilterWhere- testCommonTableExpressions- describe "PostgreSQL JSON tests" $ do- -- NOTE: We only clean the table once, so we- -- can use its contents across all JSON tests- it "MIGRATE AND CLEAN JSON TABLE" $ run $ do- void $ runMigrationSilent migrateJSON- cleanJSON- testJSONInsertions- testJSONOperators- testLateralQuery--run, runSilent, runVerbose :: Run-runSilent act = runNoLoggingT $ run_worker act-runVerbose act = runStderrLoggingT $ run_worker act-run f = do- verbose' <- lookupEnv "VERBOSE" >>= \case- Nothing -> return verbose- Just x | map Char.toLower x == "true" -> return True- | null x -> return True- | otherwise -> return False- if verbose'- then runVerbose f- else runSilent f--verbose :: Bool-verbose = False--run_worker :: RunDbMonad m => SqlPersistT (R.ResourceT m) a -> m a-run_worker act = withConn $ runSqlConn (migrateIt >> act)--migrateIt :: RunDbMonad m => SqlPersistT (R.ResourceT m) ()-migrateIt = do- void $ runMigrationSilent migrateAll- void $ runMigrationSilent migrateUnique- cleanDB- cleanUniques--withConn :: RunDbMonad m => (SqlBackend -> R.ResourceT m a) -> m a-withConn f = do- ea <- try go- case ea of- Left (SomeException se) -> do- ea' <- try go- case ea' of- Left (SomeException se1) ->- if show se == show se1- then throwM se- else throwM se1- Right a ->- pure a- Right a ->- pure a- where- go =- R.runResourceT $- withPostgresqlConn- "host=localhost port=5432 user=esqutest password=esqutest dbname=esqutest"- f++module PostgreSQL.Test where++import Control.Arrow ((&&&))+import Control.Monad (void, when)+import Control.Monad.IO.Class (MonadIO(liftIO))+import Control.Monad.Logger (runNoLoggingT, runStderrLoggingT)+import Control.Monad.Trans.Reader (ReaderT, ask, mapReaderT)+import qualified Control.Monad.Trans.Resource as R+import Data.Aeson hiding (Value)+import qualified Data.Aeson as A (Value)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Char as Char+import Data.Coerce+import Data.Foldable+import qualified Data.List as L+import Data.Map (Map)+import qualified Data.Map.Strict as Map+import Data.Ord (comparing)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Data.Time+import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime)+import Database.Esqueleto hiding (random_)+import Database.Esqueleto.Experimental hiding (from, on, random_)+import qualified Database.Esqueleto.Experimental as Experimental+import qualified Database.Esqueleto.Internal.Internal as ES+import Database.Esqueleto.PostgreSQL (random_)+import qualified Database.Esqueleto.PostgreSQL as EP+import Database.Esqueleto.PostgreSQL.JSON hiding ((-.), (?.), (||.))+import qualified Database.Esqueleto.PostgreSQL.JSON as JSON+import Database.Persist.Postgresql (withPostgresqlConn, createPostgresqlPool)+import Database.PostgreSQL.Simple (ExecStatus(..), SqlError(..))+import System.Environment+import Test.Hspec+import Test.Hspec.QuickCheck++import Common.Test+import Common.Test.Import hiding (from, on)+import PostgreSQL.MigrateJSON++returningType :: forall a m . m a -> m a+returningType a = a++testPostgresqlCoalesce :: SpecDb+testPostgresqlCoalesce = do+ itDb "works on PostgreSQL and MySQL with <2 arguments" $ do+ void $ returningType @[Value (Maybe Int)] $+ select $+ from $ \p -> do+ return (coalesce [p ^. PersonAge])+ asserting noExceptions++testPostgresqlTextFunctions :: SpecDb+testPostgresqlTextFunctions = do+ describe "text functions" $ do+ itDb "like, (%) and (++.) work on a simple example" $ do+ let nameContains t =+ select $+ from $ \p -> do+ where_+ (like+ (p ^. PersonName)+ ((%) ++. val t ++. (%)))+ orderBy [asc (p ^. PersonName)]+ return p+ [p1e, p2e, p3e, p4e] <- mapM insert' [p1, p2, p3, p4]+ h <- nameContains "h"+ i <- nameContains "i"+ iv <- nameContains "iv"+ asserting $ do+ h `shouldBe` [p1e, p2e]+ i `shouldBe` [p4e, p3e]+ iv `shouldBe` [p4e]++ itDb "ilike, (%) and (++.) work on a simple example on PostgreSQL" $ do+ [p1e, _, p3e, _, p5e] <- mapM insert' [p1, p2, p3, p4, p5]+ let nameContains t = do+ select $+ from $ \p -> do+ where_ (p ^. PersonName `ilike` (%) ++. val t ++. (%))+ orderBy [asc (p ^. PersonName)]+ return p+ mi <- nameContains "mi"+ john <- nameContains "JOHN"+ asserting $ do+ mi `shouldBe` [p3e, p5e]+ john `shouldBe` [p1e]++testPostgresqlUpdate :: SpecDb+testPostgresqlUpdate = do+ itDb "works on a simple example" $ do+ p1k <- insert p1+ p2k <- insert p2+ p3k <- insert p3+ let anon = "Anonymous"+ () <- update $ \p -> do+ set p [ PersonName =. val anon+ , PersonAge *=. just (val 2) ]+ where_ (p ^. PersonName !=. val "Mike")+ n <- updateCount $ \p -> do+ set p [ PersonAge +=. just (val 1) ]+ where_ (p ^. PersonName !=. val "Mike")+ ret <- select $+ from $ \p -> do+ orderBy [ asc (p ^. PersonName), asc (p ^. PersonAge) ]+ return p+ -- PostgreSQL: nulls are bigger than data, and update returns+ -- matched rows, not actually changed rows.+ asserting $ do+ n `shouldBe` 2+ ret `shouldBe`+ [ Entity p1k (Person anon (Just 73) Nothing 1)+ , Entity p2k (Person anon Nothing (Just 37) 2)+ , Entity p3k p3+ ]++testPostgresqlRandom :: SpecDb+testPostgresqlRandom = do+ itDb "works with random_" $ do+ _ <- select $ return (random_ :: SqlExpr (Value Double))+ asserting noExceptions++testPostgresqlSum :: SpecDb+testPostgresqlSum = do+ itDb "works with sum_" $ do+ _ <- insert' p1+ _ <- insert' p2+ _ <- insert' p3+ _ <- insert' p4+ ret <- select $+ from $ \p->+ return $ joinV $ sum_ (p ^. PersonAge)+ asserting $ ret `shouldBe` [ Value $ Just (36 + 17 + 17 :: Rational ) ]++testPostgresqlTwoAscFields :: SpecDb+testPostgresqlTwoAscFields = do+ itDb "works with two ASC fields (one call)" $ do+ p1e <- insert' p1+ p2e <- insert' p2+ p3e <- insert' p3+ p4e <- insert' p4+ ret <- select $+ from $ \p -> do+ orderBy [asc (p ^. PersonAge), asc (p ^. PersonName)]+ return p+ -- in PostgreSQL nulls are bigger than everything+ asserting $ ret `shouldBe` [ p4e, p3e, p1e , p2e ]++testPostgresqlOneAscOneDesc :: SpecDb+testPostgresqlOneAscOneDesc = do+ itDb "works with one ASC and one DESC field (two calls)" $+ do+ p1e <- insert' p1+ p2e <- insert' p2+ p3e <- insert' p3+ p4e <- insert' p4+ ret <- select $+ from $ \p -> do+ orderBy [desc (p ^. PersonAge)]+ orderBy [asc (p ^. PersonName)]+ return p+ asserting $ ret `shouldBe` [ p2e, p1e, p4e, p3e ]++testSelectDistinctOn :: SpecDb+testSelectDistinctOn = do+ describe "SELECT DISTINCT ON" $ do+ itDb "works on a simple example" $ do+ do+ [p1k, p2k, _] <- mapM insert [p1, p2, p3]+ [_, bpB, bpC] <- mapM insert'+ [ BlogPost "A" p1k+ , BlogPost "B" p1k+ , BlogPost "C" p2k ]+ ret <- select $+ from $ \bp ->+ distinctOn [don (bp ^. BlogPostAuthorId)] $ do+ orderBy [asc (bp ^. BlogPostAuthorId), desc (bp ^. BlogPostTitle)]+ return bp+ liftIO $ ret `shouldBe` L.sortBy (comparing (blogPostAuthorId . entityVal)) [bpB, bpC]++ let slightlyLessSimpleTest q =+ do+ [p1k, p2k, _] <- mapM insert [p1, p2, p3]+ [bpA, bpB, bpC] <- mapM insert'+ [ BlogPost "A" p1k+ , BlogPost "B" p1k+ , BlogPost "C" p2k ]+ ret <- select $+ from $ \bp ->+ q bp $ return bp+ let cmp = (blogPostAuthorId &&& blogPostTitle) . entityVal+ liftIO $ ret `shouldBe` L.sortBy (comparing cmp) [bpA, bpB, bpC]++ itDb "works on a slightly less simple example (two distinctOn calls, orderBy)" $+ slightlyLessSimpleTest $ \bp act ->+ distinctOn [don (bp ^. BlogPostAuthorId)] $+ distinctOn [don (bp ^. BlogPostTitle)] $ do+ orderBy [asc (bp ^. BlogPostAuthorId), asc (bp ^. BlogPostTitle)]+ act++ itDb "works on a slightly less simple example (one distinctOn call, orderBy)" $ do+ slightlyLessSimpleTest $ \bp act ->+ distinctOn [don (bp ^. BlogPostAuthorId), don (bp ^. BlogPostTitle)] $ do+ orderBy [asc (bp ^. BlogPostAuthorId), asc (bp ^. BlogPostTitle)]+ act++ itDb "works on a slightly less simple example (distinctOnOrderBy)" $ do+ slightlyLessSimpleTest $ \bp ->+ distinctOnOrderBy [asc (bp ^. BlogPostAuthorId), asc (bp ^. BlogPostTitle)]++++++testArrayAggWith :: SpecDb+testArrayAggWith = do+ describe "ALL, no ORDER BY" $ do+ itDb "creates sane SQL" $ do+ (query, args) <- showQuery ES.SELECT $ from $ \p ->+ return (EP.arrayAggWith EP.AggModeAll (p ^. PersonAge) [])+ liftIO $ query `shouldBe`+ "SELECT array_agg(\"Person\".\"age\")\n\+ \FROM \"Person\"\n"+ liftIO $ args `shouldBe` []++ itDb "works on an example" $ do+ let people = [p1, p2, p3, p4, p5]+ mapM_ insert people+ [Value (Just ret)] <-+ select $ from $ \p ->+ return (EP.arrayAggWith EP.AggModeAll (p ^. PersonName) [])+ liftIO $ L.sort ret `shouldBe` L.sort (map personName people)++ describe "DISTINCT, no ORDER BY" $ do+ itDb "creates sane SQL" $ do+ (query, args) <- showQuery ES.SELECT $ from $ \p ->+ return (EP.arrayAggWith EP.AggModeDistinct (p ^. PersonAge) [])+ liftIO $ query `shouldBe`+ "SELECT array_agg(DISTINCT \"Person\".\"age\")\n\+ \FROM \"Person\"\n"+ liftIO $ args `shouldBe` []++ itDb "works on an example" $ do+ let people = [p1, p2, p3, p4, p5]+ mapM_ insert people+ [Value (Just ret)] <-+ select $ from $ \p ->+ return (EP.arrayAggWith EP.AggModeDistinct (p ^. PersonAge) [])+ liftIO $ L.sort ret `shouldBe` [Nothing, Just 17, Just 36]++ describe "ALL, ORDER BY" $ do+ itDb "creates sane SQL" $ do+ (query, args) <- showQuery ES.SELECT $ from $ \p ->+ return (EP.arrayAggWith EP.AggModeAll (p ^. PersonAge)+ [ asc $ p ^. PersonName+ , desc $ p ^. PersonFavNum+ ])+ liftIO $ query `shouldBe`+ "SELECT array_agg(\"Person\".\"age\" \+ \ORDER BY \"Person\".\"name\" ASC, \"Person\".\"favNum\" DESC)\n\+ \FROM \"Person\"\n"+ liftIO $ args `shouldBe` []++ itDb "works on an example" $ do+ let people = [p1, p2, p3, p4, p5]+ mapM_ insert people+ [Value (Just ret)] <-+ select $ from $ \p ->+ return (EP.arrayAggWith EP.AggModeAll (p ^. PersonName) [])+ liftIO $ L.sort ret `shouldBe` L.sort (map personName people)++ describe "DISTINCT, ORDER BY" $ do+ itDb "creates sane SQL" $ do+ (query, args) <- showQuery ES.SELECT $ from $ \p ->+ return (EP.arrayAggWith EP.AggModeDistinct (p ^. PersonAge)+ [asc $ p ^. PersonAge])+ liftIO $ query `shouldBe`+ "SELECT array_agg(DISTINCT \"Person\".\"age\" \+ \ORDER BY \"Person\".\"age\" ASC)\n\+ \FROM \"Person\"\n"+ liftIO $ args `shouldBe` []++ itDb "works on an example" $ do+ let people = [p1, p2, p3, p4, p5]+ mapM_ insert people+ [Value (Just ret)] <-+ select $ from $ \p ->+ return (EP.arrayAggWith EP.AggModeDistinct (p ^. PersonAge)+ [asc $ p ^. PersonAge])+ liftIO $ ret `shouldBe` [Just 17, Just 36, Nothing]++++++testStringAggWith :: SpecDb+testStringAggWith = do+ describe "ALL, no ORDER BY" $ do+ itDb "creates sane SQL" $ do+ (query, args) <- showQuery ES.SELECT $ from $ \p ->+ return (EP.stringAggWith EP.AggModeAll (p ^. PersonName)+ (val " ") [])+ liftIO $ query `shouldBe`+ "SELECT string_agg(\"Person\".\"name\", ?)\n\+ \FROM \"Person\"\n"+ liftIO $ args `shouldBe` [PersistText " "]++ itDb "works on an example" $ do+ let people = [p1, p2, p3, p4, p5]+ mapM_ insert people+ [Value (Just ret)] <-+ select $ from $ \p ->+ return (EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ")[])+ liftIO $ (L.sort $ words ret) `shouldBe` L.sort (map personName people)++ itDb "works with zero rows" $ do+ [Value ret] <-+ select $ from $ \p ->+ return (EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ")[])+ liftIO $ ret `shouldBe` Nothing++ describe "DISTINCT, no ORDER BY" $ do+ itDb "creates sane SQL" $ do+ (query, args) <- showQuery ES.SELECT $ from $ \p ->+ return $ EP.stringAggWith EP.AggModeDistinct (p ^. PersonName)+ (val " ") []+ liftIO $ query `shouldBe`+ "SELECT string_agg(DISTINCT \"Person\".\"name\", ?)\n\+ \FROM \"Person\"\n"+ liftIO $ args `shouldBe` [PersistText " "]++ itDb "works on an example" $ do+ let people = [p1, p2, p3 {personName = "John"}, p4, p5]+ mapM_ insert people+ [Value (Just ret)] <-+ select $ from $ \p ->+ return $ EP.stringAggWith EP.AggModeDistinct (p ^. PersonName) (val " ")+ []+ liftIO $ (L.sort $ words ret) `shouldBe`+ (L.sort . L.nub $ map personName people)++ describe "ALL, ORDER BY" $ do+ itDb "creates sane SQL" $ do+ (query, args) <- showQuery ES.SELECT $ from $ \p ->+ return (EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ")+ [ asc $ p ^. PersonName+ , desc $ p ^. PersonFavNum+ ])+ liftIO $ query `shouldBe`+ "SELECT string_agg(\"Person\".\"name\", ? \+ \ORDER BY \"Person\".\"name\" ASC, \"Person\".\"favNum\" DESC)\n\+ \FROM \"Person\"\n"+ liftIO $ args `shouldBe` [PersistText " "]++ itDb "works on an example" $ do+ let people = [p1, p2, p3, p4, p5]+ mapM_ insert people+ [Value (Just ret)] <-+ select $ from $ \p ->+ return $ EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ")+ [desc $ p ^. PersonName]+ liftIO $ (words ret)+ `shouldBe` (L.reverse . L.sort $ map personName people)++ describe "DISTINCT, ORDER BY" $ do+ itDb "creates sane SQL" $ do+ (query, args) <- showQuery ES.SELECT $ from $ \p ->+ return $ EP.stringAggWith EP.AggModeDistinct (p ^. PersonName)+ (val " ") [desc $ p ^. PersonName]+ liftIO $ query `shouldBe`+ "SELECT string_agg(DISTINCT \"Person\".\"name\", ? \+ \ORDER BY \"Person\".\"name\" DESC)\n\+ \FROM \"Person\"\n"+ liftIO $ args `shouldBe` [PersistText " "]++ itDb "works on an example" $ do+ let people = [p1, p2, p3 {personName = "John"}, p4, p5]+ mapM_ insert people+ [Value (Just ret)] <-+ select $ from $ \p ->+ return $ EP.stringAggWith EP.AggModeDistinct (p ^. PersonName) (val " ")+ [desc $ p ^. PersonName]+ liftIO $ (words ret) `shouldBe`+ (L.reverse . L.sort . L.nub $ map personName people)++++++testAggregateFunctions :: SpecDb+testAggregateFunctions = do+ describe "arrayAgg" $ do+ itDb "looks sane" $ do+ let people = [p1, p2, p3, p4, p5]+ mapM_ insert people+ [Value (Just ret)] <-+ select $ from $ \p -> return (EP.arrayAgg (p ^. PersonName))+ liftIO $ L.sort ret `shouldBe` L.sort (map personName people)++ itDb "works on zero rows" $ do+ [Value ret] <-+ select $ from $ \p -> return (EP.arrayAgg (p ^. PersonName))+ liftIO $ ret `shouldBe` Nothing+ describe "arrayAggWith" testArrayAggWith+ describe "stringAgg" $ do+ itDb "looks sane" $+ do+ let people = [p1, p2, p3, p4, p5]+ mapM_ insert people+ [Value (Just ret)] <-+ select $+ from $ \p -> do+ return (EP.stringAgg (p ^. PersonName) (val " "))+ liftIO $ L.sort (words ret) `shouldBe` L.sort (map personName people)+ itDb "works on zero rows" $ do+ [Value ret] <-+ select $ from $ \p -> return (EP.stringAgg (p ^. PersonName) (val " "))+ liftIO $ ret `shouldBe` Nothing+ describe "stringAggWith" testStringAggWith++ describe "array_remove (NULL)" $ do+ itDb "removes NULL from arrays from nullable fields" $ do+ mapM_ insert [ Person "1" Nothing Nothing 1+ , Person "2" (Just 7) Nothing 1+ , Person "3" (Nothing) Nothing 1+ , Person "4" (Just 8) Nothing 2+ , Person "5" (Just 9) Nothing 2+ ]+ ret <- select $ from $ \(person :: SqlExpr (Entity Person)) -> do+ groupBy (person ^. PersonFavNum)+ return . EP.arrayRemoveNull . EP.maybeArray . EP.arrayAgg+ $ person ^. PersonAge+ liftIO $ (L.sort $ map (L.sort . unValue) ret)+ `shouldBe` [[7], [8,9]]++ describe "maybeArray" $ do+ itDb "Coalesces NULL into an empty array" $ do+ [Value ret] <-+ select $ from $ \p ->+ return (EP.maybeArray $ EP.arrayAgg (p ^. PersonName))+ liftIO $ ret `shouldBe` []++testPostgresModule :: SpecDb+testPostgresModule = do+ describe "date_trunc" $ modifyMaxSuccess (`div` 10) $ do+ propDb "works" $ \run listOfDateParts -> run $ do+ let+ utcTimes =+ map+ (\(y, m, d, s) ->+ fromInteger s+ `addUTCTime`+ UTCTime (fromGregorian (2000 + y) m d) 0+ )+ listOfDateParts+ truncateDate+ :: SqlExpr (Value String) -- ^ .e.g (val "day")+ -> SqlExpr (Value UTCTime) -- ^ input field+ -> SqlExpr (Value UTCTime) -- ^ truncated date+ truncateDate datePart expr =+ ES.unsafeSqlFunction "date_trunc" (datePart, expr)+ vals =+ zip (map (DateTruncTestKey . fromInteger) [1..]) utcTimes+ for_ vals $ \(idx, utcTime) -> do+ insertKey idx (DateTruncTest utcTime)++ -- Necessary to get the test to pass; see the discussion in+ -- https://github.com/bitemyapp/esqueleto/pull/180+ rawExecute "SET TIME ZONE 'UTC'" []+ ret <-+ fmap (Map.fromList . coerce :: _ -> Map DateTruncTestId (UTCTime, UTCTime)) $+ select $+ from $ \dt -> do+ pure+ ( dt ^. DateTruncTestId+ , ( dt ^. DateTruncTestCreated+ , truncateDate (val "day") (dt ^. DateTruncTestCreated)+ )+ )++ asserting $ for_ vals $ \(idx, utcTime) -> do+ case Map.lookup idx ret of+ Nothing ->+ expectationFailure "index not found"+ Just (original, truncated) -> do+ utcTime `shouldBe` original+ if utctDay utcTime == utctDay truncated+ then+ utctDay utcTime `shouldBe` utctDay truncated+ else+ -- use this if/else to get a better error message+ utcTime `shouldBe` truncated++ describe "PostgreSQL module" $ do+ describe "Aggregate functions" testAggregateFunctions+ itDb "chr looks sane" $ do+ [Value (ret :: String)] <- select $ return (EP.chr (val 65))+ liftIO $ ret `shouldBe` "A"++ itDb "allows unit for functions" $ do+ let+ fn :: SqlExpr (Value UTCTime)+ fn = ES.unsafeSqlFunction "now" ()+ vals <- select $ pure fn+ liftIO $ vals `shouldSatisfy` ((1 ==) . length)++ itDb "works with now" $+ do+ nowDb <- select $ return EP.now_+ nowUtc <- liftIO getCurrentTime+ let oneSecond = realToFrac (1 :: Double)++ -- | Check the result is not null+ liftIO $ nowDb `shouldSatisfy` (not . null)++ -- | Unpack the now value+ let (Value now: _) = nowDb++ -- | Get the time diff and check it's less than a second+ liftIO $ diffUTCTime nowUtc now `shouldSatisfy` (< oneSecond)++testJSONInsertions :: SpecDb+testJSONInsertions =+ describe "JSON Insertions" $ do+ itDb "adds scalar values" $ do+ insertIt Null+ insertIt $ Bool True+ insertIt $ Number 1+ insertIt $ String "test"+ itDb "adds arrays" $ do+ insertIt $ toJSON ([] :: [A.Value])+ insertIt $ toJSON [Number 1, Bool True, Null]+ insertIt $ toJSON [String "test",object ["a" .= Number 3.14], Null, Bool True]+ itDb "adds objects" $ do+ insertIt $ object ["a" .= (1 :: Int), "b" .= False]+ insertIt $ object ["a" .= object ["b" .= object ["c" .= String "message"]]]+ where+ insertIt :: MonadIO m => A.Value -> SqlPersistT m ()+ insertIt = insert_ . Json . JSONB++testJSONOperators :: SpecDb+testJSONOperators =+ describe "JSON Operators" $ do+ testArrowOperators+ testFilterOperators+ testConcatDeleteOperators++testArrowOperators :: SpecDb+testArrowOperators =+ describe "Arrow Operators" $ do+ testArrowJSONB+ testArrowText+ testHashArrowJSONB+ testHashArrowText++testArrowJSONB :: SpecDb+testArrowJSONB =+ describe "Single Arrow (JSONB)" $ do+ itDb "creates sane SQL" $+ createSaneSQL @JSONValue+ (jsonbVal (object ["a" .= True]) ->. "a")+ "SELECT (? -> ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped "{\"a\":true}"+ , PersistText "a"+ ]+ itDb "creates sane SQL (chained)" $ do+ let obj = object ["a" .= [1 :: Int,2,3]]+ createSaneSQL @JSONValue+ (jsonbVal obj ->. "a" ->. 1)+ "SELECT ((? -> ?) -> ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped "{\"a\":[1,2,3]}"+ , PersistText "a"+ , PersistInt64 1 ]+ itDb "works as expected" $ do+ x <- selectJSONwhere $ \v -> v ->. "b" ==. jsonbVal (Bool False)+ y <- selectJSONwhere $ \v -> v ->. 1 ==. jsonbVal (Bool True)+ z <- selectJSONwhere $ \v -> v ->. "a" ->. "b" ->. "c" ==. jsonbVal (String "message")+ asserting $ do+ length x `shouldBe` 1+ length y `shouldBe` 1+ length z `shouldBe` 1++testArrowText :: SpecDb+testArrowText =+ describe "Single Arrow (Text)" $ do+ itDb "creates sane SQL" $+ createSaneSQL+ (jsonbVal (object ["a" .= True]) ->>. "a")+ "SELECT (? ->> ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped "{\"a\":true}"+ , PersistText "a" ]+ itDb "creates sane SQL (chained)" $ do+ let obj = object ["a" .= [1 :: Int,2,3]]+ createSaneSQL+ (jsonbVal obj ->. "a" ->>. 1)+ "SELECT ((? -> ?) ->> ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped "{\"a\":[1,2,3]}"+ , PersistText "a"+ , PersistInt64 1 ]+ itDb "works as expected" $ do+ x <- selectJSONwhere $ \v -> v ->>. "b" ==. just (val "false")+ y <- selectJSONwhere $ \v -> v ->>. 1 ==. just (val "true")+ z <- selectJSONwhere $ \v -> v ->. "a" ->. "b" ->>. "c" ==. just (val "message")+ liftIO $ length x `shouldBe` 1+ liftIO $ length y `shouldBe` 1+ liftIO $ length z `shouldBe` 1++testHashArrowJSONB :: SpecDb+testHashArrowJSONB =+ describe "Double Arrow (JSONB)" $ do+ itDb "creates sane SQL" $ do+ let list = ["a","b","c"]+ createSaneSQL @JSONValue+ (jsonbVal (object ["a" .= True]) #>. list)+ "SELECT (? #> ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped "{\"a\":true}"+ , persistTextArray list ]+ itDb "creates sane SQL (chained)" $ do+ let obj = object ["a" .= [object ["b" .= True]]]+ createSaneSQL @JSONValue+ (jsonbVal obj #>. ["a","1"] #>. ["b"])+ "SELECT ((? #> ?) #> ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped "{\"a\":[{\"b\":true}]}"+ , persistTextArray ["a","1"]+ , persistTextArray ["b"] ]+ itDb "works as expected" $ do+ x <- selectJSONwhere $ \v -> v #>. ["a","b","c"] ==. jsonbVal (String "message")+ y <- selectJSONwhere $ \v -> v #>. ["1","a"] ==. jsonbVal (Number 3.14)+ z <- selectJSONwhere $ \v -> v #>. ["1"] #>. ["a"] ==. jsonbVal (Number 3.14)+ liftIO $ length x `shouldBe` 1+ liftIO $ length y `shouldBe` 1+ liftIO $ length z `shouldBe` 1++testHashArrowText :: SpecDb+testHashArrowText =+ describe "Double Arrow (Text)" $ do+ itDb "creates sane SQL" $ do+ let list = ["a","b","c"]+ createSaneSQL+ (jsonbVal (object ["a" .= True]) #>>. list)+ "SELECT (? #>> ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped "{\"a\":true}"+ , persistTextArray list ]+ itDb "creates sane SQL (chained)" $ do+ let obj = object ["a" .= [object ["b" .= True]]]+ createSaneSQL+ (jsonbVal obj #>. ["a","1"] #>>. ["b"])+ "SELECT ((? #> ?) #>> ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped "{\"a\":[{\"b\":true}]}"+ , persistTextArray ["a","1"]+ , persistTextArray ["b"] ]+ itDb "works as expected" $ do+ x <- selectJSONwhere $ \v -> v #>>. ["a","b","c"] ==. just (val "message")+ y <- selectJSONwhere $ \v -> v #>>. ["1","a"] ==. just (val "3.14")+ z <- selectJSONwhere $ \v -> v #>. ["1"] #>>. ["a"] ==. just (val "3.14")+ liftIO $ length x `shouldBe` 1+ liftIO $ length y `shouldBe` 1+ liftIO $ length z `shouldBe` 1+++testFilterOperators :: SpecDb+testFilterOperators =+ describe "Filter Operators" $ do+ testInclusion+ testQMark+ testQMarkAny+ testQMarkAll++testInclusion :: SpecDb+testInclusion = do+ describe "@>" $ do+ itDb "creates sane SQL" $ do+ let obj = object ["a" .= False, "b" .= True]+ encoded = BSL.toStrict $ encode obj+ createSaneSQL+ (jsonbVal obj @>. jsonbVal (object ["a" .= False]))+ "SELECT (? @> ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped encoded+ , PersistLiteralEscaped "{\"a\":false}"+ ]+ itDb "creates sane SQL (chained)" $ do+ let obj = object ["a" .= [object ["b" .= True]]]+ encoded = BSL.toStrict $ encode obj+ createSaneSQL+ (jsonbVal obj ->. "a" @>. jsonbVal (object ["b" .= True]))+ "SELECT ((? -> ?) @> ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped encoded+ , PersistText "a"+ , PersistLiteralEscaped "{\"b\":true}"+ ]+ itDb "works as expected" $ do+ x <- selectJSONwhere $ \v -> v @>. jsonbVal (Number 1)+ y <- selectJSONwhere $ \v -> v @>. jsonbVal (toJSON [object ["a" .= Number 3.14]])+ z <- selectJSONwhere $ \v -> v ->. 1 @>. jsonbVal (object ["a" .= Number 3.14])+ liftIO $ length x `shouldBe` 2+ liftIO $ length y `shouldBe` 1+ liftIO $ length z `shouldBe` 1+ describe "<@" $ do+ itDb "creates sane SQL" $ do+ let obj = object ["a" .= False, "b" .= True]+ encoded = BSL.toStrict $ encode obj+ createSaneSQL+ (jsonbVal (object ["a" .= False]) <@. jsonbVal obj )+ "SELECT (? <@ ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped "{\"a\":false}"+ , PersistLiteralEscaped encoded+ ]+ itDb "creates sane SQL (chained)" $ do+ let obj = object ["a" .= [object ["b" .= True]]]+ obj' = object ["b" .= True, "c" .= Null]+ encoded = BSL.toStrict $ encode obj'+ createSaneSQL+ (jsonbVal obj ->. "a" <@. jsonbVal obj')+ "SELECT ((? -> ?) <@ ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped "{\"a\":[{\"b\":true}]}"+ , PersistText "a"+ , PersistLiteralEscaped encoded+ ]+ itDb "works as expected" $ do+ x <- selectJSONwhere $ \v -> v <@. jsonbVal (toJSON [Number 1])+ y <- selectJSONwhere $ \v -> v <@. jsonbVal (object ["a" .= (1 :: Int), "b" .= False, "c" .= Null])+ z <- selectJSONwhere $ \v -> v #>. ["a","b"] <@. jsonbVal (object ["b" .= False, "c" .= String "message"])+ liftIO $ length x `shouldBe` 2+ liftIO $ length y `shouldBe` 1+ liftIO $ length z `shouldBe` 1++testQMark :: SpecDb+testQMark = do+ describe "Question Mark" $ do+ itDb "creates sane SQL" $ do+ let obj = object ["a" .= False, "b" .= True]+ encoded = BSL.toStrict $ encode obj+ createSaneSQL+ (jsonbVal obj JSON.?. "a")+ "SELECT (? ?? ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped encoded+ , PersistText "a"+ ]+ itDb "creates sane SQL (chained)" $ do+ let obj = object ["a" .= [object ["b" .= True]]]+ encoded = BSL.toStrict $ encode obj+ createSaneSQL+ (jsonbVal obj #>. ["a","0"] JSON.?. "b")+ "SELECT ((? #> ?) ?? ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped encoded+ , persistTextArray ["a","0"]+ , PersistText "b"+ ]+ itDb "works as expected" $ do+ x <- selectJSONwhere (JSON.?. "a")+ y <- selectJSONwhere (JSON.?. "test")+ z <- selectJSONwhere $ \v -> v ->. "a" JSON.?. "b"+ liftIO $ length x `shouldBe` 2+ liftIO $ length y `shouldBe` 2+ liftIO $ length z `shouldBe` 1++testQMarkAny :: SpecDb+testQMarkAny = do+ describe "Question Mark (Any)" $ do+ itDb "creates sane SQL" $ do+ let obj = (object ["a" .= False, "b" .= True])+ encoded = BSL.toStrict $ encode obj+ createSaneSQL+ (jsonbVal obj ?|. ["a","c"])+ "SELECT (? ??| ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped encoded+ , persistTextArray ["a","c"]+ ]+ itDb "creates sane SQL (chained)" $ do+ let obj = object ["a" .= [object ["b" .= True]]]+ encoded = BSL.toStrict $ encode obj+ createSaneSQL+ (jsonbVal obj #>. ["a","0"] ?|. ["b","c"])+ "SELECT ((? #> ?) ??| ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped encoded+ , persistTextArray ["a","0"]+ , persistTextArray ["b","c"]+ ]+ itDb "works as expected" $ do+ x <- selectJSONwhere (?|. ["b","test"])+ y <- selectJSONwhere (?|. ["a"])+ z <- selectJSONwhere $ \v -> v ->. (-3) ?|. ["a"]+ w <- selectJSONwhere (?|. [])+ liftIO $ length x `shouldBe` 3+ liftIO $ length y `shouldBe` 2+ liftIO $ length z `shouldBe` 1+ liftIO $ length w `shouldBe` 0++testQMarkAll :: SpecDb+testQMarkAll = do+ describe "Question Mark (All)" $ do+ itDb "creates sane SQL" $ do+ let obj = object ["a" .= False, "b" .= True]+ encoded = BSL.toStrict $ encode obj+ createSaneSQL+ (jsonbVal obj ?&. ["a","c"])+ "SELECT (? ??& ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped encoded+ , persistTextArray ["a","c"]+ ]+ itDb "creates sane SQL (chained)" $ do+ let obj = object ["a" .= [object ["b" .= True]]]+ encoded = BSL.toStrict $ encode obj+ createSaneSQL+ (jsonbVal obj #>. ["a","0"] ?&. ["b","c"])+ "SELECT ((? #> ?) ??& ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped encoded+ , persistTextArray ["a","0"]+ , persistTextArray ["b","c"]+ ]+ itDb "works as expected" $ do+ x <- selectJSONwhere (?&. ["test"])+ y <- selectJSONwhere (?&. ["a","b"])+ z <- selectJSONwhere $ \v -> v ->. "a" ?&. ["b"]+ w <- selectJSONwhere (?&. [])+ liftIO $ length x `shouldBe` 2+ liftIO $ length y `shouldBe` 1+ liftIO $ length z `shouldBe` 1+ liftIO $ length w `shouldBe` 9++testConcatDeleteOperators :: SpecDb+testConcatDeleteOperators = do+ describe "Concatenation Operator" testConcatenationOperator+ describe "Deletion Operators" $ do+ testMinusOperator+ testMinusOperatorV10+ testHashMinusOperator++testConcatenationOperator :: SpecDb+testConcatenationOperator = do+ describe "Concatenation" $ do+ itDb "creates sane SQL" $ do+ let objAB = object ["a" .= False, "b" .= True]+ objC = object ["c" .= Null]+ createSaneSQL @JSONValue+ (jsonbVal objAB+ JSON.||. jsonbVal objC)+ "SELECT (? || ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped $ BSL.toStrict $ encode objAB+ , PersistLiteralEscaped $ BSL.toStrict $ encode objC+ ]+ itDb "creates sane SQL (chained)" $ do+ let obj = object ["a" .= [object ["b" .= True]]]+ encoded = BSL.toStrict $ encode obj+ createSaneSQL @JSONValue+ (jsonbVal obj ->. "a" JSON.||. jsonbVal (toJSON [Null]))+ "SELECT ((? -> ?) || ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped encoded+ , PersistText "a"+ , PersistLiteralEscaped "[null]"+ ]+ itDb "works as expected" $ do+ x <- selectJSON $ \v -> do+ where_ $ v @>. jsonbVal (object [])+ where_ $ v JSON.||. jsonbVal (object ["x" .= True])+ @>. jsonbVal (object ["x" .= True])+ y <- selectJSONwhere $ \v ->+ v JSON.||. jsonbVal (toJSON [String "a", String "b"])+ ->>. 4 ==. just (val "b")+ z <- selectJSONwhere $ \v ->+ v JSON.||. jsonbVal (toJSON [Bool False])+ ->. 0 JSON.@>. jsonbVal (Number 1)+ w <- selectJSON $ \v -> do+ where_ . not_ $ v @>. jsonbVal (object [])+ where_ $ jsonbVal (String "test1") JSON.||. v ->>. 0 ==. just (val "test1")+ liftIO $ length x `shouldBe` 2+ liftIO $ length y `shouldBe` 1+ liftIO $ length z `shouldBe` 2+ liftIO $ length w `shouldBe` 7++testMinusOperator :: SpecDb+testMinusOperator =+ describe "Minus Operator" $ do+ itDb "creates sane SQL" $ do+ let obj = object ["a" .= False, "b" .= True]+ encoded = BSL.toStrict $ encode obj+ createSaneSQL @JSONValue+ (jsonbVal obj JSON.-. "a")+ "SELECT (? - ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped encoded+ , PersistText "a"+ ]+ itDb "creates sane SQL (chained)" $ do+ let obj = object ["a" .= [object ["b" .= True]]]+ encoded = BSL.toStrict $ encode obj+ createSaneSQL @JSONValue+ (jsonbVal obj ->. "a" JSON.-. 0)+ "SELECT ((? -> ?) - ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped encoded+ , PersistText "a"+ , PersistInt64 0+ ]+ itDb "works as expected" $ do+ x <- selectJSON $ \v -> do+ where_ $ v @>. jsonbVal (toJSON ([] :: [Int]))+ where_ $ v JSON.-. 0 @>. jsonbVal (toJSON [Bool True])+ y <- selectJSON $ \v -> do+ where_ $ v @>. jsonbVal (toJSON ([] :: [Int]))+ where_ $ v JSON.-. (-1) @>. jsonbVal (toJSON [Null])+ z <- selectJSON_ $ \v -> v JSON.-. "b" ?&. ["a", "b"]+ w <- selectJSON_ $ \v -> do+ v JSON.-. "test" @>. jsonbVal (toJSON [String "test"])+ liftIO $ length x `shouldBe` 2+ liftIO $ length y `shouldBe` 1+ liftIO $ length z `shouldBe` 0+ liftIO $ length w `shouldBe` 0+ sqlFailWith "22023" $ selectJSONwhere $ \v ->+ v JSON.-. 0 @>. jsonbVal (toJSON ([] :: [Int]))+ where+ selectJSON_ f = selectJSON $ \v -> do+ where_+ $ v @>. jsonbVal (object [])+ ||. v @>. jsonbVal (toJSON ([] :: [Int]))+ where_ $ f v++testMinusOperatorV10 :: SpecDb+testMinusOperatorV10 = do+ describe "Minus Operator (PSQL >= v10)" $ do+ itDb "creates sane SQL" $ do+ let obj = object ["a" .= False, "b" .= True]+ encoded = BSL.toStrict $ encode obj+ createSaneSQL @JSONValue+ (jsonbVal obj --. ["a","b"])+ "SELECT (? - ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped encoded+ , persistTextArray ["a","b"]+ ]+ itDb "creates sane SQL (chained)" $ do+ let obj = object ["a" .= [object ["b" .= True]]]+ encoded = BSL.toStrict $ encode obj+ createSaneSQL @JSONValue+ (jsonbVal obj #>. ["a","0"] --. ["b"])+ "SELECT ((? #> ?) - ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped encoded+ , persistTextArray ["a","0"]+ , persistTextArray ["b"]+ ]+ itDb "works as expected" $ do+ x <- selectJSON $ \v -> do+ where_ $ v @>. jsonbVal (toJSON ([] :: [Int]))+ where_ $ v --. ["test","a"] @>. jsonbVal (toJSON [String "test"])+ y <- selectJSON $ \v -> do+ where_ $ v @>. jsonbVal (object [])+ where_ $ v --. ["a","b"] <@. jsonbVal (object [])+ z <- selectJSON_ $ \v -> v --. ["b"] <@. jsonbVal (object ["a" .= (1 :: Int)])+ w <- selectJSON_ $ \v -> do+ v --. ["test"] @>. jsonbVal (toJSON [String "test"])+ liftIO $ length x `shouldBe` 0+ liftIO $ length y `shouldBe` 2+ liftIO $ length z `shouldBe` 1+ liftIO $ length w `shouldBe` 0+ sqlFailWith "22023" $ selectJSONwhere $ \v ->+ v --. ["a"] @>. jsonbVal (toJSON ([] :: [Int]))+ where+ selectJSON_ f = selectJSON $ \v -> do+ where_ $ v @>. jsonbVal (object [])+ ||. v @>. jsonbVal (toJSON ([] :: [Int]))+ where_ $ f v++testHashMinusOperator :: SpecDb+testHashMinusOperator =+ describe "Hash-Minus Operator" $ do+ itDb "creates sane SQL" $+ createSaneSQL @JSONValue+ (jsonbVal (object ["a" .= False, "b" .= True]) #-. ["a"])+ "SELECT (? #- ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped (BSL.toStrict $ encode $ object ["a" .= False, "b" .= True])+ , persistTextArray ["a"] ]+ itDb "creates sane SQL (chained)" $ do+ let obj = object ["a" .= [object ["b" .= True]]]+ createSaneSQL @JSONValue+ (jsonbVal obj ->. "a" #-. ["0","b"])+ "SELECT ((? -> ?) #- ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped (BSL.toStrict $ encode obj)+ , PersistText "a"+ , persistTextArray ["0","b"] ]+ itDb "works as expected" $ do+ x <- selectJSON $ \v -> do+ where_ $ v @>. jsonbVal (toJSON ([] :: [Int]))+ where_ $ v #-. ["1","a"] @>. jsonbVal (toJSON [object []])+ y <- selectJSON $ \v -> do+ where_ $ v @>. jsonbVal (toJSON ([] :: [Int]))+ where_ $ v #-. ["-3","a"] @>. jsonbVal (toJSON [object []])+ z <- selectJSON_ $ \v -> v #-. ["a","b","c"]+ @>. jsonbVal (object ["a" .= object ["b" .= object ["c" .= String "message"]]])+ w <- selectJSON_ $ \v -> v #-. ["a","b"] JSON.?. "b"+ liftIO $ length x `shouldBe` 1+ liftIO $ length y `shouldBe` 1+ liftIO $ length z `shouldBe` 0+ liftIO $ length w `shouldBe` 1+ sqlFailWith "22023" $ selectJSONwhere $ \v ->+ v #-. ["0"] @>. jsonbVal (toJSON ([] :: [Int]))+ where selectJSON_ f = selectJSON $ \v -> do+ where_ $ v @>. jsonbVal (object [])+ where_ $ f v++testInsertUniqueViolation :: SpecDb+testInsertUniqueViolation =+ describe "Unique Violation on Insert" $+ itDb "Unique throws exception" $ do+ eres <-+ try $ do+ _ <- insert u1+ _ <- insert u2+ insert u3+ liftIO $ case eres of+ Left err | err == exception ->+ pure ()+ _ ->+ expectationFailure $ "Expected a SQL exception, got: " <>+ show eres++ where+ exception = SqlError {+ sqlState = "23505",+ sqlExecStatus = FatalError,+ sqlErrorMsg = "duplicate key value violates unique constraint \"UniqueValue\"",+ sqlErrorDetail = "Key (value)=(0) already exists.",+ sqlErrorHint = ""}++testUpsert :: SpecDb+testUpsert =+ describe "Upsert test" $ do+ itDb "Upsert can insert like normal" $ do+ u1e <- EP.upsert u1 [OneUniqueName =. val "fifth"]+ liftIO $ entityVal u1e `shouldBe` u1+ itDb "Upsert performs update on collision" $ do+ u1e <- EP.upsert u1 [OneUniqueName =. val "fifth"]+ liftIO $ entityVal u1e `shouldBe` u1+ u2e <- EP.upsert u2 [OneUniqueName =. val "fifth"]+ liftIO $ entityVal u2e `shouldBe` u2+ u3e <- EP.upsert u3 [OneUniqueName =. val "fifth"]+ liftIO $ entityVal u3e `shouldBe` u1{oneUniqueName="fifth"}++testInsertSelectWithConflict :: SpecDb+testInsertSelectWithConflict =+ describe "insertSelectWithConflict test" $ do+ itDb "Should do Nothing when no updates set" $ do+ _ <- insert p1+ _ <- insert p2+ _ <- insert p3+ n1 <- EP.insertSelectWithConflictCount UniqueValue (+ from $ \p -> return $ OneUnique <# val "test" <&> (p ^. PersonFavNum)+ )+ (\current excluded -> [])+ uniques1 <- select $ from $ \u -> return u+ n2 <- EP.insertSelectWithConflictCount UniqueValue (+ from $ \p -> return $ OneUnique <# val "test" <&> (p ^. PersonFavNum)+ )+ (\current excluded -> [])+ uniques2 <- select $ from $ \u -> return u+ liftIO $ n1 `shouldBe` 3+ liftIO $ n2 `shouldBe` 0+ let test = map (OneUnique "test" . personFavNum) [p1,p2,p3]+ liftIO $ map entityVal uniques1 `shouldBe` test+ liftIO $ map entityVal uniques2 `shouldBe` test+ itDb "Should update a value if given an update on conflict" $ do+ _ <- insert p1+ _ <- insert p2+ _ <- insert p3+ -- Note, have to sum 4 so that the update does not conflicts again with another row.+ n1 <- EP.insertSelectWithConflictCount UniqueValue (+ from $ \p -> return $ OneUnique <# val "test" <&> (p ^. PersonFavNum)+ )+ (\current excluded -> [OneUniqueValue =. val 4 +. (current ^. OneUniqueValue) +. (excluded ^. OneUniqueValue)])+ uniques1 <- select $ from $ \u -> return u+ n2 <- EP.insertSelectWithConflictCount UniqueValue (+ from $ \p -> return $ OneUnique <# val "test" <&> (p ^. PersonFavNum)+ )+ (\current excluded -> [OneUniqueValue =. val 4 +. (current ^. OneUniqueValue) +. (excluded ^. OneUniqueValue)])+ uniques2 <- select $ from $ \u -> return u+ liftIO $ n1 `shouldBe` 3+ liftIO $ n2 `shouldBe` 3+ let test = map (OneUnique "test" . personFavNum) [p1,p2,p3]+ test2 = map (OneUnique "test" . (+4) . (*2) . personFavNum) [p1,p2,p3]+ liftIO $ map entityVal uniques1 `shouldBe` test+ liftIO $ map entityVal uniques2 `shouldBe` test2++testFilterWhere :: SpecDb+testFilterWhere =+ describe "filterWhere" $ do+ itDb "adds a filter clause to count aggregation" $ do+ -- Person "John" (Just 36) Nothing 1+ _ <- insert p1+ -- Person "Rachel" Nothing (Just 37) 2+ _ <- insert p2+ -- Person "Mike" (Just 17) Nothing 3+ _ <- insert p3+ -- Person "Livia" (Just 17) (Just 18) 4+ _ <- insert p4+ -- Person "Mitch" Nothing Nothing 5+ _ <- insert p5++ usersByAge <- fmap coerce <$> do+ select $ from $ \users -> do+ groupBy $ users ^. PersonAge+ return+ ( users ^. PersonAge :: SqlExpr (Value (Maybe Int))+ -- Nothing: [Rachel { favNum = 2 }, Mitch { favNum = 5 }] = 2+ -- Just 36: [John { favNum = 1 } (excluded)] = 0+ -- Just 17: [Mike { favNum = 3 }, Livia { favNum = 4 }] = 2+ , count (users ^. PersonId) `EP.filterWhere` (users ^. PersonFavNum >=. val 2)+ :: SqlExpr (Value Int)+ -- Nothing: [Rachel { favNum = 2 } (excluded), Mitch { favNum = 5 } (excluded)] = 0+ -- Just 36: [John { favNum = 1 }] = 1+ -- Just 17: [Mike { favNum = 3 } (excluded), Livia { favNum = 4 } (excluded)] = 0+ , count (users ^. PersonFavNum) `EP.filterWhere` (users ^. PersonFavNum <. val 2)+ :: SqlExpr (Value Int)+ )++ liftIO $ usersByAge `shouldMatchList`+ ( [ (Nothing, 2, 0)+ , (Just 36, 0, 1)+ , (Just 17, 2, 0)+ ] :: [(Maybe Int, Int, Int)]+ )++ itDb "adds a filter clause to sum aggregation" $ do+ -- Person "John" (Just 36) Nothing 1+ _ <- insert p1+ -- Person "Rachel" Nothing (Just 37) 2+ _ <- insert p2+ -- Person "Mike" (Just 17) Nothing 3+ _ <- insert p3+ -- Person "Livia" (Just 17) (Just 18) 4+ _ <- insert p4+ -- Person "Mitch" Nothing Nothing 5+ _ <- insert p5++ usersByAge <- fmap (\(Value a, Value b, Value c) -> (a, b, c)) <$> do+ select $ from $ \users -> do+ groupBy $ users ^. PersonAge+ return+ ( users ^. PersonAge+ -- Nothing: [Rachel { favNum = 2 }, Mitch { favNum = 5 }] = Just 7+ -- Just 36: [John { favNum = 1 } (excluded)] = Nothing+ -- Just 17: [Mike { favNum = 3 }, Livia { favNum = 4 }] = Just 7+ , sum_ (users ^. PersonFavNum) `EP.filterWhere` (users ^. PersonFavNum >=. val 2)+ -- Nothing: [Rachel { favNum = 2 } (excluded), Mitch { favNum = 5 } (excluded)] = Nothing+ -- Just 36: [John { favNum = 1 }] = Just 1+ -- Just 17: [Mike { favNum = 3 } (excluded), Livia { favNum = 4 } (excluded)] = Nothing+ , sum_ (users ^. PersonFavNum) `EP.filterWhere` (users ^. PersonFavNum <. val 2)+ )++ liftIO $ usersByAge `shouldMatchList`+ ( [ (Nothing, Just 7, Nothing)+ , (Just 36, Nothing, Just 1)+ , (Just 17, Just 7, Nothing)+ ] :: [(Maybe Int, Maybe Rational, Maybe Rational)]+ )++testCommonTableExpressions :: SpecDb+testCommonTableExpressions = do+ describe "You can run them" $ do+ itDb "will run" $ do+ void $ select $ do+ limitedLordsCte <-+ Experimental.with $ do+ lords <- Experimental.from $ Experimental.table @Lord+ limit 10+ pure lords+ lords <- Experimental.from limitedLordsCte+ orderBy [asc $ lords ^. LordId]+ pure lords++ asserting noExceptions++ itDb "can do multiple recursive queries" $ do+ let+ oneToTen =+ Experimental.withRecursive+ (pure $ val (1 :: Int))+ Experimental.unionAll_+ (\self -> do+ v <- Experimental.from self+ where_ $ v <. val 10+ pure $ v +. val 1+ )++ vals <- select $ do+ cte <- oneToTen+ cte2 <- oneToTen+ res1 <- Experimental.from cte+ res2 <- Experimental.from cte2+ pure (res1, res2)+ asserting $ vals `shouldBe` (((,) <$> fmap Value [1..10] <*> fmap Value [1..10]))++ itDb "passing previous query works" $ do+ let+ oneToTen =+ Experimental.withRecursive+ (pure $ val (1 :: Int))+ Experimental.unionAll_+ (\self -> do+ v <- Experimental.from self+ where_ $ v <. val 10+ pure $ v +. val 1+ )++ oneMore q =+ Experimental.with $ do+ v <- Experimental.from q+ pure $ v +. val 1+ vals <- select $ do+ cte <- oneToTen+ cte2 <- oneMore cte+ res <- Experimental.from cte2+ pure res+ asserting $ vals `shouldBe` fmap Value [2..11]++-- Since lateral queries arent supported in Sqlite or older versions of mysql+-- the test is in the Postgres module+testLateralQuery :: SpecDb+testLateralQuery = do+ describe "Lateral queries" $ do+ itDb "supports CROSS JOIN LATERAL" $ do+ _ <- do+ select $ do+ l :& c <-+ Experimental.from $ table @Lord+ `CrossJoin` \lord -> do+ deed <- Experimental.from $ table @Deed+ where_ $ lord ^. LordId ==. deed ^. DeedOwnerId+ pure $ countRows @Int+ pure (l, c)+ liftIO $ True `shouldBe` True++ itDb "supports INNER JOIN LATERAL" $ do+ let subquery lord = do+ deed <- Experimental.from $ table @Deed+ where_ $ lord ^. LordId ==. deed ^. DeedOwnerId+ pure $ countRows @Int+ res <- select $ do+ l :& c <- Experimental.from $ table @Lord+ `InnerJoin` subquery+ `Experimental.on` (const $ val True)+ pure (l, c)++ let _ = res :: [(Entity Lord, Value Int)]+ asserting noExceptions++ itDb "supports LEFT JOIN LATERAL" $ do+ res <- select $ do+ l :& c <- Experimental.from $ table @Lord+ `LeftOuterJoin` (\lord -> do+ deed <- Experimental.from $ table @Deed+ where_ $ lord ^. LordId ==. deed ^. DeedOwnerId+ pure $ countRows @Int)+ `Experimental.on` (const $ val True)+ pure (l, c)++ let _ = res :: [(Entity Lord, Value (Maybe Int))]+ asserting noExceptions++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++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)
test/SQLite/Test.hs view
@@ -4,173 +4,137 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -module Main (main) where+module SQLite.Test where +import Common.Test.Import hiding (from, on)+ import Control.Monad (void)-import Control.Monad.IO.Class (MonadIO(liftIO)) import Control.Monad.Logger (runNoLoggingT, runStderrLoggingT)-import Control.Monad.Trans.Reader (ReaderT)-import qualified Control.Monad.Trans.Resource as R-import Database.Esqueleto hiding (random_)+import Database.Esqueleto.Legacy hiding (random_) import Database.Esqueleto.SQLite (random_)-import Database.Persist.Sqlite (withSqliteConn)+import Database.Persist.Sqlite (createSqlitePool) import Database.Sqlite (SqliteException)-import Test.Hspec import Common.Test ----testSqliteRandom :: Spec+testSqliteRandom :: SpecDb testSqliteRandom = do- it "works with random_" $- run $ do- _ <- select $ return (random_ :: SqlExpr (Value Int))- return ()----+ itDb "works with random_" $ do+ _ <- select $ return (random_ :: SqlExpr (Value Int))+ asserting noExceptions -testSqliteSum :: Spec+testSqliteSum :: SpecDb testSqliteSum = do- it "works with sum_" $- run $ do- _ <- insert' p1- _ <- insert' p2- _ <- insert' p3- _ <- insert' p4- ret <- select $- from $ \p->- return $ joinV $ sum_ (p ^. PersonAge)- liftIO $ ret `shouldBe` [ Value $ Just (36 + 17 + 17 :: Int) ]+ 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 :: Int) ] -testSqliteTwoAscFields :: Spec+testSqliteTwoAscFields :: SpecDb testSqliteTwoAscFields = do- it "works with two ASC fields (one call)" $- run $ 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 SQLite and MySQL, its the reverse- liftIO $ ret `shouldBe` [ p2e, p4e, p3e, p1e ]----+ 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 SQLite and MySQL, its the reverse+ asserting $ ret `shouldBe` [ p2e, p4e, p3e, p1e ] -testSqliteOneAscOneDesc :: Spec+testSqliteOneAscOneDesc :: SpecDb testSqliteOneAscOneDesc = do- it "works with one ASC and one DESC field (two calls)" $- run $ 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- liftIO $ ret `shouldBe` [ p1e, p4e, p3e, p2e ]----+ 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` [ p1e, p4e, p3e, p2e ] -testSqliteCoalesce :: Spec+testSqliteCoalesce :: SpecDb testSqliteCoalesce = do- it "throws an exception on SQLite with <2 arguments" $- run (select $- from $ \p -> do- return (coalesce [p ^. PersonAge]) :: SqlQuery (SqlExpr (Value (Maybe Int))))- `shouldThrow` (\(_ :: SqliteException) -> True)----+ itDb "throws an exception on SQLite with <2 arguments" $ do+ eres <- try $ select $+ from $ \p -> do+ return (coalesce [p ^. PersonAge]) :: SqlQuery (SqlExpr (Value (Maybe Int)))+ asserting $ case eres of+ Left (_ :: SqliteException) ->+ pure ()+ Right _ ->+ expectationFailure "Expected SqliteException with <2 args to coalesce" -testSqliteUpdate :: Spec+testSqliteUpdate :: SpecDb testSqliteUpdate = do- it "works on a simple example" $- run $ 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- -- SQLite: nulls appear first, update returns matched rows.- liftIO $ n `shouldBe` 2- liftIO $ ret `shouldBe` [ Entity p2k (Person anon Nothing (Just 37) 2)- , Entity p1k (Person anon (Just 73) Nothing 1)- , Entity p3k p3 ]------nameContains :: (BaseBackend backend ~ SqlBackend,- BackendCompatible SqlBackend backend,- MonadIO m, SqlString s,- IsPersistBackend backend, PersistQueryRead backend,- PersistUniqueRead backend)- => (SqlExpr (Value [Char])- -> SqlExpr (Value s)- -> SqlExpr (Value Bool))- -> s- -> [Entity Person]- -> ReaderT backend m ()-nameContains f t expected = do- ret <- select $- from $ \p -> do- where_ (f- (p ^. PersonName)- ((%) ++. val t ++. (%)))- orderBy [asc (p ^. PersonName)]- return p- liftIO $ ret `shouldBe` expected+ itDb "works on a simple example" $ do+ p1k <- insert p1+ p2k <- insert p2+ p3k <- insert p3+ let anon = "Anonymous" :: String+ () <- 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+ -- SQLite: nulls appear first, update returns matched rows.+ asserting $ do+ n `shouldBe` 2+ ret `shouldMatchList`+ [ Entity p2k (Person anon Nothing (Just 37) 2)+ , Entity p1k (Person anon (Just 73) Nothing 1)+ , Entity p3k p3+ ] -testSqliteTextFunctions :: Spec+testSqliteTextFunctions :: SpecDb testSqliteTextFunctions = do- describe "text functions" $ do- it "like, (%) and (++.) work on a simple example" $- run $ do- [p1e, p2e, p3e, p4e] <- mapM insert' [p1, p2, p3, p4]- nameContains like "h" [p1e, p2e]- nameContains like "i" [p4e, p3e]- nameContains like "iv" [p4e]--main :: IO ()-main = do- hspec $ do- tests run+ describe "text functions" $ do+ itDb "like, (%) and (++.) work on a simple example" $ do+ let query :: String -> SqlPersistT IO [Entity Person]+ query 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]+ r0 <- query "h"+ r1 <- query "i"+ r2 <- query "iv"+ asserting $ do+ r0 `shouldBe` [p1e, p2e]+ r1 `shouldBe` [p4e, p3e]+ r2 `shouldBe` [p4e] - describe "Test SQLite locking" $ do- testLocking withConn+spec :: HasCallStack => Spec+spec = beforeAll mkConnectionPool $ do+ tests describe "SQLite specific tests" $ do- testAscRandom random_ run- testRandomMath run+ testAscRandom random_+ testRandomMath testSqliteRandom testSqliteSum testSqliteTwoAscFields@@ -179,24 +143,23 @@ testSqliteUpdate testSqliteTextFunctions -run, runSilent, runVerbose :: Run-runSilent act = runNoLoggingT $ run_worker act-runVerbose act = runStderrLoggingT $ run_worker act-run =- if verbose- then runVerbose- else runSilent+mkConnectionPool :: IO ConnectionPool+mkConnectionPool = do+ conn <-+ if verbose+ then runStderrLoggingT $+ createSqlitePool ".esqueleto-test.sqlite" 4+ else runNoLoggingT $+ createSqlitePool ".esqueleto-test.sqlite" 4+ flip runSqlPool conn $ do+ migrateIt + pure conn+ verbose :: Bool verbose = False -run_worker :: RunDbMonad m => SqlPersistT (R.ResourceT m) a -> m a-run_worker act = withConn $ runSqlConn (migrateIt >> act)--migrateIt :: RunDbMonad m => SqlPersistT (R.ResourceT m) ()+migrateIt :: MonadUnliftIO m => SqlPersistT m () migrateIt = do void $ runMigrationSilent migrateAll--withConn :: RunDbMonad m => (SqlBackend -> R.ResourceT m a) -> m a-withConn =- R.runResourceT . withSqliteConn ":memory:"+ cleanDB
+ test/Spec.hs view
@@ -0,0 +1,22 @@+module Main where++import Test.Hspec+import Test.Hspec.Core.Spec++import qualified SQLite.Test as SQLite+import qualified MySQL.Test as MySQL+import qualified PostgreSQL.Test as Postgres++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+ parallel $ describe "Esqueleto" $ do+ describe "SQLite" $ do+ sequential $ SQLite.spec+ describe "MySQL" $ do+ sequential $ MySQL.spec+ describe "Postgresql" $ do+ sequential $ Postgres.spec+