esqueleto 2.5.3 → 2.6.0
raw patch · 12 files changed
+2975/−1807 lines, 12 filesdep +timedep +unliftiodep −HUnitdep −QuickCheckdep −monad-controldep ~basedep ~conduitdep ~hspecnew-uploader
Dependencies added: time, unliftio
Dependencies removed: HUnit, QuickCheck, monad-control
Dependency ranges changed: base, conduit, hspec, monad-logger, mysql, mysql-simple, persistent, persistent-mysql, persistent-postgresql, persistent-sqlite, persistent-template, postgresql-libpq, postgresql-simple, resourcet, text, transformers
Files
- esqueleto.cabal +137/−102
- src/Database/Esqueleto.hs +6/−9
- src/Database/Esqueleto/Internal/Language.hs +26/−26
- src/Database/Esqueleto/Internal/Sql.hs +176/−116
- src/Database/Esqueleto/MySQL.hs +18/−0
- src/Database/Esqueleto/PostgreSQL.hs +127/−13
- src/Database/Esqueleto/SQLite.hs +18/−0
- test/Common/Test.hs +1470/−0
- test/MySQL/Test.hs +218/−0
- test/PostgreSQL/Test.hs +564/−0
- test/SQLite/Test.hs +215/−0
- test/Test.hs +0/−1541
esqueleto.cabal view
@@ -1,122 +1,157 @@-name: esqueleto-version: 2.5.3-synopsis: Type-safe EDSL for SQL queries on persistent backends.-homepage: https://github.com/bitemyapp/esqueleto-license: BSD3-license-file: LICENSE-author: Felipe Lessa-maintainer: cma@bitemyapp.com-copyright: (c) 2012-2016 Felipe Almeida Lessa-category: Database-build-type: Simple-cabal-version: >=1.8-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.- .- @persistent@ is a library for type-safe data serialization. It- has many kinds of backends, such as SQL backends- (@persistent-mysql@, @persistent-postgresql@,- @persistent-sqlite@) and NoSQL backends (@persistent-mongoDB@).- While @persistent@ is a nice library for storing and retrieving- records, including with filters, it does not try to support- some of the features that are specific to SQL backends. In- particular, @esqueleto@ is the recommended library for- type-safe @JOIN@s on @persistent@ SQL backends. (The- alternative is using raw SQL, but that's error prone and does- not offer any composability.)- .- Currently, @SELECT@s, @UPDATE@s, @INSERT@s and @DELETE@s are supported.- Not all SQL features are available, but most of them can be easily added- (especially functions), so please open an issue or send a pull request if- you need anything that is not covered by @esqueleto@ on- <https://github.com/bitemyapp/esqueleto>.- .- The name of this library means \"skeleton\" in Portuguese and- contains all three SQL letters in the correct order =). It was- inspired by Scala's Squeryl but created from scratch.+cabal-version: 1.12 -source-repository head- type: git- location: git://github.com/bitemyapp/esqueleto.git+-- This file has been generated from package.yaml by hpack version 0.31.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: c5408ff1923a2a70cf9c7b5590f83d724453768845c1dd1d92888c177dfad357 -Flag postgresql- Description: test postgresql. default is to test sqlite.- Default: False+name: esqueleto+version: 2.6.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.+ .+ @persistent@ is a library for type-safe data serialization. It has many kinds of backends, such as SQL backends (@persistent-mysql@, @persistent-postgresql@, @persistent-sqlite@) and NoSQL backends (@persistent-mongoDB@). While @persistent@ is a nice library for storing and retrieving records, including with filters, it does not try to support some of the features that are specific to SQL backends. In particular, @esqueleto@ is the recommended library for type-safe @JOIN@s on @persistent@ SQL backends. (The alternative is using raw SQL, but that's error prone and does not offer any composability.)+ .+ Currently, @SELECT@s, @UPDATE@s, @INSERT@s and @DELETE@s are supported. Not all SQL features are available, but most of them can be easily added (especially functions), so please open an issue or send a pull request if you need anything that is not covered by @esqueleto@ on <https://github.com/bitemyapp/esqueleto>.+ .+ The name of this library means \"skeleton\" in Portuguese and contains all three SQL letters in the correct order =). It was inspired by Scala's Squeryl but created from scratch.+category: Database+homepage: https://github.com/bitemyapp/esqueleto+author: Felipe Lessa+maintainer: cma@bitemyapp.com+copyright: (c) 2012-2016 Felipe Almeida Lessa+license: BSD3+license-file: LICENSE+build-type: Simple -Flag mysql- Description: test MySQL/MariaDB. default is to test sqlite.- Default: False+source-repository head+ type: git+ location: git://github.com/bitemyapp/esqueleto.git library exposed-modules:- Database.Esqueleto- Database.Esqueleto.PostgreSQL- Database.Esqueleto.Internal.Language- Database.Esqueleto.Internal.Sql+ Database.Esqueleto+ Database.Esqueleto.Internal.Language+ Database.Esqueleto.Internal.Sql+ Database.Esqueleto.MySQL+ Database.Esqueleto.PostgreSQL+ Database.Esqueleto.SQLite other-modules:- Database.Esqueleto.Internal.PersistentImport+ Database.Esqueleto.Internal.PersistentImport+ Paths_esqueleto+ hs-source-dirs:+ src/ build-depends:- base >= 4.8 && < 5.0+ base >=4.8 && <5.0+ , blaze-html , bytestring- , text >= 0.11 && < 1.3- , persistent >= 2.5 && < 2.8- , transformers >= 0.2- , unordered-containers >= 0.2- , tagged >= 0.2-+ , conduit >=1.3 , monad-logger- , conduit >= 1.1- , resourcet >= 1.1- , blaze-html- hs-source-dirs: src/- if impl(ghc >= 8.0)+ , persistent >=2.8.0 && <2.10+ , resourcet >=1.2+ , tagged >=0.2+ , text >=0.11 && <1.3+ , time >=1.5.0.1 && <=1.8.0.2+ , transformers >=0.2+ , unliftio+ , unordered-containers >=0.2+ if impl(ghc >=8.0) ghc-options: -Wall -Wno-redundant-constraints else ghc-options: -Wall+ default-language: Haskell2010 -test-suite test+test-suite mysql type: exitcode-stdio-1.0- ghc-options: -Wall- hs-source-dirs: test- main-is: Test.hs+ main-is: MySQL/Test.hs+ other-modules:+ Common.Test+ Paths_esqueleto+ hs-source-dirs:+ test+ ghc-options: -Wall build-depends:- -- Library dependencies used on the tests. No need to- -- specify versions since they'll use the same as above.- base, persistent, transformers, resourcet, text-- -- Test-only dependencies- , conduit >= 1.1+ base >=4.8 && <5.0+ , blaze-html+ , bytestring+ , conduit >=1.3 , containers- , HUnit- , QuickCheck- , hspec >= 1.8- , persistent-sqlite >= 2.1.3- , persistent-template >= 2.1- , monad-control- , monad-logger >= 0.3-- -- This library , esqueleto-- if flag(postgresql)- build-depends:- postgresql-simple >= 0.2- , postgresql-libpq >= 0.6- , persistent-postgresql >= 2.0-- cpp-options: -DWITH_POSTGRESQL+ , hspec+ , monad-logger+ , mysql+ , mysql-simple+ , persistent >=2.8.0 && <2.10+ , persistent-mysql+ , persistent-template+ , resourcet >=1.2+ , tagged >=0.2+ , text >=0.11 && <1.3+ , time >=1.5.0.1 && <=1.8.0.2+ , transformers >=0.2+ , unliftio+ , unordered-containers >=0.2+ default-language: Haskell2010 - if flag(mysql)- build-depends:- mysql-simple >= 0.2.2.3- , mysql >= 0.1.1.3- , persistent-mysql >= 2.0+test-suite postgresql+ type: exitcode-stdio-1.0+ main-is: PostgreSQL/Test.hs+ other-modules:+ Common.Test+ Paths_esqueleto+ hs-source-dirs:+ test+ ghc-options: -Wall+ build-depends:+ base >=4.8 && <5.0+ , blaze-html+ , bytestring+ , conduit >=1.3+ , containers+ , esqueleto+ , hspec+ , monad-logger+ , persistent >=2.8.0 && <2.10+ , persistent-postgresql+ , persistent-template+ , postgresql-libpq+ , postgresql-simple+ , resourcet >=1.2+ , tagged >=0.2+ , text >=0.11 && <1.3+ , time >=1.5.0.1 && <=1.8.0.2+ , transformers >=0.2+ , unliftio+ , unordered-containers >=0.2+ default-language: Haskell2010 - cpp-options: -DWITH_MYSQL+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+ build-depends:+ base >=4.8 && <5.0+ , blaze-html+ , bytestring+ , conduit >=1.3+ , containers+ , esqueleto+ , hspec+ , monad-logger+ , persistent >=2.8.0 && <2.10+ , persistent-sqlite+ , persistent-template+ , resourcet >=1.2+ , tagged >=0.2+ , text >=0.11 && <1.3+ , time >=1.5.0.1 && <=1.8.0.2+ , transformers >=0.2+ , unliftio+ , unordered-containers >=0.2+ default-language: Haskell2010
src/Database/Esqueleto.hs view
@@ -40,8 +40,8 @@ -- * @esqueleto@'s Language Esqueleto( where_, on, groupBy, orderBy, rand, asc, desc, limit, offset , distinct, distinctOn, don, distinctOnOrderBy, having, locking- , sub_select, sub_selectDistinct, (^.), (?.)- , val, isNothing, just, nothing, joinV+ , sub_select, (^.), (?.)+ , val, isNothing, just, nothing, joinV, withNonNull , countRows, count, countDistinct , not_, (==.), (>=.), (>.), (<=.), (<.), (!=.), (&&.), (||.) , (+.), (-.), (/.), (*.)@@ -49,7 +49,7 @@ , min_, max_, sum_, avg_, castNum, castNumM , coalesce, coalesceDefault , lower_, like, ilike, (%), concat_, (++.), castString- , subList_select, subList_selectDistinct, valList, justList+ , subList_select, valList, justList , in_, notIn, exists, notExists , set, (=.), (+=.), (-=.), (*=.), (/=.) , case_, toBaseId)@@ -59,7 +59,6 @@ , else_ , from , Value(..)- , unValue , ValueList(..) , OrderBy , DistinctOn@@ -78,19 +77,17 @@ , SqlExpr , SqlEntity , select- , selectDistinct , selectSource- , selectDistinctSource , delete , deleteCount , update , updateCount , insertSelect , insertSelectCount- , insertSelectDistinct , (<#) , (<&>)-+ -- * Internal.Language+ , From -- * RDBMS-specific modules -- $rdbmsSpecificModules @@ -314,7 +311,7 @@ -- SELECT P1.*, Follow.*, P2.* -- FROM Person AS P1 -- INNER JOIN Follow ON P1.id = Follow.follower--- INNER JOIN P2 ON P2.id = Follow.followed+-- INNER JOIN Person AS P2 ON P2.id = Follow.followed -- @ -- -- In @esqueleto@, we may write the same query above as:
src/Database/Esqueleto/Internal/Language.hs view
@@ -16,7 +16,6 @@ Esqueleto(..) , from , Value(..)- , unValue , ValueList(..) , SomeValue(..) , ToSomeValues(..)@@ -36,6 +35,7 @@ -- * The guts , JoinKind(..) , IsJoinKind(..)+ , BackendCompatible(..) , PreprocessedFrom , From , FromPreprocess@@ -54,7 +54,6 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as TL - -- | Finally tagless representation of @esqueleto@'s EDSL. class (Functor query, Applicative query, Monad query) => Esqueleto query expr backend | query -> expr backend, expr -> query backend where@@ -73,12 +72,12 @@ -- @JOIN@. fromStart :: ( PersistEntity a- , PersistEntityBackend a ~ backend )+ , BackendCompatible backend (PersistEntityBackend a) ) => query (expr (PreprocessedFrom (expr (Entity a)))) -- | (Internal) Same as 'fromStart', but entity may be missing. fromStartMaybe :: ( PersistEntity a- , PersistEntityBackend a ~ backend )+ , BackendCompatible backend (PersistEntityBackend a) ) => query (expr (PreprocessedFrom (expr (Maybe (Entity a))))) -- | (Internal) Do a @JOIN@. fromJoin@@ -293,13 +292,16 @@ -- is guaranteed to return just one row. sub_select :: PersistField a => query (expr (Value a)) -> expr (Value a) - -- | Same as 'sub_select' but using @SELECT DISTINCT@.- sub_selectDistinct :: PersistField a => query (expr (Value a)) -> expr (Value a)- -- | Project a field of an entity. (^.) :: (PersistEntity val, PersistField typ) => expr (Entity val) -> EntityField val typ -> expr (Value typ) + -- | Project an expression that may be null, guarding against null cases.+ withNonNull :: PersistField typ+ => expr (Value (Maybe typ))+ -> (expr (Value typ) -> query a)+ -> query a+ -- | Project a field of an entity that may be null. (?.) :: (PersistEntity val, PersistField typ) => expr (Maybe (Entity val)) -> EntityField val typ -> expr (Value (Maybe typ))@@ -442,9 +444,6 @@ -- list of values. subList_select :: PersistField a => query (expr (Value a)) -> expr (ValueList a) - -- | Same as 'sublist_select' but using @SELECT DISTINCT@.- subList_selectDistinct :: PersistField a => query (expr (Value a)) -> expr (ValueList a)- -- | Lift a list of constant value from Haskell-land to the query. valList :: PersistField typ => [typ] -> expr (ValueList typ) @@ -590,9 +589,9 @@ -- /Since: 2.4.3/ toBaseId :: ToBaseId ent => expr (Value (Key ent)) -> expr (Value (Key (BaseEnt ent))) -{-# DEPRECATED sub_selectDistinct "Since 2.2.4: use 'sub_select' and 'distinct'." #-}-{-# DEPRECATED subList_selectDistinct "Since 2.2.4: use 'subList_select' and 'distinct'." #-}+{-# DEPRECATED random_ "Since 2.6.0: `random_` is not uniform across all databases! Please use a specific one such as 'Database.Esqueleto.PostgreSQL.random_', 'Database.Esqueleto.MySQL.random_', or 'Database.Esqueleto.SQLite.random_'" #-} +{-# DEPRECATED rand "Since 2.6.0: `rand` ordering function is not uniform across all databases! To avoid accidental partiality it will be removed in the next major version." #-} -- Fixity declarations infixl 9 ^.@@ -624,29 +623,25 @@ -- | A single value (as opposed to a whole entity). You may use -- @('^.')@ or @('?.')@ to get a 'Value' from an 'Entity'.-data Value a = Value a deriving (Eq, Ord, Show, Typeable)--- Note: because of GHC bug #6124 we use @data@ instead of @newtype@.--- <https://ghc.haskell.org/trac/ghc/ticket/6124>+newtype Value a = Value { unValue :: a } deriving (Eq, Ord, Show, Typeable) -- | /Since: 1.4.4/ instance Functor Value where fmap f (Value a) = Value (f a) ---- | Unwrap a 'Value'.------ /Since: 1.4.1/-unValue :: Value a -> a-unValue (Value a) = a+instance Applicative Value where+ (<*>) (Value f) (Value a) = Value (f a)+ pure = Value +instance Monad Value where+ (>>=) x f = valueJoin $ fmap f x+ where valueJoin (Value v) = v -- | A list of single values. There's a limited set of functions -- able to work with this data type (such as 'subList_select', -- 'valList', 'in_' and 'exists').-data ValueList a = ValueList a deriving (Eq, Ord, Show, Typeable)--- Note: because of GHC bug #6124 we use @data@ instead of @newtype@.--- <https://ghc.haskell.org/trac/ghc/ticket/6124>+newtype ValueList a = ValueList a deriving (Eq, Ord, Show, Typeable) -- | A wrapper type for for any @expr (Value a)@ for all a.@@ -834,6 +829,11 @@ -- PostgreSQL. -- -- /Since: 2.2.7/+ | ForUpdateSkipLocked+ -- ^ @FOR UPDATE SKIP LOCKED@ syntax. Supported by MySQL, Oracle and+ -- PostgreSQL.+ --+ -- /Since: 2.2.7/ | ForShare -- ^ @FOR SHARE@ syntax. Supported by PostgreSQL. --@@ -1053,13 +1053,13 @@ instance ( Esqueleto query expr backend , PersistEntity val- , PersistEntityBackend val ~ backend+ , BackendCompatible backend (PersistEntityBackend val) ) => FromPreprocess query expr backend (expr (Entity val)) where fromPreprocess = fromStart instance ( Esqueleto query expr backend , PersistEntity val- , PersistEntityBackend val ~ backend+ , BackendCompatible backend (PersistEntityBackend val) ) => FromPreprocess query expr backend (expr (Maybe (Entity val))) where fromPreprocess = fromStartMaybe
src/Database/Esqueleto/Internal/Sql.hs view
@@ -10,6 +10,7 @@ , ScopedTypeVariables , InstanceSigs , Rank2Types+ , CPP #-} -- | This is an internal module, anything exported by this module -- may change without a major version bump. Please use only@@ -17,17 +18,14 @@ module Database.Esqueleto.Internal.Sql ( -- * The pretty face SqlQuery- , SqlExpr+ , SqlExpr(..) , SqlEntity , select , selectSource- , selectDistinct- , selectDistinctSource , delete , deleteCount , update , updateCount- , insertSelectDistinct , insertSelect , insertSelectCount -- * The guts@@ -35,24 +33,33 @@ , unsafeSqlBinOp , unsafeSqlBinOpComposite , unsafeSqlValue+ , unsafeSqlCastAs , unsafeSqlFunction , unsafeSqlExtractSubField , UnsafeSqlFunctionArgument+ , OrderByClause , rawSelectSource , runSource , rawEsqueleto , toRawSql , Mode(..)+ , NeedParens(..) , IdentState , initialIdentState , IdentInfo , SqlSelect(..) , veryUnsafeCoerceSqlExprValue , veryUnsafeCoerceSqlExprValueList+ -- * Helper functions+ , makeOrderByNoNewline+ , uncommas'+ , parens+ , toArgList+ , builderToText ) where import Control.Arrow ((***), first)-import Control.Exception (throw, throwIO)+import Control.Exception (Exception, throw, throwIO) import Control.Monad (ap, MonadPlus(..), void) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Class (lift)@@ -60,7 +67,10 @@ import Data.Acquire (with, allocateAcquire, Acquire) import Data.Int (Int64) import Data.List (intersperse)-import Data.Monoid (Last(..), (<>))+#if __GLASGOW_HASKELL__ < 804+import Data.Semigroup+#endif+import qualified Data.Monoid as Monoid import Data.Proxy (Proxy(..)) import Database.Esqueleto.Internal.PersistentImport import Database.Persist.Sql.Util (entityColumnNames, entityColumnCount, parseEntityValues, isIdField, hasCompositeKey)@@ -76,6 +86,47 @@ import Database.Esqueleto.Internal.Language +-- | Exception data type for @esqueleto@ internal errors+data EsqueletoError =+ CompositeKeyErr CompositeKeyError+ | UnexpectedCaseErr UnexpectedCaseError+ | SqlBinOpCompositeErr SqlBinOpCompositeError+ deriving (Show)++instance Exception EsqueletoError++data CompositeKeyError =+ NotError+ | ToInsertionError+ | CombineInsertionError+ | FoldHelpError+ | SqlCaseError+ | SqlBinOpError+ | SqlCastAsError+ | MakeOnClauseError+ | MakeExcError+ | MakeSetError+ | MakeWhereError+ | MakeHavingError+ deriving (Show)++data UnexpectedCaseError =+ EmptySqlExprValueList+ | MakeFromError+ | UnsupportedSqlInsertIntoType+ | InsertionFinalError+ | NewIdentForError+ | UnsafeSqlCaseError+ deriving (Show)++data SqlBinOpCompositeError =+ MismatchingLengthsError+ | NullPlaceholdersError+ | DeconstructionError+ deriving (Show)+++ -- | SQL backend for @esqueleto@ using 'SqlPersistT'. newtype SqlQuery a = Q { unQ :: W.WriterT SideData (S.State IdentState) a }@@ -112,11 +163,13 @@ , sdLockingClause :: !LockingClause } -instance Monoid SideData where- mempty = SideData mempty mempty mempty mempty mempty mempty mempty mempty mempty- SideData d f s w g h o l k `mappend` SideData d' f' s' w' g' h' o' l' k' =+instance Semigroup SideData where+ SideData d f s w g h o l k <> SideData d' f' s' w' g' h' o' l' k' = SideData (d <> d') (f <> f') (s <> s') (w <> w') (g <> g') (h <> h') (o <> o') (l <> l') (k <> k') +instance Monoid SideData where+ mempty = SideData mempty mempty mempty mempty mempty mempty mempty mempty mempty+ mappend = (<>) -- | The @DISTINCT@ "clause". data DistinctClause =@@ -124,13 +177,15 @@ | DistinctStandard -- ^ Only @DISTINCT@, SQL standard. | DistinctOn [SqlExpr DistinctOn] -- ^ @DISTINCT ON@, PostgreSQL extension. +instance Semigroup DistinctClause where+ DistinctOn a <> DistinctOn b = DistinctOn (a <> b)+ DistinctOn a <> _ = DistinctOn a+ DistinctStandard <> _ = DistinctStandard+ DistinctAll <> b = b+ instance Monoid DistinctClause where mempty = DistinctAll- DistinctOn a `mappend` DistinctOn b = DistinctOn (a <> b)- DistinctOn a `mappend` _ = DistinctOn a- DistinctStandard `mappend` _ = DistinctStandard- DistinctAll `mappend` b = b-+ mappend = (<>) -- | A part of a @FROM@ clause. data FromClause =@@ -177,19 +232,24 @@ data WhereClause = Where (SqlExpr (Value Bool)) | NoWhere +instance Semigroup WhereClause where+ NoWhere <> w = w+ w <> NoWhere = w+ Where e1 <> Where e2 = Where (e1 &&. e2)+ instance Monoid WhereClause where mempty = NoWhere- NoWhere `mappend` w = w- w `mappend` NoWhere = w- Where e1 `mappend` Where e2 = Where (e1 &&. e2)-+ mappend = (<>) -- | A @GROUP BY@ clause. newtype GroupByClause = GroupBy [SomeValue SqlExpr] +instance Semigroup GroupByClause where+ GroupBy fs <> GroupBy fs' = GroupBy (fs <> fs')+ instance Monoid GroupByClause where mempty = GroupBy []- GroupBy fs `mappend` GroupBy fs' = GroupBy (fs <> fs')+ mappend = (<>) -- | A @HAVING@ cause. type HavingClause = WhereClause@@ -201,17 +261,19 @@ -- | A @LIMIT@ clause. data LimitClause = Limit (Maybe Int64) (Maybe Int64) -instance Monoid LimitClause where- mempty = Limit mzero mzero- Limit l1 o1 `mappend` Limit l2 o2 =+instance Semigroup LimitClause where+ Limit l1 o1 <> Limit l2 o2 = Limit (l2 `mplus` l1) (o2 `mplus` o1) -- More than one 'limit' or 'offset' is issued, we want to -- keep the latest one. That's why we use mplus with -- "reversed" arguments. +instance Monoid LimitClause where+ mempty = Limit mzero mzero+ mappend = (<>) -- | A locking clause.-type LockingClause = Last LockingKind+type LockingClause = Monoid.Last LockingKind ----------------------------------------------------------------------@@ -238,7 +300,7 @@ s <- S.get let go (t:ts) | t `HS.member` inUse s = go ts | otherwise = use t- go [] = error "Esqueleto/Sql/newIdentFor: never here"+ go [] = throw (UnexpectedCaseErr NewIdentForError) go (possibilities orig) possibilities t = t : map addNum [2..]@@ -260,7 +322,6 @@ useIdent info (I ident) = fromDBName info $ DBName ident ----------------------------------------------------------------------- -- | An expression on the SQL backend.@@ -395,7 +456,7 @@ having expr = Q $ W.tell mempty { sdHavingClause = Where expr } - locking kind = Q $ W.tell mempty { sdLockingClause = Last (Just kind) }+ locking kind = Q $ W.tell mempty { sdLockingClause = Monoid.Last (Just kind) } orderBy exprs = Q $ W.tell mempty { sdOrderByClause = exprs } asc = EOrderBy ASC@@ -416,9 +477,10 @@ where toDistinctOn :: SqlExpr OrderBy -> SqlExpr DistinctOn toDistinctOn (EOrderBy _ f) = EDistinctOn f+ toDistinctOn EOrderRandom =+ error "We can't select distinct by a random order!" sub_select = sub SELECT- sub_selectDistinct = sub_select . distinct (^.) :: forall val typ. (PersistEntity val, PersistField typ) => SqlExpr (Entity val) -> EntityField val typ -> SqlExpr (Value typ)@@ -431,6 +493,14 @@ ed = entityDef $ getEntityVal (Proxy :: Proxy (SqlExpr (Entity val))) Just pdef = entityPrimary ed + withNonNull :: PersistField typ+ => SqlExpr (Value (Maybe typ))+ -> (SqlExpr (Value typ) -> SqlQuery a)+ -> SqlQuery a+ withNonNull field f = do+ where_ $ not_ $ isNothing field+ f $ veryUnsafeCoerceSqlExprValue field+ EMaybe r ?. field = just (r ^. field) val v = ERaw Never $ const ("?", [toPersistValue v])@@ -448,7 +518,7 @@ not_ (ERaw p f) = ERaw Never $ \info -> let (b, vals) = f info in ("NOT " <> parensM p b, vals)- not_ (ECompositeKey _) = unexpectedCompositeKeyError "not_"+ not_ (ECompositeKey _) = throw (CompositeKeyErr NotError) (==.) = unsafeSqlBinOpComposite " = " " AND " (!=.) = unsafeSqlBinOpComposite " != " " OR "@@ -488,7 +558,6 @@ castString = veryUnsafeCoerceSqlExprValue subList_select = EList . sub_select- subList_selectDistinct = subList_select . distinct valList [] = EEmptyList valList vals = EList $ ERaw Parens $ const ( uncommas ("?" <$ vals)@@ -514,13 +583,13 @@ field /=. expr = setAux field (\ent -> ent ^. field /. expr) (<#) _ (ERaw _ f) = EInsert Proxy f- (<#) _ (ECompositeKey _) = unexpectedCompositeKeyError "(<#)"+ (<#) _ (ECompositeKey _) = throw (CompositeKeyErr ToInsertionError) (EInsert _ f) <&> (ERaw _ g) = EInsert Proxy $ \x -> let (fb, fv) = f x (gb, gv) = g x in (fb <> ", " <> gb, fv ++ gv)- (EInsert _ _) <&> (ECompositeKey _) = unexpectedCompositeKeyError "(<&>)"+ (EInsert _ _) <&> (ECompositeKey _) = throw (CompositeKeyErr CombineInsertionError) case_ = unsafeSqlCase toBaseId = veryUnsafeCoerceSqlExprValue@@ -578,7 +647,7 @@ in ( "CASE" <> b2 <> " ELSE " <> parensM p1 b1 <> " END", vals2 <> vals1) mapWhen :: [(SqlExpr (Value Bool), SqlExpr (Value a))] -> IdentInfo -> (TLB.Builder, [PersistValue])- mapWhen [] _ = error "unsafeSqlCase: empty when list."+ mapWhen [] _ = throw (UnexpectedCaseErr UnsafeSqlCaseError) mapWhen when' info = foldl (foldHelp info) (mempty, mempty) when' foldHelp :: IdentInfo -> (TLB.Builder, [PersistValue]) -> (SqlExpr (Value Bool), SqlExpr (Value a)) -> (TLB.Builder, [PersistValue])@@ -586,8 +655,8 @@ let (b1, vals1) = f1' info (b2, vals2) = f2 info in ( b0 <> " WHEN " <> parensM p1' b1 <> " THEN " <> parensM p2 b2, vals0 <> vals1 <> vals2 )- foldHelp _ _ _ = unexpectedCompositeKeyError "unsafeSqlCase/foldHelp"-unsafeSqlCase _ (ECompositeKey _) = unexpectedCompositeKeyError "unsafeSqlCase"+ foldHelp _ _ _ = throw (CompositeKeyErr FoldHelpError)+unsafeSqlCase _ (ECompositeKey _) = throw (CompositeKeyErr SqlCaseError) -- | (Internal) Create a custom binary operator. You /should/@@ -609,7 +678,7 @@ (b2, vals2) = f2 info in ( parensM p1 b1 <> op <> parensM p2 b2 , vals1 <> vals2 )-unsafeSqlBinOp _ _ _ = unexpectedCompositeKeyError "unsafeSqlBinOp"+unsafeSqlBinOp _ _ _ = throw (CompositeKeyErr SqlBinOpError) {-# INLINE unsafeSqlBinOp #-} @@ -647,21 +716,18 @@ deconstruct :: (TLB.Builder, [PersistValue]) -> ([TLB.Builder], [PersistValue]) deconstruct ("?", [PersistList vals]) = (replicate (length vals) "?", vals) deconstruct (b', []) = (TLB.fromLazyText <$> TL.splitOn "," (TLB.toLazyText b'), [])- deconstruct x = err $ "cannot deconstruct " ++ show x ++ "."+ deconstruct _ = throw (SqlBinOpCompositeErr DeconstructionError) compose f1 f2 info- | not (null v1 || null v2) = err' "one side needs to have null placeholders"- | length b1 /= length b2 = err' "mismatching lengths"+ | not (null v1 || null v2) = throw (SqlBinOpCompositeErr NullPlaceholdersError)+ | length b1 /= length b2 = throw (SqlBinOpCompositeErr MismatchingLengthsError) | otherwise = (bc, vc) where (b1, v1) = f1 info (b2, v2) = f2 info bc = intersperseB sep [x <> op <> y | (x, y) <- zip b1 b2] vc = v1 <> v2- err' = err . (++ (", " ++ show ((b1, v1), (b2, v2)))) - err = error . ("unsafeSqlBinOpComposite: " ++)- -- | (Internal) A raw SQL value. The same warning from -- 'unsafeSqlBinOp' applies to this function as well. unsafeSqlValue :: TLB.Builder -> SqlExpr (Value a)@@ -701,6 +767,14 @@ uncommas' $ map (\(ERaw p f) -> first (parensM p) (f info)) $ toArgList arg in (name <> parens argsTLB, argsVals) +-- | (Internal) An explicit SQL type cast using CAST(value as type).+-- See 'unsafeSqlBinOp' for warnings.+unsafeSqlCastAs :: T.Text -> SqlExpr (Value a) -> SqlExpr (Value b)+unsafeSqlCastAs t (ERaw p f) =+ ERaw Never $ \info ->+ let (b, v) = f info+ in ("CAST" <> parens ( parensM p b <> " AS " <> TLB.fromText t), v )+unsafeSqlCastAs _ (ECompositeKey _) = throw (CompositeKeyErr SqlCastAsError) class UnsafeSqlFunctionArgument a where toArgList :: a -> [SqlExpr (Value ())]@@ -739,26 +813,26 @@ -- a)' to 'SqlExpr (Value a)'. Does not work with empty lists. veryUnsafeCoerceSqlExprValueList :: SqlExpr (ValueList a) -> SqlExpr (Value a) veryUnsafeCoerceSqlExprValueList (EList v) = v-veryUnsafeCoerceSqlExprValueList EEmptyList =- error "veryUnsafeCoerceSqlExprValueList: empty list."+veryUnsafeCoerceSqlExprValueList EEmptyList = throw (UnexpectedCaseErr EmptySqlExprValueList) ---------------------------------------------------------------------- - -- | (Internal) Execute an @esqueleto@ @SELECT@ 'SqlQuery' inside -- @persistent@'s 'SqlPersistT' monad. rawSelectSource :: ( SqlSelect a r , MonadIO m1- , MonadIO m2 )+ , MonadIO m2+ ) => Mode -> SqlQuery a- -> SqlReadT m1 (Acquire (C.Source m2 r))+ -> SqlReadT m1 (Acquire (C.ConduitT () r m2 ())) rawSelectSource mode query = do- conn <- persistBackend <$> R.ask- res <- run conn- return $ (C.$= massage) `fmap` res+ conn <- projectBackend <$> R.ask+ let _ = conn :: SqlBackend+ res <- R.withReaderT (const conn) (run conn)+ return $ (C..| massage) `fmap` res where run conn =@@ -779,9 +853,13 @@ -- | Execute an @esqueleto@ @SELECT@ query inside @persistent@'s -- 'SqlPersistT' monad and return a 'C.Source' of rows. selectSource :: ( SqlSelect a r- , MonadResource m )+ , BackendCompatible SqlBackend backend+ , IsPersistBackend backend+ , PersistQueryRead backend+ , PersistStoreRead backend, PersistUniqueRead backend+ , MonadResource m ) => SqlQuery a- -> C.Source (SqlPersistT m) r+ -> C.ConduitT () r (R.ReaderT backend m) () selectSource query = do res <- lift $ rawSelectSource SELECT query (key, src) <- lift $ allocateAcquire res@@ -830,40 +908,19 @@ -- function composition that the @p@ inside the query is of type -- @SqlExpr (Entity Person)@. select :: ( SqlSelect a r- , MonadIO m )+ , MonadIO m+ ) => SqlQuery a -> SqlReadT m [r] select query = do res <- rawSelectSource SELECT query conn <- R.ask liftIO $ with res $ flip R.runReaderT conn . runSource ---- | Execute an @esqueleto@ @SELECT DISTINCT@ query inside--- @persistent@'s 'SqlPersistT' monad and return a 'C.Source' of--- rows.-selectDistinctSource- :: ( SqlSelect a r- , MonadResource m )- => SqlQuery a- -> C.Source (SqlPersistT m) r-selectDistinctSource = selectSource . distinct-{-# DEPRECATED selectDistinctSource "Since 2.2.4: use 'selectSource' and 'distinct'." #-}----- | Execute an @esqueleto@ @SELECT DISTINCT@ query inside--- @persistent@'s 'SqlPersistT' monad and return a list of rows.-selectDistinct :: ( SqlSelect a r- , MonadIO m )- => SqlQuery a -> SqlPersistT m [r]-selectDistinct = select . distinct-{-# DEPRECATED selectDistinct "Since 2.2.4: use 'select' and 'distinct'." #-}-- -- | (Internal) Run a 'C.Source' of rows. runSource :: Monad m =>- C.Source (R.ReaderT backend m) r+ C.ConduitT () r (R.ReaderT backend m) () -> R.ReaderT backend m [r]-runSource src = src C.$$ CL.consume+runSource src = C.runConduit $ src C..| CL.consume ----------------------------------------------------------------------@@ -871,12 +928,12 @@ -- | (Internal) Execute an @esqueleto@ statement inside -- @persistent@'s 'SqlPersistT' monad.-rawEsqueleto :: ( MonadIO m, SqlSelect a r, IsSqlBackend backend)+rawEsqueleto :: ( MonadIO m, SqlSelect a r, BackendCompatible SqlBackend backend) => Mode -> SqlQuery a -> R.ReaderT backend m Int64 rawEsqueleto mode query = do- conn <- persistBackend <$> R.ask+ conn <- R.ask uncurry rawExecuteCount $ first builderToText $ toRawSql mode (conn, initialIdentState) query@@ -928,17 +985,23 @@ -- 'set' p [ PersonAge '=.' 'just' ('val' thisYear) -. p '^.' PersonBorn ] -- 'where_' $ isNothing (p '^.' PersonAge) -- @-update :: ( MonadIO m- , SqlEntity val )- => (SqlExpr (Entity val) -> SqlQuery ())- -> SqlWriteT m ()+update+ ::+ ( MonadIO m, PersistEntity val+ , BackendCompatible SqlBackend (PersistEntityBackend val)+ )+ => (SqlExpr (Entity val) -> SqlQuery ())+ -> SqlWriteT m () update = void . updateCount -- | Same as 'update', but returns the number of rows affected.-updateCount :: ( MonadIO m- , SqlEntity val )- => (SqlExpr (Entity val) -> SqlQuery ())- -> SqlWriteT m Int64+updateCount+ ::+ ( MonadIO m, PersistEntity val+ , BackendCompatible SqlBackend (PersistEntityBackend val)+ )+ => (SqlExpr (Entity val) -> SqlQuery ())+ -> SqlWriteT m Int64 updateCount = rawEsqueleto UPDATE . from @@ -958,7 +1021,7 @@ -- possible but tedious), you may just turn on query logging of -- @persistent@. toRawSql- :: (IsSqlBackend backend, SqlSelect a r)+ :: (SqlSelect a r, BackendCompatible SqlBackend backend) => Mode -> (backend, IdentState) -> SqlQuery a -> (TLB.Builder, [PersistValue]) toRawSql mode (conn, firstIdentState) query = let ((ret, sd), finalIdentState) =@@ -978,7 +1041,7 @@ -- that were used) to the subsequent calls. This ensures -- that no name clashes will occur on subqueries that may -- appear on the expressions below.- info = (persistBackend conn, finalIdentState)+ info = (projectBackend conn, finalIdentState) in mconcat [ makeInsertInto info mode ret , makeSelect info mode distinctClause ret@@ -1055,7 +1118,7 @@ , mk Parens rhs , maybe mempty makeOnClause monClause ]- mk _ (OnClause _) = error "Esqueleto/Sql/makeFrom: never here (is collectOnClauses working?)"+ mk _ (OnClause _) = throw (UnexpectedCaseErr MakeFromError) base ident@(I identText) def = let db@(DBName dbText) = entityDB def@@ -1071,29 +1134,25 @@ fromKind FullOuterJoinKind = " FULL OUTER JOIN " makeOnClause (ERaw _ f) = first (" ON " <>) (f info)- makeOnClause (ECompositeKey _) = unexpectedCompositeKeyError "makeFrom/makeOnClause"+ makeOnClause (ECompositeKey _) = throw (CompositeKeyErr MakeOnClauseError) mkExc :: SqlExpr (Value Bool) -> OnClauseWithoutMatchingJoinException mkExc (ERaw _ f) = OnClauseWithoutMatchingJoinException $ TL.unpack $ TLB.toLazyText $ fst (f info)- mkExc (ECompositeKey _) = unexpectedCompositeKeyError "makeFrom/mkExc"--unexpectedCompositeKeyError :: String -> a-unexpectedCompositeKeyError w = error $ w ++ ": non-id/composite keys not expected here"-+ mkExc (ECompositeKey _) = throw (CompositeKeyErr MakeExcError) makeSet :: IdentInfo -> [SetClause] -> (TLB.Builder, [PersistValue]) makeSet _ [] = mempty makeSet info os = first ("\nSET " <>) . uncommas' $ concatMap mk os where mk (SetClause (ERaw _ f)) = [f info]- mk (SetClause (ECompositeKey _)) = unexpectedCompositeKeyError "makeSet" -- FIXME+ mk (SetClause (ECompositeKey _)) = throw (CompositeKeyErr MakeSetError) -- FIXME makeWhere :: IdentInfo -> WhereClause -> (TLB.Builder, [PersistValue]) makeWhere _ NoWhere = mempty makeWhere info (Where (ERaw _ f)) = first ("\nWHERE " <>) (f info)-makeWhere _ (Where (ECompositeKey _)) = unexpectedCompositeKeyError "makeWhere"+makeWhere _ (Where (ECompositeKey _)) = throw (CompositeKeyErr MakeWhereError) makeGroupBy :: IdentInfo -> GroupByClause -> (TLB.Builder, [PersistValue])@@ -1110,12 +1169,13 @@ makeHaving :: IdentInfo -> WhereClause -> (TLB.Builder, [PersistValue]) makeHaving _ NoWhere = mempty makeHaving info (Where (ERaw _ f)) = first ("\nHAVING " <>) (f info)-makeHaving _ (Where (ECompositeKey _)) = unexpectedCompositeKeyError "makeHaving"+makeHaving _ (Where (ECompositeKey _)) = throw (CompositeKeyErr MakeHavingError) -- makeHaving, makeWhere and makeOrderBy-makeOrderBy :: IdentInfo -> [OrderByClause] -> (TLB.Builder, [PersistValue])-makeOrderBy _ [] = mempty-makeOrderBy info os = first ("\nORDER BY " <>) . uncommas' $ concatMap mk os+makeOrderByNoNewline ::+ IdentInfo -> [OrderByClause] -> (TLB.Builder, [PersistValue])+makeOrderByNoNewline _ [] = mempty+makeOrderByNoNewline info os = first ("ORDER BY " <>) . uncommas' $ concatMap mk os where mk :: OrderByClause -> [(TLB.Builder, [PersistValue])] mk (EOrderBy t (ERaw p f)) = [first ((<> orderByType t) . parensM p) (f info)]@@ -1127,7 +1187,14 @@ orderByType ASC = " ASC" orderByType DESC = " DESC" +makeOrderBy :: IdentInfo -> [OrderByClause] -> (TLB.Builder, [PersistValue])+makeOrderBy _ [] = mempty+makeOrderBy info is =+ let (tlb, vals) = makeOrderByNoNewline info is+ in ("\n" <> tlb, vals) +{-# DEPRECATED EOrderRandom "Since 2.6.0: `rand` ordering function is not uniform across all databases! To avoid accidental partiality it will be removed in the next major version." #-}+ makeLimit :: IdentInfo -> LimitClause -> [OrderByClause] -> (TLB.Builder, [PersistValue]) makeLimit (conn, _) (Limit ml mo) orderByClauses = let limitRaw = connLimitOffset conn (v ml, v mo) hasOrderClause "\n"@@ -1137,11 +1204,12 @@ makeLocking :: LockingClause -> (TLB.Builder, [PersistValue])-makeLocking = flip (,) [] . maybe mempty toTLB . getLast+makeLocking = flip (,) [] . maybe mempty toTLB . Monoid.getLast where- toTLB ForUpdate = "\nFOR UPDATE"- toTLB ForShare = "\nFOR SHARE"- toTLB LockInShareMode = "\nLOCK IN SHARE MODE"+ toTLB ForUpdate = "\nFOR UPDATE"+ toTLB ForUpdateSkipLocked = "\nFOR UPDATE SKIP LOCKED"+ toTLB ForShare = "\nFOR SHARE"+ toTLB LockInShareMode = "\nLOCK IN SHARE MODE" @@ -1172,7 +1240,7 @@ -- | Create @INSERT INTO@ clause instead. sqlInsertInto :: IdentInfo -> a -> (TLB.Builder, [PersistValue])- sqlInsertInto = error "Type does not support sqlInsertInto."+ sqlInsertInto = throw (UnexpectedCaseErr UnsupportedSqlInsertIntoType) -- | @INSERT INTO@ hack.@@ -1186,9 +1254,8 @@ in ("INSERT INTO " <> table <> parens fields <> "\n", []) sqlSelectCols info (EInsertFinal (EInsert _ f)) = f info sqlSelectColCount = const 0- sqlSelectProcessRow = const (Right (error msg))- where- msg = "sqlSelectProcessRow/SqlSelect/InsertionFinal: never here"+ sqlSelectProcessRow =+ const (Right (throw (UnexpectedCaseErr InsertionFinalError))) -- | Not useful for 'select', but used for 'update' and 'delete'.@@ -1755,10 +1822,3 @@ insertSelectCount :: (MonadIO m, PersistEntity a) => SqlQuery (SqlExpr (Insertion a)) -> SqlWriteT m Int64 insertSelectCount = rawEsqueleto INSERT_INTO . fmap EInsertFinal----- | Insert a 'PersistField' for every unique selected value.-insertSelectDistinct :: (MonadIO m, PersistEntity a) =>- SqlQuery (SqlExpr (Insertion a)) -> SqlWriteT m ()-insertSelectDistinct = insertSelect . distinct-{-# DEPRECATED insertSelectDistinct "Since 2.2.4: use 'insertSelect' and 'distinct'." #-}
+ src/Database/Esqueleto/MySQL.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE OverloadedStrings #-}+-- | This module contain MySQL-specific functions.+--+-- /Since: 2.2.8/+module Database.Esqueleto.MySQL+ ( random_+ ) where++import Database.Esqueleto.Internal.Language hiding (random_)+import Database.Esqueleto.Internal.PersistentImport+import Database.Esqueleto.Internal.Sql++-- | (@random()@) Split out into database specific modules+-- because MySQL uses `rand()`.+--+-- /Since: 2.6.0/+random_ :: (PersistField a, Num a) => SqlExpr (Value a)+random_ = unsafeSqlValue "RAND()"
src/Database/Esqueleto/PostgreSQL.hs view
@@ -1,36 +1,147 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings+ , GADTs, CPP #-} -- | This module contain PostgreSQL-specific functions. -- -- /Since: 2.2.8/ module Database.Esqueleto.PostgreSQL- ( arrayAgg+ ( AggMode(..)+ , arrayAggDistinct+ , arrayAgg+ , arrayAggWith+ , arrayRemove+ , arrayRemoveNull , stringAgg+ , stringAggWith+ , maybeArray , chr+ , now_+ , random_+ -- * Internal+ , unsafeSqlAggregateFunction ) where -import Database.Esqueleto.Internal.Language-import Database.Esqueleto.Internal.Sql+#if __GLASGOW_HASKELL__ < 804+import Data.Semigroup+#endif+import qualified Data.Text.Internal.Builder as TLB+import Data.Time.Clock (UTCTime)+import Database.Esqueleto.Internal.Language hiding (random_)+import Database.Esqueleto.Internal.PersistentImport+import Database.Esqueleto.Internal.Sql +-- | (@random()@) Split out into database specific modules+-- because MySQL uses `rand()`.+--+-- /Since: 2.6.0/+random_ :: (PersistField a, Num a) => SqlExpr (Value a)+random_ = unsafeSqlValue "RANDOM()" --- | (@array_agg@) Concatenate input values, including @NULL@s,--- into an array.+-- | Empty array literal. (@val []@) does unfortunately not work+emptyArray :: SqlExpr (Value [a])+emptyArray = unsafeSqlValue "'{}'"++-- | Coalesce an array with an empty default value+maybeArray ::+ (PersistField a, PersistField [a])+ => SqlExpr (Value (Maybe [a]))+ -> SqlExpr (Value [a])+maybeArray x = coalesceDefault [x] (emptyArray)++-- | Aggregate mode+data AggMode = AggModeAll -- ^ ALL+ | AggModeDistinct -- ^ DISTINCT+ deriving (Show)++-- | (Internal) Create a custom aggregate functions with aggregate mode ----- /Since: 2.2.8/-arrayAgg :: SqlExpr (Value a) -> SqlExpr (Value [a])-arrayAgg = unsafeSqlFunction "array_agg"+-- /Do/ /not/ use this function directly, instead define a new function and give+-- it a type (see `unsafeSqlBinOp`)+unsafeSqlAggregateFunction ::+ UnsafeSqlFunctionArgument a+ => TLB.Builder+ -> AggMode+ -> a+ -> [OrderByClause]+ -> SqlExpr (Value b)+unsafeSqlAggregateFunction name mode args orderByClauses =+ ERaw Never $ \info ->+ let (orderTLB, orderVals) = makeOrderByNoNewline info orderByClauses+ -- Don't add a space if we don't have order by clauses+ orderTLBSpace = case orderByClauses of+ [] -> ""+ (_:_) -> " "+ (argsTLB, argsVals) =+ uncommas' $ map (\(ERaw _ f) -> f info) $ toArgList args+ aggMode = case mode of+ AggModeAll -> "" -- ALL is the default, so we don't need to+ -- specify it+ AggModeDistinct -> "DISTINCT "+ in ( name <> parens (aggMode <> argsTLB <> orderTLBSpace <> orderTLB)+ , argsVals <> orderVals+ ) +--- | (@array_agg@) Concatenate input values, including @NULL@s,+--- into an array.+arrayAggWith ::+ AggMode+ -> SqlExpr (Value a)+ -> [OrderByClause]+ -> SqlExpr (Value (Maybe [a]))+arrayAggWith = unsafeSqlAggregateFunction "array_agg"++--- | (@array_agg@) Concatenate input values, including @NULL@s,+--- into an array.+arrayAgg :: (PersistField a) => SqlExpr (Value a) -> SqlExpr (Value (Maybe [a]))+arrayAgg x = arrayAggWith AggModeAll x []++-- | (@array_agg@) Concatenate distinct input values, including @NULL@s, into+-- an array.+--+-- /Since: 2.5.3/+arrayAggDistinct ::+ (PersistField a, PersistField [a])+ => SqlExpr (Value a)+ -> SqlExpr (Value (Maybe [a]))+arrayAggDistinct x = arrayAggWith AggModeDistinct x []+++-- | (@array_remove@) Remove all elements equal to the given value from the+-- array.+--+-- /Since: 2.5.3/+arrayRemove :: SqlExpr (Value [a]) -> SqlExpr (Value a) -> SqlExpr (Value [a])+arrayRemove arr elem' = unsafeSqlFunction "array_remove" (arr, elem')++-- | Remove @NULL@ values from an array+arrayRemoveNull :: SqlExpr (Value [Maybe a]) -> SqlExpr (Value [a])+-- This can't be a call to arrayRemove because it changes the value type+arrayRemoveNull x = unsafeSqlFunction "array_remove" (x, unsafeSqlValue "NULL")++ -- | (@string_agg@) Concatenate input values separated by a -- delimiter.+stringAggWith ::+ SqlString s+ => AggMode -- ^ Aggregate mode (ALL or DISTINCT)+ -> SqlExpr (Value s) -- ^ Input values.+ -> SqlExpr (Value s) -- ^ Delimiter.+ -> [OrderByClause] -- ^ ORDER BY clauses+ -> SqlExpr (Value (Maybe s)) -- ^ Concatenation.+stringAggWith mode expr delim os =+ unsafeSqlAggregateFunction "string_agg" mode (expr, delim) os++-- | (@string_agg@) Concatenate input values separated by a+-- delimiter. -- -- /Since: 2.2.8/-stringAgg- :: SqlString s+stringAgg ::+ SqlString s => SqlExpr (Value s) -- ^ Input values. -> SqlExpr (Value s) -- ^ Delimiter.- -> SqlExpr (Value s) -- ^ Concatenation.-stringAgg expr delim = unsafeSqlFunction "string_agg" (expr, delim)-+ -> SqlExpr (Value (Maybe s)) -- ^ Concatenation.+stringAgg expr delim = stringAggWith AggModeAll expr delim [] -- | (@chr@) Translate the given integer to a character. (Note the result will -- depend on the character set of your database.)@@ -38,3 +149,6 @@ -- /Since: 2.2.11/ chr :: SqlString s => SqlExpr (Value Int) -> SqlExpr (Value s) chr = unsafeSqlFunction "chr"++now_ :: SqlExpr (Value UTCTime)+now_ = unsafeSqlValue "NOW()"
+ src/Database/Esqueleto/SQLite.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE OverloadedStrings #-}+-- | This module contain SQLite-specific functions.+--+-- /Since: 2.2.8/+module Database.Esqueleto.SQLite+ ( random_+ ) where++import Database.Esqueleto.Internal.Language hiding (random_)+import Database.Esqueleto.Internal.PersistentImport+import Database.Esqueleto.Internal.Sql++-- | (@random()@) Split out into database specific modules+-- because MySQL uses `rand()`.+--+-- /Since: 2.6.0/+random_ :: (PersistField a, Num a) => SqlExpr (Value a)+random_ = unsafeSqlValue "RANDOM()"
+ test/Common/Test.hs view
@@ -0,0 +1,1470 @@+{-# OPTIONS_GHC -fno-warn-unused-binds #-}+{-# OPTIONS_GHC -fno-warn-deprecations #-}+{-# LANGUAGE ConstraintKinds+ , CPP+ , EmptyDataDecls+ , FlexibleContexts+ , FlexibleInstances+ , DeriveGeneric+ , GADTs+ , GeneralizedNewtypeDeriving+ , MultiParamTypeClasses+ , OverloadedStrings+ , QuasiQuotes+ , Rank2Types+ , TemplateHaskell+ , TypeFamilies+ , ScopedTypeVariables+ , TypeSynonymInstances+ #-}++module Common.Test+ ( tests+ , testLocking+ , testAscRandom+ , testRandomMath+ , migrateAll+ , cleanDB+ , RunDbMonad+ , Run+ , p1, p2, p3, p4, p5+ , l1, l2, l3+ , insert'+ , EntityField (..)+ , Foo (..)+ , Bar (..)+ , Person (..)+ , BlogPost (..)+ , Lord (..)+ , Deed (..)+ , Follow (..)+ , CcList (..)+ , Frontcover (..)+ , Article (..)+ , Tag (..)+ , ArticleTag (..)+ , Article2 (..)+ , Point (..)+ , Circle (..)+ , Numbers (..)+ ) where++import Control.Monad (forM_, replicateM, replicateM_, void)+#if __GLASGOW_HASKELL__ >= 806+import Control.Monad.Fail (MonadFail)+#endif+import Control.Monad.IO.Class (MonadIO(liftIO))+import Control.Monad.Logger (MonadLogger (..), NoLoggingT, runNoLoggingT)+import Control.Monad.Trans.Reader (ReaderT)+import Data.Char (toLower, toUpper)+import Data.Monoid ((<>))+import Database.Esqueleto+import Database.Persist.TH+import Test.Hspec+import UnliftIO++import Data.Conduit (ConduitT, (.|), runConduit)+import qualified Data.Conduit.List as CL+import Control.Monad.Trans.Resource (MonadThrow)+import qualified Data.List as L+import qualified Data.Set as S+import qualified Data.Text.Lazy.Builder as TLB+import qualified Data.Text.Internal.Lazy as TL+import qualified Database.Esqueleto.Internal.Sql as EI+import qualified UnliftIO.Resource as R++++-- Test schema+share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|+ Foo+ name Int+ Primary name+ Bar+ quux FooId++ Person+ name String+ age Int Maybe+ weight Int Maybe+ favNum Int+ deriving Eq Show+ BlogPost+ title String+ authorId PersonId+ deriving Eq Show++ Lord+ county String maxlen=100+ dogs Int Maybe+ Primary county+ deriving Show++ Deed+ contract String maxlen=100+ ownerId LordId maxlen=100+ Primary contract+ deriving 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+ 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+|]+++++-- | 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)++++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) ]+++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 "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]++++testSelectWhere :: Run -> Spec+testSelectWhere run = do+ describe "select/where_" $ do+ it "works for a simple example with (==.)" $+ run $ do+ p1e <- insert' p1+ _ <- insert' p2+ _ <- insert' p3+ ret <- select $+ from $ \p -> do+ where_ (p ^. PersonName ==. val "John")+ return p+ liftIO $ ret `shouldBe` [ p1e ]++ it "works for a simple example with (==.) and (||.)" $+ run $ do+ p1e <- insert' p1+ p2e <- insert' p2+ _ <- insert' p3+ ret <- select $+ from $ \p -> do+ where_ (p ^. PersonName ==. val "John" ||. p ^. PersonName ==. val "Rachel")+ return p+ liftIO $ ret `shouldBe` [ p1e, p2e ]++ it "works for a simple example with (>.) [uses val . Just]" $+ run $ do+ p1e <- insert' p1+ _ <- insert' p2+ _ <- insert' p3+ ret <- select $+ from $ \p -> do+ where_ (p ^. PersonAge >. val (Just 17))+ return p+ liftIO $ ret `shouldBe` [ p1e ]++ it "works for a simple example with (>.) and not_ [uses just . val]" $+ run $ do+ _ <- insert' p1+ _ <- insert' p2+ p3e <- insert' p3+ ret <- select $+ from $ \p -> do+ where_ (not_ $ p ^. PersonAge >. just (val 17))+ return p+ liftIO $ ret `shouldBe` [ p3e ]++ 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 with LEFT OUTER JOINs" $+ run $ do+ p1e@(Entity p1k _) <- insert' p1+ p2e@(Entity p2k _) <- insert' p2+ p3e <- insert' p3+ p4e@(Entity p4k _) <- insert' p4+ f12 <- insert' (Follow p1k p2k)+ f21 <- insert' (Follow p2k p1k)+ f42 <- insert' (Follow p4k p2k)+ f11 <- insert' (Follow p1k p1k)+ ret <- select $+ from $ \(follower `LeftOuterJoin` mfollows `LeftOuterJoin` mfollowed) -> do+ on $ mfollowed ?. PersonId ==. mfollows ?. FollowFollowed+ on $ just (follower ^. PersonId) ==. mfollows ?. FollowFollower+ orderBy [ asc ( follower ^. PersonName)+ , asc (mfollowed ?. PersonName) ]+ return (follower, mfollows, mfollowed)+ liftIO $ ret `shouldBe` [ (p1e, Just f11, Just p1e)+ , (p1e, Just f12, Just p2e)+ , (p4e, Just f42, Just p2e)+ , (p3e, Nothing, Nothing)+ , (p2e, Just f21, Just p1e) ]++ it "works with a composite primary key" $+ run $ do+ let p = Point x y ""+ x = 10+ y = 15+ Right thePk = keyFromValues [toPersistValue x, toPersistValue y]+ pPk <- insert p+ [Entity _ ret] <- select $ from $ \p' -> do+ where_ (p'^.PointId ==. val pPk)+ return p'+ liftIO $ do+ ret `shouldBe` p+ pPk `shouldBe` thePk++++testSelectOrderBy :: Run -> Spec+testSelectOrderBy run = do+ describe "select/orderBy" $ do+ it "works with a single ASC field" $+ run $ do+ p1e <- insert' p1+ p2e <- insert' p2+ p3e <- insert' p3+ ret <- select $+ from $ \p -> do+ orderBy [asc $ p ^. PersonName]+ return p+ liftIO $ ret `shouldBe` [ p1e, p3e, p2e ]++ it "works with a sub_select" $+ run $ do+ [p1k, p2k, p3k, p4k] <- mapM insert [p1, p2, p3, p4]+ [b1k, b2k, b3k, b4k] <- mapM (insert . BlogPost "") [p1k, p2k, p3k, p4k]+ ret <- select $+ from $ \b -> do+ orderBy [desc $ sub_select $+ from $ \p -> do+ where_ (p ^. PersonId ==. b ^. BlogPostAuthorId)+ return (p ^. PersonName)+ ]+ return (b ^. BlogPostId)+ liftIO $ ret `shouldBe` (Value <$> [b2k, b3k, b4k, b1k])++ it "works on a composite primary key" $+ run $ do+ let ps = [Point 2 1 "", Point 1 2 ""]+ mapM_ insert ps+ eps <- select $+ from $ \p' -> do+ orderBy [asc (p'^.PointId)]+ return p'+ liftIO $ map entityVal eps `shouldBe` reverse ps++testAscRandom :: SqlExpr (Value Double) -> Run -> Spec+testAscRandom rand' run =+ describe "random_" $+ it "asc random_ works" $+ run $ do+ _p1e <- insert' p1+ _p2e <- insert' p2+ _p3e <- insert' p3+ _p4e <- insert' p4+ rets <-+ fmap S.fromList $+ replicateM 11 $+ select $+ from $ \p -> do+ orderBy [asc (rand' :: SqlExpr (Value Double))]+ return (p ^. PersonId :: SqlExpr (Value PersonId))+ -- There are 2^4 = 16 possible orderings. The chance+ -- of 11 random samplings returning the same ordering+ -- is 1/2^40, so this test should pass almost everytime.+ liftIO $ S.size rets `shouldSatisfy` (>2)++testSelectDistinct :: Run -> Spec+testSelectDistinct run = do+ describe "SELECT DISTINCT" $ do+ let selDistTest+ :: ( forall m. RunDbMonad m+ => SqlQuery (SqlExpr (Value String))+ -> SqlPersistT (R.ResourceT m) [Value String])+ -> IO ()+ selDistTest q = run $ do+ p1k <- insert p1+ let (t1, t2, t3) = ("a", "b", "c")+ mapM_ (insert . flip BlogPost p1k) [t1, t3, t2, t2, t1]+ ret <- q $+ from $ \b -> do+ let title = b ^. BlogPostTitle+ orderBy [asc title]+ return title+ liftIO $ ret `shouldBe` [ Value t1, Value t2, Value t3 ]++ it "works on a simple example (select . distinct)" $+ selDistTest (select . distinct)++ it "works on a simple example (distinct (return ()))" $+ selDistTest (\act -> select $ distinct (return ()) >> act)++++testCoasleceDefault :: Run -> Spec+testCoasleceDefault run = do+ describe "coalesce/coalesceDefault" $ do+ it "works on a simple example" $+ run $ do+ mapM_ insert' [p1, p2, p3, p4, p5]+ ret1 <- select $+ from $ \p -> do+ orderBy [asc (p ^. PersonId)]+ return (coalesce [p ^. PersonAge, p ^. PersonWeight])+ liftIO $ ret1 `shouldBe` [ Value (Just (36 :: Int))+ , Value (Just 37)+ , Value (Just 17)+ , Value (Just 17)+ , Value Nothing+ ]++ ret2 <- select $+ from $ \p -> do+ orderBy [asc (p ^. PersonId)]+ return (coalesceDefault [p ^. PersonAge, p ^. PersonWeight] (p ^. PersonFavNum))+ liftIO $ ret2 `shouldBe` [ Value (36 :: Int)+ , Value 37+ , Value 17+ , Value 17+ , Value 5+ ]++ it "works with sub-queries" $+ run $ do+ p1id <- insert p1+ p2id <- insert p2+ p3id <- insert p3+ _ <- insert p4+ _ <- insert p5+ _ <- insert $ BlogPost "a" p1id+ _ <- insert $ BlogPost "b" p2id+ _ <- insert $ BlogPost "c" p3id+ ret <- select $+ from $ \b -> do+ let sub =+ from $ \p -> do+ where_ (p ^. PersonId ==. b ^. BlogPostAuthorId)+ return $ p ^. PersonAge+ return $ coalesceDefault [sub_select sub] (val (42 :: Int))+ liftIO $ ret `shouldBe` [ Value (36 :: Int)+ , Value 42+ , Value 17+ ]++++testDelete :: Run -> Spec+testDelete run = do+ describe "delete" $+ it "works on a simple example" $+ run $ do+ p1e <- insert' p1+ p2e <- insert' p2+ p3e <- insert' p3+ let getAll = select $+ from $ \p -> do+ orderBy [asc (p ^. PersonName)]+ return p+ ret1 <- getAll+ liftIO $ ret1 `shouldBe` [ p1e, p3e, p2e ]+ () <- delete $+ from $ \p ->+ where_ (p ^. PersonName ==. val (personName p1))+ ret2 <- getAll+ liftIO $ ret2 `shouldBe` [ p3e, p2e ]+ n <- deleteCount $+ from $ \p ->+ return ((p :: SqlExpr (Entity Person)) `seq` ())+ ret3 <- getAll+ liftIO $ (n, ret3) `shouldBe` (2, [])++++testUpdate :: Run -> Spec+testUpdate run = do+ describe "update" $ do++ it "works with a subexpression having COUNT(*)" $+ run $ do+ p1k <- insert p1+ p2k <- insert p2+ p3k <- insert p3+ replicateM_ 3 (insert $ BlogPost "" p1k)+ replicateM_ 7 (insert $ BlogPost "" p3k)+ let blogPostsBy p =+ from $ \b -> do+ where_ (b ^. BlogPostAuthorId ==. p ^. PersonId)+ return countRows+ () <- update $ \p -> do+ set p [ PersonAge =. just (sub_select (blogPostsBy p)) ]+ ret <- select $+ from $ \p -> do+ orderBy [ asc (p ^. PersonName) ]+ return p+ liftIO $ ret `shouldBe` [ Entity p1k p1 { personAge = Just 3 }+ , Entity p3k p3 { personAge = Just 7 }+ , Entity p2k p2 { personAge = Just 0 } ]++ it "works with a composite primary key" $+ pendingWith "Need refactor to support composite pks on ESet"+ {-+ run $ do+ let p = Point x y ""+ x = 10+ y = 15+ newX = 20+ newY = 25+ Right newPk = keyFromValues [toPersistValue newX, toPersistValue newY]+ insert_ p+ () <- update $ \p' -> do+ set p' [PointId =. val newPk]+ [Entity _ ret] <- select $ from $ return+ liftIO $ do+ ret `shouldBe` Point newX newY []+ -}++ it "GROUP BY works with COUNT" $+ run $ do+ p1k <- insert p1+ p2k <- insert p2+ p3k <- insert p3+ replicateM_ 3 (insert $ BlogPost "" p1k)+ replicateM_ 7 (insert $ BlogPost "" p3k)+ ret <- select $+ from $ \(p `LeftOuterJoin` b) -> do+ on (p ^. PersonId ==. b ^. BlogPostAuthorId)+ groupBy (p ^. PersonId)+ let cnt = count (b ^. BlogPostId)+ orderBy [ asc cnt ]+ return (p, cnt)+ liftIO $ ret `shouldBe` [ (Entity p2k p2, Value (0 :: Int))+ , (Entity p1k p1, Value 3)+ , (Entity p3k p3, Value 7) ]++ it "GROUP BY works with COUNT and InnerJoin" $+ run $ do+ l1k <- insert l1+ l3k <- insert l3+ mapM_ (\k -> insert $ Deed k l1k) (map show [1..3 :: Int])++ mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int])++ (ret :: [(Value (Key Lord), Value Int)]) <- select $ from $+ \ ( lord `InnerJoin` deed ) -> do+ on $ lord ^. LordId ==. deed ^. DeedOwnerId+ groupBy (lord ^. LordId)+ return (lord ^. LordId, count $ deed ^. DeedId)+ liftIO $ ret `shouldMatchList` [ (Value l3k, Value 7)+ , (Value l1k, Value 3) ]++ it "GROUP BY works with HAVING" $+ run $ do+ p1k <- insert p1+ _p2k <- insert p2+ p3k <- insert p3+ replicateM_ 3 (insert $ BlogPost "" p1k)+ replicateM_ 7 (insert $ BlogPost "" p3k)+ ret <- select $+ from $ \(p `LeftOuterJoin` b) -> do+ on (p ^. PersonId ==. b ^. BlogPostAuthorId)+ let cnt = count (b ^. BlogPostId)+ groupBy (p ^. PersonId)+ having (cnt >. (val 0))+ orderBy [ asc cnt ]+ return (p, cnt)+ liftIO $ ret `shouldBe` [ (Entity p1k p1, Value (3 :: Int))+ , (Entity p3k p3, Value 7) ]+++-- we only care that this compiles. check that SqlWriteT doesn't fail on+-- updates.+testSqlWriteT :: MonadIO m => SqlWriteT m ()+testSqlWriteT =+ update $ \p -> do+ set p [ PersonAge =. just (val 6) ]++-- we only care that this compiles. checks that the SqlWriteT monad can run+-- select queries.+testSqlWriteTRead :: MonadIO m => SqlWriteT m [(Value (Key Lord), Value Int)]+testSqlWriteTRead =+ select $+ from $ \ ( lord `InnerJoin` deed ) -> do+ on $ lord ^. LordId ==. deed ^. DeedOwnerId+ groupBy (lord ^. LordId)+ return (lord ^. LordId, count $ deed ^. DeedId)++-- we only care that this compiles checks that SqlReadT allows+testSqlReadT :: MonadIO m => SqlReadT m [(Value (Key Lord), Value Int)]+testSqlReadT =+ select $+ from $ \ ( lord `InnerJoin` deed ) -> do+ on $ lord ^. LordId ==. deed ^. DeedOwnerId+ groupBy (lord ^. LordId)+ return (lord ^. LordId, count $ deed ^. DeedId)++testListOfValues :: Run -> Spec+testListOfValues run = do+ describe "lists of values" $ do+ it "IN works for valList" $+ run $ do+ p1k <- insert p1+ p2k <- insert p2+ _p3k <- insert p3+ ret <- select $+ from $ \p -> do+ where_ (p ^. PersonName `in_` valList (personName <$> [p1, p2]))+ return p+ liftIO $ ret `shouldBe` [ Entity p1k p1+ , Entity p2k p2 ]++ it "IN works for valList (null list)" $+ run $ do+ _p1k <- insert p1+ _p2k <- insert p2+ _p3k <- insert p3+ ret <- select $+ from $ \p -> do+ where_ (p ^. PersonName `in_` valList [])+ return p+ liftIO $ ret `shouldBe` []++ it "IN works for subList_select" $+ run $ do+ p1k <- insert p1+ _p2k <- insert p2+ p3k <- insert p3+ _ <- insert (BlogPost "" p1k)+ _ <- insert (BlogPost "" p3k)+ ret <- select $+ from $ \p -> do+ let subquery =+ from $ \bp -> do+ orderBy [ asc (bp ^. BlogPostAuthorId) ]+ return (bp ^. BlogPostAuthorId)+ where_ (p ^. PersonId `in_` subList_select subquery)+ return p+ liftIO $ ret `shouldBe` [ Entity p1k p1+ , Entity p3k p3 ]++ it "NOT IN works for subList_select" $+ run $ do+ p1k <- insert p1+ p2k <- insert p2+ p3k <- insert p3+ _ <- insert (BlogPost "" p1k)+ _ <- insert (BlogPost "" p3k)+ ret <- select $+ from $ \p -> do+ let subquery =+ from $ \bp ->+ return (bp ^. BlogPostAuthorId)+ where_ (p ^. PersonId `notIn` subList_select subquery)+ return p+ liftIO $ ret `shouldBe` [ Entity p2k p2 ]++ it "EXISTS works for subList_select" $+ run $ do+ p1k <- insert p1+ _p2k <- insert p2+ p3k <- insert p3+ _ <- insert (BlogPost "" p1k)+ _ <- insert (BlogPost "" p3k)+ ret <- select $+ from $ \p -> do+ where_ $ exists $+ from $ \bp -> do+ where_ (bp ^. BlogPostAuthorId ==. p ^. PersonId)+ orderBy [asc (p ^. PersonName)]+ return p+ liftIO $ ret `shouldBe` [ Entity p1k p1+ , Entity p3k p3 ]++ it "EXISTS works for subList_select" $+ run $ do+ p1k <- insert p1+ p2k <- insert p2+ p3k <- insert p3+ _ <- insert (BlogPost "" p1k)+ _ <- insert (BlogPost "" p3k)+ ret <- select $+ from $ \p -> do+ where_ $ notExists $+ from $ \bp -> do+ where_ (bp ^. BlogPostAuthorId ==. p ^. PersonId)+ return p+ liftIO $ ret `shouldBe` [ Entity p2k p2 ]++++++testListFields :: Run -> Spec+testListFields run = do+ describe "list fields" $ do+ -- <https://github.com/prowdsponsor/esqueleto/issues/100>+ it "can update list fields" $+ run $ do+ cclist <- insert $ CcList []+ update $ \p -> do+ set p [ CcListNames =. val ["fred"]]+ where_ (p ^. CcListId ==. val cclist)++++++testInsertsBySelect :: Run -> Spec+testInsertsBySelect run = do+ describe "inserts by select" $ do+ it "IN works for insertSelect" $+ run $ do+ _ <- insert p1+ _ <- insert p2+ _ <- insert p3+ insertSelect $ from $ \p -> do+ return $ BlogPost <# val "FakePost" <&> (p ^. PersonId)+ ret <- select $ from (\(_::(SqlExpr (Entity BlogPost))) -> return countRows)+ liftIO $ ret `shouldBe` [Value (3::Int)]++++++testInsertsBySelectReturnsCount :: Run -> Spec+testInsertsBySelectReturnsCount run = do+ describe "inserts by select, returns count" $ do+ it "IN works for insertSelectCount" $+ run $ do+ _ <- insert p1+ _ <- insert p2+ _ <- insert p3+ cnt <- insertSelectCount $ from $ \p -> do+ return $ BlogPost <# val "FakePost" <&> (p ^. PersonId)+ ret <- select $ from (\(_::(SqlExpr (Entity BlogPost))) -> return countRows)+ liftIO $ ret `shouldBe` [Value (3::Int)]+ liftIO $ cnt `shouldBe` 3+++++testRandomMath :: Run -> Spec+testRandomMath run = describe "random_ math" $+ it "rand returns result in random order" $+ run $ do+ replicateM_ 20 $ do+ _ <- insert p1+ _ <- insert p2+ _ <- insert p3+ _ <- insert p4+ _ <- insert $ Person "Jane" Nothing Nothing 0+ _ <- insert $ Person "Mark" Nothing Nothing 0+ _ <- insert $ Person "Sarah" Nothing Nothing 0+ insert $ Person "Paul" Nothing Nothing 0+ ret1 <- fmap (map unValue) $ select $ from $ \p -> do+ orderBy [rand]+ return (p ^. PersonId)+ ret2 <- fmap (map unValue) $ select $ from $ \p -> do+ orderBy [rand]+ return (p ^. PersonId)++ liftIO $ (ret1 == ret2) `shouldBe` False++testMathFunctions :: Run -> Spec+testMathFunctions run = do+ describe "Math-related functions" $ do+ it "castNum works for multiplying Int and Double" $+ run $ do+ mapM_ insert [Numbers 2 3.4, Numbers 7 1.1]+ ret <-+ select $+ from $ \n -> do+ let r = castNum (n ^. NumbersInt) *. n ^. NumbersDouble+ orderBy [asc r]+ return r+ liftIO $ length ret `shouldBe` 2+ let [Value a, Value b] = ret+ liftIO $ max (abs (a - 6.8)) (abs (b - 7.7)) `shouldSatisfy` (< 0.01)++++++testCase :: Run -> Spec+testCase run = do+ describe "case" $ do+ it "Works for a simple value based when - False" $+ run $ do+ ret <- select $+ return $+ case_+ [ when_ (val False) then_ (val (1 :: Int)) ]+ (else_ (val 2))++ liftIO $ ret `shouldBe` [ Value 2 ]++ it "Works for a simple value based when - True" $+ run $ do+ ret <- select $+ return $+ case_+ [ when_ (val True) then_ (val (1 :: Int)) ]+ (else_ (val 2))++ liftIO $ ret `shouldBe` [ Value 1 ]++ it "works for a semi-complicated query" $+ run $ do+ _ <- insert p1+ _ <- insert p2+ _ <- insert p3+ _ <- insert p4+ _ <- insert p5+ ret <- select $+ return $+ case_+ [ when_+ (exists $ from $ \p -> do+ where_ (p ^. PersonName ==. val "Mike"))+ then_+ (sub_select $ from $ \v -> do+ let sub =+ from $ \c -> do+ where_ (c ^. PersonName ==. val "Mike")+ return (c ^. PersonFavNum)+ where_ (v ^. PersonFavNum >. sub_select sub)+ return $ count (v ^. PersonName) +. val (1 :: Int)) ]+ (else_ $ val (-1))++ liftIO $ ret `shouldBe` [ Value (3) ]++++++testLocking :: WithConn (NoLoggingT IO) [TL.Text] -> Spec+testLocking withConn = do+ describe "locking" $ do+ -- The locking clause is the last one, so try to use many+ -- others to test if it's at the right position. We don't+ -- care about the text of the rest, nor with the RDBMS'+ -- reaction to the clause.+ let sanityCheck kind syntax = do+ let complexQuery =+ from $ \(p1' `InnerJoin` p2') -> do+ on (p1' ^. PersonName ==. p2' ^. PersonName)+ where_ (p1' ^. PersonFavNum >. val 2)+ orderBy [desc (p2' ^. PersonAge)]+ limit 3+ offset 9+ groupBy (p1' ^. PersonId)+ having (countRows <. val (0 :: Int))+ return (p1', p2')+ queryWithClause1 = do+ r <- complexQuery+ locking kind+ return r+ queryWithClause2 = do+ locking ForUpdate+ r <- complexQuery+ locking ForShare+ locking kind+ return r+ queryWithClause3 = do+ locking kind+ complexQuery+ toText conn q =+ let (tlb, _) = EI.toRawSql EI.SELECT (conn, EI.initialIdentState) q+ in TLB.toLazyText tlb+ [complex, with1, with2, with3] <-+ runNoLoggingT $ withConn $ \conn -> return $+ map (toText conn) [complexQuery, queryWithClause1, queryWithClause2, queryWithClause3]+ let expected = complex <> "\n" <> syntax+ (with1, with2, with3) `shouldBe` (expected, expected, expected)++ it "looks sane for ForUpdate" $ sanityCheck ForUpdate "FOR UPDATE"+ it "looks sane for ForUpdateSkipLocked" $ sanityCheck ForUpdateSkipLocked "FOR UPDATE SKIP LOCKED"+ it "looks sane for ForShare" $ sanityCheck ForShare "FOR SHARE"+ it "looks sane for LockInShareMode" $ sanityCheck LockInShareMode "LOCK IN SHARE MODE"++++++testCountingRows :: Run -> Spec+testCountingRows run = do+ describe "counting rows" $ do+ forM_ [ ("count (test A)", count . (^. PersonAge), 4)+ , ("count (test B)", count . (^. PersonWeight), 5)+ , ("countRows", const countRows, 5)+ , ("countDistinct", countDistinct . (^. PersonAge), 2) ] $+ \(title, countKind, expected) ->+ it (title ++ " works as expected") $+ run $ do+ mapM_ insert+ [ Person "" (Just 1) (Just 1) 1+ , Person "" (Just 2) (Just 1) 1+ , Person "" (Just 2) (Just 1) 1+ , Person "" (Just 2) (Just 2) 1+ , Person "" Nothing (Just 3) 1]+ [Value n] <- select $ from $ return . countKind+ liftIO $ (n :: Int) `shouldBe` expected++++++tests :: Run -> Spec+tests run = do+ describe "Tests that are common to all backends" $ do+ testSelect run+ testSelectSource run+ testSelectFrom run+ testSelectJoin 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+++++insert' :: ( Functor m+ , BaseBackend backend ~ PersistEntityBackend val+ , PersistStore backend+ , MonadIO m+ , PersistEntity val )+ => val -> ReaderT backend m (Entity val)+insert' v = flip Entity v <$> insert v+++type RunDbMonad m = ( MonadUnliftIO m+ , MonadIO m+ , MonadLogger m+ , MonadThrow 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 Foo)) -> return ()+ delete $ from $ \(_ :: SqlExpr (Entity Bar)) -> 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 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 ()
+ test/MySQL/Test.hs view
@@ -0,0 +1,218 @@+{-# LANGUAGE ScopedTypeVariables+ , FlexibleContexts+ , RankNTypes+ , TypeFamilies+#-}++module Main (main) where++import Control.Monad (void)+import Control.Monad.IO.Class (MonadIO(liftIO))+import Control.Monad.Logger (runStderrLoggingT, runNoLoggingT)+import Control.Monad.Trans.Reader (ReaderT)+import Database.Persist.MySQL ( withMySQLConn+ , connectHost+ , connectDatabase+ , connectUser+ , connectPassword+ , defaultConnectInfo)+import Database.Esqueleto+import qualified Control.Monad.Trans.Resource as R+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 = 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 :: Double ) ]+++++testMysqlTwoAscFields :: Spec+testMysqlTwoAscFields = 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+ liftIO $ ret `shouldBe` [ p2e, p4e, p3e, p1e ]+++++testMysqlOneAscOneDesc :: Spec+testMysqlOneAscOneDesc = 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 ]+++++testMysqlCoalesce :: Spec+testMysqlCoalesce = do+ it "works on PostgreSQL and MySQL with <2 arguments" $+ run $ do+ _ :: [Value (Maybe Int)] <-+ select $+ from $ \p -> do+ return (coalesce [p ^. PersonAge])+ return ()+++++testMysqlUpdate :: Spec+testMysqlUpdate = 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+ -- MySQL: nulls appear first, and update returns actual number+ -- of changed rows+ liftIO $ n `shouldBe` 1+ 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,+ Esqueleto query expr backend, MonadIO m, SqlString s,+ IsPersistBackend backend, PersistQueryRead backend,+ PersistUniqueRead backend)+ => (SqlExpr (Value [Char])+ -> expr (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)+ (concat_ [(%), val t, (%)]))+ orderBy [asc (p ^. PersonName)]+ return p+ liftIO $ ret `shouldBe` expected+++testMysqlTextFunctions :: Spec+testMysqlTextFunctions = 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 "Test MySQL locking" $ do+ testLocking withConn++ describe "MySQL specific tests" $ do+ -- definitely doesn't work at the moment+ -- testMysqlRandom+ testMysqlSum+ testMysqlTwoAscFields+ testMysqlOneAscOneDesc+ testMysqlCoalesce+ testMysqlUpdate+ testMysqlTextFunctions+++++run, runSilent, runVerbose :: Run+runSilent act = runNoLoggingT $ run_worker act+runVerbose act = runStderrLoggingT $ run_worker act+run =+ if verbose+ then runVerbose+ else runSilent+++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+ cleanDB+++withConn :: RunDbMonad m => (SqlBackend -> R.ResourceT m a) -> m a+withConn =+ R.runResourceT .+ withMySQLConn defaultConnectInfo+ { connectHost = "localhost"+ , connectUser = "travis"+ , connectPassword = ""+ , connectDatabase = "esqutest"+ }
+ test/PostgreSQL/Test.hs view
@@ -0,0 +1,564 @@+{-# OPTIONS_GHC -fno-warn-unused-binds #-}+{-# LANGUAGE ScopedTypeVariables+ , FlexibleContexts+ , RankNTypes+ , TypeFamilies+ , OverloadedStrings+ , LambdaCase+ #-}+module Main (main) where++import Control.Arrow ((&&&))+import Control.Monad (void)+import Control.Monad.IO.Class (MonadIO(liftIO))+import Control.Monad.Logger (runStderrLoggingT, runNoLoggingT)+import Control.Monad.Trans.Reader (ReaderT, ask)+import qualified Control.Monad.Trans.Resource as R+import qualified Data.Char as Char+import qualified Data.List as L+import Data.Ord (comparing)+import qualified Data.Text as T+import Data.Time.Clock (getCurrentTime, diffUTCTime)+import Database.Esqueleto hiding (random_)+import qualified Database.Esqueleto.Internal.Sql as ES+import Database.Esqueleto.PostgreSQL (random_)+import qualified Database.Esqueleto.PostgreSQL as EP+import Database.Persist.Postgresql (withPostgresqlConn)+import System.Environment+import Test.Hspec++import Common.Test+++++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,+ Esqueleto query expr backend, MonadIO m, SqlString s,+ IsPersistBackend backend, PersistQueryRead backend,+ PersistUniqueRead backend)+ => (SqlExpr (Value [Char])+ -> expr (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 "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 "works with now" $+ run $ do+ nowDb <- select $ return EP.now_+ nowUtc <- liftIO getCurrentTime+ let halfSecond = realToFrac (0.5 :: 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 half a second+ liftIO $ diffUTCTime nowUtc now `shouldSatisfy` (< halfSecond)++++++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++++++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++migrateIt :: RunDbMonad m => SqlPersistT (R.ResourceT m) ()+migrateIt = do+ void $ runMigrationSilent migrateAll+ cleanDB++run_worker :: RunDbMonad m => SqlPersistT (R.ResourceT m) a -> m a+run_worker act = withConn $ runSqlConn (migrateIt >> act)++withConn :: RunDbMonad m => (SqlBackend -> R.ResourceT m a) -> m a+withConn =+ R.runResourceT . withPostgresqlConn "host=localhost port=5432 user=esqutest password=esqutest dbname=esqutest"++-- | Show the SQL generated by a query+showQuery :: (Monad m, ES.SqlSelect a r, BackendCompatible SqlBackend backend)+ => ES.Mode -> SqlQuery a -> ReaderT backend m (T.Text, [PersistValue])+showQuery mode query = do+ backend <- ask+ let (builder, values) = ES.toRawSql mode (backend, ES.initialIdentState) query+ return (ES.builderToText builder, values)
+ test/SQLite/Test.hs view
@@ -0,0 +1,215 @@+{-# LANGUAGE ScopedTypeVariables+ , FlexibleContexts+ , RankNTypes+ , TypeFamilies+ , OverloadedStrings+#-}++module Main (main) where++import Control.Monad (void)+import Control.Monad.IO.Class (MonadIO(liftIO))+import Control.Monad.Logger (runStderrLoggingT, runNoLoggingT)+import Control.Monad.Trans.Reader (ReaderT)+import Database.Persist.Sqlite (withSqliteConn)+import Database.Sqlite (SqliteException)+import Database.Esqueleto hiding (random_)+import Database.Esqueleto.SQLite (random_)+import qualified Control.Monad.Trans.Resource as R+import Test.Hspec++import Common.Test+++++testSqliteRandom :: Spec+testSqliteRandom = do+ it "works with random_" $+ run $ do+ _ <- select $ return (random_ :: SqlExpr (Value Int))+ return ()++++++testSqliteSum :: Spec+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) ]++++++testSqliteTwoAscFields :: Spec+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 ]++++++testSqliteOneAscOneDesc :: Spec+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 ]++++++testSqliteCoalesce :: Spec+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)++++++testSqliteUpdate :: Spec+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,+ Esqueleto query expr backend, MonadIO m, SqlString s,+ IsPersistBackend backend, PersistQueryRead backend,+ PersistUniqueRead backend)+ => (SqlExpr (Value [Char])+ -> expr (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++testSqliteTextFunctions :: Spec+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 "Test SQLite locking" $ do+ testLocking withConn++ describe "SQLite specific tests" $ do+ testAscRandom random_ run+ testRandomMath run+ testSqliteRandom+ testSqliteSum+ testSqliteTwoAscFields+ testSqliteOneAscOneDesc+ testSqliteCoalesce+ 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+++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+++withConn :: RunDbMonad m => (SqlBackend -> R.ResourceT m a) -> m a+withConn =+ R.runResourceT . withSqliteConn ":memory:"
− test/Test.hs
@@ -1,1541 +0,0 @@-{-# OPTIONS_GHC -fno-warn-unused-binds #-}-{-# LANGUAGE ConstraintKinds- , EmptyDataDecls- , FlexibleContexts- , FlexibleInstances- , DeriveGeneric- , GADTs- , GeneralizedNewtypeDeriving- , MultiParamTypeClasses- , OverloadedStrings- , QuasiQuotes- , Rank2Types- , TemplateHaskell- , TypeFamilies- , ScopedTypeVariables- , CPP- , TypeSynonymInstances- #-}-module Main (main) where--import Control.Monad (forM_, replicateM, replicateM_, void)-import Control.Monad.IO.Class (MonadIO(liftIO))-import Control.Monad.Logger (MonadLogger(..), runStderrLoggingT, runNoLoggingT)-import Control.Monad.Trans.Control (MonadBaseControl(..))-import Control.Monad.Trans.Reader (ReaderT)-import Data.Char (toLower, toUpper)-import Data.Monoid ((<>))-import Database.Esqueleto-#if defined (WITH_POSTGRESQL)-import Database.Persist.Postgresql (withPostgresqlConn)-import Data.Ord (comparing)-import Control.Arrow ((&&&))-import qualified Database.Esqueleto.PostgreSQL as EP-#elif defined (WITH_MYSQL)-import Database.Persist.MySQL ( withMySQLConn- , connectHost- , connectDatabase- , connectUser- , connectPassword- , defaultConnectInfo)-#endif-import Database.Persist.Sqlite (withSqliteConn)-import Database.Sqlite (SqliteException)-import Database.Persist.TH-import Test.Hspec--import Data.Conduit (($$), Source, (=$=))-import qualified Data.Conduit.List as CL-import qualified Control.Monad.Trans.Resource as R-import qualified Data.List as L-import qualified Data.Set as S-import qualified Data.Text.Lazy.Builder as TLB-import qualified Database.Esqueleto.Internal.Sql as EI----- Test schema-share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|- Foo- name Int- Primary name- Bar- quux FooId-- Person- name String- age Int Maybe- weight Int Maybe- favNum Int- deriving Eq Show- BlogPost- title String- authorId PersonId- deriving Eq Show-- Lord- county String- dogs Int Maybe- Primary county- deriving Show-- Deed- contract String- ownerId LordId- Primary contract- deriving 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- Tag- name String- Primary name- deriving Eq Show- ArticleTag- articleId ArticleId- tagId TagId- 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-|]---- | 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)--main :: IO ()-main = do- let p1 = Person "John" (Just 36) Nothing 1- p2 = Person "Rachel" Nothing (Just 37) 2- p3 = Person "Mike" (Just 17) Nothing 3- p4 = Person "Livia" (Just 17) (Just 18) 4- p5 = Person "Mitch" Nothing Nothing 5- l1 = Lord "Cornwall" (Just 36)- l2 = Lord "Dorset" Nothing- l3 = Lord "Chester" (Just 17)-- hspec $ 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) ]-- describe "selectSource" $ do- it "works for a simple example" $- run $ do- let query = selectSource $- from $ \person ->- return person- p1e <- insert' p1- ret <- 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 <- query $$ CL.consume- ret1 <- query $$ CL.consume- liftIO $ ret0 `shouldBe` [ p1e ]- liftIO $ ret1 `shouldBe` [ p1e ]-- it "works on repro" $ do- let selectPerson :: R.MonadResource m => String -> Source (SqlPersistT m) (Key Person)- 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 <- selectPerson (personName p1) $$ CL.consume- r2 <- selectPerson (personName p2) $$ CL.consume- liftIO $ do- r1 `shouldBe` [ entityKey p1e ]- r2 `shouldBe` [ entityKey p2e ]--- 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--- 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 "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]-- 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 ]-- it "works with sum_" $- run $ do- _ <- insert' p1- _ <- insert' p2- _ <- insert' p3- _ <- insert' p4- ret <- select $- from $ \p->- return $ joinV $ sum_ (p ^. PersonAge)-#if defined(WITH_POSTGRESQL)- liftIO $ ret `shouldBe` [ Value $ Just (36 + 17 + 17 :: Rational ) ]-#elif defined(WITH_MYSQL)- liftIO $ ret `shouldBe` [ Value $ Just (36 + 17 + 17 :: Double ) ]-#else- liftIO $ ret `shouldBe` [ Value $ Just (36 + 17 + 17 :: Int) ]-#endif-- it "works with avg_" $- run $ do- _ <- insert' p1- _ <- insert' p2- _ <- insert' p3- _ <- insert' p4- ret <- select $- from $ \p->- return $ joinV $ avg_ (p ^. PersonAge)- liftIO $ ret `shouldBe` [ Value $ Just ((36 + 17 + 17) / 3 :: Double) ]-- 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 random_" $- run $ do-#if defined(WITH_POSTGRESQL) || defined(WITH_MYSQL)- _ <- select $ return (random_ :: SqlExpr (Value Double))-#else- _ <- select $ return (random_ :: SqlExpr (Value Int))-#endif- return ()-- 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 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--- 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 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-#ifdef WITH_POSTGRESQL- liftIO $ ret `shouldBe` [ p4e, p3e, p1e , p2e ]-#else- -- in SQLite and MySQL, its the reverse- liftIO $ ret `shouldBe` [ p2e, p4e, p3e, p1e ]-#endif-- 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-#ifdef WITH_POSTGRESQL- liftIO $ ret `shouldBe` [ p2e, p1e, p4e, p3e ]-#else- liftIO $ ret `shouldBe` [ p1e, p4e, p3e, p2e ]-#endif-- 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 with asc random_" $- 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 (random_ :: 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)-- 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--- 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 (selectDistinct)" $- selDistTest selectDistinct-- it "works on a simple example (select . distinct)" $- selDistTest (select . distinct)-- it "works on a simple example (distinct (return ()))" $- selDistTest (\act -> select $ distinct (return ()) >> act)--#if defined(WITH_POSTGRESQL)- 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)]-#endif-- 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- ]--#if defined(WITH_POSTGRESQL) || defined(WITH_MYSQL)- it "works on PostgreSQL and MySQL with <2 arguments" $- run $ do- _ :: [Value (Maybe Int)] <-- select $- from $ \p -> do- return (coalesce [p ^. PersonAge])- return ()-#else- 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)-#endif-- describe "text functions" $ do- it "like, (%) and (++.) work on a simple example" $- run $ do- [p1e, p2e, p3e, p4e] <- mapM insert' [p1, p2, p3, p4]- let nameContains t expected = do- ret <- select $- from $ \p -> do- where_ (p ^. PersonName `like` (%) ++. val t ++. (%))- orderBy [asc (p ^. PersonName)]- return p- liftIO $ ret `shouldBe` expected- nameContains "h" [p1e, p2e]- nameContains "i" [p4e, p3e]- nameContains "iv" [p4e]--#if defined(WITH_POSTGRESQL)- 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]-#endif-- describe "delete" $- it "works on a simple example" $- run $ do- p1e <- insert' p1- p2e <- insert' p2- p3e <- insert' p3- let getAll = select $- from $ \p -> do- orderBy [asc (p ^. PersonName)]- return p- ret1 <- getAll- liftIO $ ret1 `shouldBe` [ p1e, p3e, p2e ]- () <- delete $- from $ \p ->- where_ (p ^. PersonName ==. val (personName p1))- ret2 <- getAll- liftIO $ ret2 `shouldBe` [ p3e, p2e ]- n <- deleteCount $- from $ \p ->- return ((p :: SqlExpr (Entity Person)) `seq` ())- ret3 <- getAll- liftIO $ (n, ret3) `shouldBe` (2, [])-- describe "update" $ 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.-#if defined(WITH_POSTGRESQL)- 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 ]- -- MySQL: nulls appear first, and update returns actual number- -- of changed rows-#elif defined(WITH_MYSQL)- liftIO $ n `shouldBe` 1- liftIO $ ret `shouldBe` [ Entity p2k (Person anon Nothing (Just 37) 2)- , Entity p1k (Person anon (Just 73) Nothing 1)- , Entity p3k p3 ]-#else- -- 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 ]-#endif-- it "works with a subexpression having COUNT(*)" $- run $ do- p1k <- insert p1- p2k <- insert p2- p3k <- insert p3- replicateM_ 3 (insert $ BlogPost "" p1k)- replicateM_ 7 (insert $ BlogPost "" p3k)- let blogPostsBy p =- from $ \b -> do- where_ (b ^. BlogPostAuthorId ==. p ^. PersonId)- return countRows- () <- update $ \p -> do- set p [ PersonAge =. just (sub_select (blogPostsBy p)) ]- ret <- select $- from $ \p -> do- orderBy [ asc (p ^. PersonName) ]- return p- liftIO $ ret `shouldBe` [ Entity p1k p1 { personAge = Just 3 }- , Entity p3k p3 { personAge = Just 7 }- , Entity p2k p2 { personAge = Just 0 } ]-- it "works with a composite primary key" $- pendingWith "Need refactor to support composite pks on ESet"- {-- run $ do- let p = Point x y ""- x = 10- y = 15- newX = 20- newY = 25- Right newPk = keyFromValues [toPersistValue newX, toPersistValue newY]- insert_ p- () <- update $ \p' -> do- set p' [PointId =. val newPk]- [Entity _ ret] <- select $ from $ return- liftIO $ do- ret `shouldBe` Point newX newY []- -}-- it "GROUP BY works with COUNT" $- run $ do- p1k <- insert p1- p2k <- insert p2- p3k <- insert p3- replicateM_ 3 (insert $ BlogPost "" p1k)- replicateM_ 7 (insert $ BlogPost "" p3k)- ret <- select $- from $ \(p `LeftOuterJoin` b) -> do- on (p ^. PersonId ==. b ^. BlogPostAuthorId)- groupBy (p ^. PersonId)- let cnt = count (b ^. BlogPostId)- orderBy [ asc cnt ]- return (p, cnt)- liftIO $ ret `shouldBe` [ (Entity p2k p2, Value (0 :: Int))- , (Entity p1k p1, Value 3)- , (Entity p3k p3, Value 7) ]-- it "GROUP BY works with COUNT and InnerJoin" $- run $ do- l1k <- insert l1- l2k <- insert l2- l3k <- insert l3- mapM_ (\k -> insert $ Deed k l1k) (map show [1..3])-- mapM_ (\k -> insert $ Deed k l3k) (map show [4..10])-- (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 `shouldBe` [ (Value l3k, Value 7)- , (Value l1k, Value 3) ]-- 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) ]-- 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 $ ret `shouldBe` [ 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 ]-- 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)-- 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)]-- 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-- describe "Math-related functions" $ do- 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-- 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)-- 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) ]-- 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 ForShare" $ sanityCheck ForShare "FOR SHARE"- it "looks sane for LockInShareMode" $ sanityCheck LockInShareMode "LOCK IN SHARE MODE"-- 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-- describe "PostgreSQL module" $ do- it "should be tested on the PostgreSQL database" $-#if !defined(WITH_POSTGRESQL)- pendingWith "test suite not running under PostgreSQL, skipping"-#else- (return () :: IO ())-- it "arrayAgg looks sane" $- run $ do- let people = [p1, p2, p3, p4, p5]- mapM_ insert people- [Value ret] <-- select . from $ \p -> return (EP.arrayAgg (p ^. PersonName))- liftIO $ L.sort ret `shouldBe` L.sort (map personName people)-- it "stringAgg looks sane" $- run $ do- let people = [p1, p2, p3, p4, p5]- mapM_ insert people- [Value ret] <-- select $- from $ \p -> do- return (EP.stringAgg (p ^. PersonName) (val " "))- liftIO $ L.sort (words ret) `shouldBe` L.sort (map personName people)-- it "chr looks sane" $- run $ do- [Value (ret :: String)] <- select $ return (EP.chr (val 65))- liftIO $ ret `shouldBe` "A"-#endif---------------------------------------------------------------------------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 = ( MonadBaseControl IO m, MonadIO m, MonadLogger m- , R.MonadThrow m )--#if defined (WITH_POSTGRESQL) || defined (WITH_MYSQL)--- 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 Foo)) -> return ()- delete $ from $ \(_ :: SqlExpr (Entity Bar)) -> return ()-- delete $ from $ \(_ :: SqlExpr (Entity BlogPost)) -> return ()- delete $ from $ \(_ :: SqlExpr (Entity Follow)) -> return ()- delete $ from $ \(_ :: SqlExpr (Entity Person)) -> return ()-- delete $ from $ \(_ :: SqlExpr (Entity CcList)) -> return ()-- delete $ from $ \(_ :: SqlExpr (Entity ArticleTag)) -> 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 ()-#endif---run, runSilent, runVerbose :: (forall m. RunDbMonad m => SqlPersistT (R.ResourceT m) a) -> IO a-runSilent act = runNoLoggingT $ run_worker act-runVerbose act = runStderrLoggingT $ run_worker act-run =- if verbose- then runVerbose- else runSilent---verbose :: Bool-verbose = True---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-#if defined (WITH_POSTGRESQL) || defined (WITH_MYSQL)- cleanDB-#endif---withConn :: RunDbMonad m => (SqlBackend -> R.ResourceT m a) -> m a-withConn =- R.runResourceT .-#if defined(WITH_POSTGRESQL)- withPostgresqlConn "host=localhost port=5432 user=test dbname=test"-#elif defined (WITH_MYSQL)- withMySQLConn defaultConnectInfo- { connectHost = "localhost"- , connectUser = "test"- , connectPassword = "test"- , connectDatabase = "test"- }-#else- withSqliteConn ":memory:"-#endif