esqueleto-2.4.1/src/0000755000000000000000000000000012512076365012510 5ustar0000000000000000esqueleto-2.4.1/src/Database/0000755000000000000000000000000012562407464014217 5ustar0000000000000000esqueleto-2.4.1/src/Database/Esqueleto/0000755000000000000000000000000012560457300016155 5ustar0000000000000000esqueleto-2.4.1/src/Database/Esqueleto/Internal/0000755000000000000000000000000012562407464017741 5ustar0000000000000000esqueleto-2.4.1/test/0000755000000000000000000000000012562407464012703 5ustar0000000000000000esqueleto-2.4.1/src/Database/Esqueleto.hs0000644000000000000000000003141512562407464016525 0ustar0000000000000000{-# LANGUAGE FlexibleContexts, FlexibleInstances, GADTs #-} -- | The @esqueleto@ EDSL (embedded domain specific language). -- This module replaces @Database.Persist@, so instead of -- importing that module you should just import this one: -- -- @ -- -- For a module using just esqueleto. -- import Database.Esqueleto -- @ -- -- If you need to use @persistent@'s default support for queries -- as well, either import it qualified: -- -- @ -- -- For a module that mostly uses esqueleto. -- import Database.Esqueleto -- import qualified Database.Persistent as P -- @ -- -- or import @esqueleto@ itself qualified: -- -- @ -- -- For a module uses esqueleto just on some queries. -- import Database.Persistent -- import qualified Database.Esqueleto as E -- @ -- -- Other than identifier name clashes, @esqueleto@ does not -- conflict with @persistent@ in any way. module Database.Esqueleto ( -- * Setup -- $setup -- * Introduction -- $introduction -- * Getting started -- $gettingstarted -- * @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 , countRows, count, countDistinct , not_, (==.), (>=.), (>.), (<=.), (<.), (!=.), (&&.), (||.) , (+.), (-.), (/.), (*.) , random_, round_, ceiling_, floor_ , min_, max_, sum_, avg_, castNum, castNumM , coalesce, coalesceDefault , lower_, like, ilike, (%), concat_, (++.), castString , subList_select, subList_selectDistinct, valList, justList , in_, notIn, exists, notExists , set, (=.), (+=.), (-=.), (*=.), (/=.) , case_ ) , when_ , then_ , else_ , from , Value(..) , unValue , ValueList(..) , OrderBy , DistinctOn , LockingKind(..) , SqlString -- ** Joins , InnerJoin(..) , CrossJoin(..) , LeftOuterJoin(..) , RightOuterJoin(..) , FullOuterJoin(..) , OnClauseWithoutMatchingJoinException(..) -- * SQL backend , SqlQuery , SqlExpr , SqlEntity , select , selectDistinct , selectSource , selectDistinctSource , delete , deleteCount , update , updateCount , insertSelect , insertSelectDistinct , (<#) , (<&>) -- * RDBMS-specific modules -- $rdbmsSpecificModules -- * Helpers , valkey , valJ -- * Re-exports -- $reexports , deleteKey , module Database.Esqueleto.Internal.PersistentImport ) where import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Reader (ReaderT) import Data.Int (Int64) import Database.Esqueleto.Internal.Language import Database.Esqueleto.Internal.Sql import Database.Esqueleto.Internal.PersistentImport import qualified Database.Persist -- $setup -- -- If you're already using @persistent@, then you're ready to use -- @esqueleto@, no further setup is needed. If you're just -- starting a new project and would like to use @esqueleto@, take -- a look at @persistent@'s book first -- () to learn how to -- define your schema. ---------------------------------------------------------------------- -- $introduction -- -- The main goals of @esqueleto@ are to: -- -- * Be easily translatable to SQL. When you take a look at a -- @esqueleto@ query, you should be able to know exactly how -- the SQL query will end up. (As opposed to being a -- relational algebra EDSL such as HaskellDB, which is -- non-trivial to translate into SQL.) -- -- * Support the mostly used SQL features. We'd like you to be -- able to use @esqueleto@ for all of your queries, no -- exceptions. Send a pull request or open an issue on our -- project page () if -- there's anything missing that you'd like to see. -- -- * Be as type-safe as possible. We strive to provide as many -- type checks as possible. If you get bitten by some invalid -- code that type-checks, please open an issue on our project -- page so we can take a look. -- -- However, it is /not/ a goal to be able to write portable SQL. -- We do not try to hide the differences between DBMSs from you, -- and @esqueleto@ code that works for one database may not work -- on another. This is a compromise we have to make in order to -- give you as much control over the raw SQL as possible without -- losing too much convenience. This also means that you may -- type-check a query that doesn't work on your DBMS. ---------------------------------------------------------------------- -- $gettingstarted -- -- We like clean, easy-to-read EDSLs. However, in order to -- achieve this goal we've used a lot of type hackery, leading to -- some hard-to-read type signatures. On this section, we'll try -- to build some intuition about the syntax. -- -- For the following examples, we'll use this example schema: -- -- @ -- share [mkPersist sqlSettings, mkMigrate \"migrateAll\"] [persist| -- Person -- name String -- age Int Maybe -- deriving Eq Show -- BlogPost -- title String -- authorId PersonId -- deriving Eq Show -- Follow -- follower PersonId -- followed PersonId -- deriving Eq Show -- |] -- @ -- -- Most of @esqueleto@ was created with @SELECT@ statements in -- mind, not only because they're the most common but also -- because they're the most complex kind of statement. The most -- simple kind of @SELECT@ would be: -- -- @ -- SELECT * -- FROM Person -- @ -- -- In @esqueleto@, we may write the same query above as: -- -- @ -- do people <- 'select' $ -- 'from' $ \\person -> do -- return person -- liftIO $ mapM_ (putStrLn . personName . entityVal) people -- @ -- -- The expression above has type @SqlPersist m ()@, while -- @people@ has type @[Entity Person]@. The query above will be -- translated into exactly the same query we wrote manually, but -- instead of @SELECT *@ it will list all entity fields (using -- @*@ is not robust). Note that @esqueleto@ knows that we want -- an @Entity Person@ just because of the @personName@ that we're -- printing later. -- -- However, most of the time we need to filter our queries using -- @WHERE@. For example: -- -- @ -- SELECT * -- FROM Person -- WHERE Person.name = \"John\" -- @ -- -- In @esqueleto@, we may write the same query above as: -- -- @ -- 'select' $ -- 'from' $ \\p -> do -- 'where_' (p '^.' PersonName '==.' 'val' \"John\") -- return p -- @ -- -- Although @esqueleto@'s code is a bit more noisy, it's has -- almost the same structure (save from the @return@). The -- @('^.')@ operator is used to project a field from an entity. -- The field name is the same one generated by @persistent@'s -- Template Haskell functions. We use 'val' to lift a constant -- Haskell value into the SQL query. -- -- Another example would be: -- -- @ -- SELECT * -- FROM Person -- WHERE Person.age >= 18 -- @ -- -- In @esqueleto@, we may write the same query above as: -- -- @ -- 'select' $ -- 'from' $ \\p -> do -- 'where_' (p '^.' PersonAge '>=.' 'just' ('val' 18)) -- return p -- @ -- -- Since @age@ is an optional @Person@ field, we use 'just' lift -- @'val' 18 :: SqlExpr (Value Int)@ into @just ('val' 18) :: -- SqlExpr (Value (Maybe Int))@. -- -- Implicit joins are represented by tuples. For example, to get -- the list of all blog posts and their authors, we could write: -- -- @ -- SELECT BlogPost.*, Person.* -- FROM BlogPost, Person -- WHERE BlogPost.authorId = Person.id -- ORDER BY BlogPost.title ASC -- @ -- -- In @esqueleto@, we may write the same query above as: -- -- @ -- 'select' $ -- 'from' $ \\(b, p) -> do -- 'where_' (b '^.' BlogPostAuthorId '==.' p '^.' PersonId) -- 'orderBy' ['asc' (b '^.' BlogPostTitle)] -- return (b, p) -- @ -- -- However, we may want your results to include people who don't -- have any blog posts as well using a @LEFT OUTER JOIN@: -- -- @ -- SELECT Person.*, BlogPost.* -- FROM Person LEFT OUTER JOIN BlogPost -- ON Person.id = BlogPost.authorId -- ORDER BY Person.name ASC, BlogPost.title ASC -- @ -- -- In @esqueleto@, we may write the same query above as: -- -- @ -- 'select' $ -- 'from' $ \\(p `'LeftOuterJoin`` mb) -> do -- 'on' ('just' (p '^.' PersonId) '==.' mb '?.' BlogPostAuthorId) -- 'orderBy' ['asc' (p '^.' PersonName), 'asc' (mb '?.' BlogPostTitle)] -- return (p, mb) -- @ -- -- On a @LEFT OUTER JOIN@ the entity on the right hand side may -- not exist (i.e. there may be a @Person@ without any -- @BlogPost@s), so while @p :: SqlExpr (Entity Person)@, we have -- @mb :: SqlExpr (Maybe (Entity BlogPost))@. The whole -- expression above has type @SqlPersist m [(Entity Person, Maybe -- (Entity BlogPost))]@. Instead of using @(^.)@, we used -- @('?.')@ to project a field from a @Maybe (Entity a)@. -- -- We are by no means limited to joins of two tables, nor by -- joins of different tables. For example, we may want a list -- the @Follow@ entity: -- -- @ -- SELECT P1.*, Follow.*, P2.* -- FROM Person AS P1 -- INNER JOIN Follow ON P1.id = Follow.follower -- INNER JOIN P2 ON P2.id = Follow.followed -- @ -- -- In @esqueleto@, we may write the same query above as: -- -- @ -- 'select' $ -- 'from' $ \\(p1 `'InnerJoin`` f `'InnerJoin`` p2) -> do -- 'on' (p2 '^.' PersonId '==.' f '^.' FollowFollowed) -- 'on' (p1 '^.' PersonId '==.' f '^.' FollowFollower) -- return (p1, f, p2) -- @ -- -- /Note carefully that the order of the ON clauses is/ -- /reversed!/ You're required to write your 'on's in reverse -- order because that helps composability (see the documentation -- of 'on' for more details). -- -- We also currently support @UPDATE@ and @DELETE@ statements. -- For example: -- -- @ -- do 'update' $ \\p -> do -- 'set' p [ PersonName '=.' 'val' \"João\" ] -- 'where_' (p '^.' PersonName '==.' 'val' \"Joao\") -- 'delete' $ -- 'from' $ \\p -> do -- 'where_' (p '^.' PersonAge '<.' 'just' ('val' 14)) -- @ -- -- The results of queries can also be used for insertions. -- In @SQL@, we might write the following, inserting a new blog -- post for every user: -- -- @ -- INSERT INTO BlogPost -- SELECT ('Group Blog Post', id) -- FROM Person -- @ -- -- In @esqueleto@, we may write the same query above as: -- -- @ -- 'insertSelect' $ 'from' $ \\p-> -- return $ BlogPost '<#' \"Group Blog Post\" '<&>' (p '^.' PersonId) -- @ -- -- Individual insertions can be performed through Persistent's -- 'insert' function, reexported for convenience. ---------------------------------------------------------------------- -- $reexports -- -- We re-export many symbols from @persistent@ for convenince: -- -- * \"Store functions\" from "Database.Persist". -- -- * Everything from "Database.Persist.Class" except for -- @PersistQuery@ and @delete@ (use 'deleteKey' instead). -- -- * Everything from "Database.Persist.Types" except for -- @Update@, @SelectOpt@, @BackendSpecificFilter@ and @Filter@. -- -- * Everything from "Database.Persist.Sql" except for -- @deleteWhereCount@ and @updateWhereCount@. ---------------------------------------------------------------------- -- $rdbmsSpecificModules -- -- There are many differences between SQL syntax and functions -- supported by different RDBMSs. Since version 2.2.8, -- @esqueleto@ includes modules containing functions that are -- specific to a given RDBMS. -- -- * PostgreSQL: "Database.Esqueleto.PostgreSQL". -- -- In order to use these functions, you need to explicitly import -- their corresponding modules, they're not re-exported here. ---------------------------------------------------------------------- -- | @valkey i = 'val' . 'toSqlKey'@ -- (). valkey :: (Esqueleto query expr backend, ToBackendKey SqlBackend entity, PersistField (Key entity)) => Int64 -> expr (Value (Key entity)) valkey = val . toSqlKey -- | @valJ@ is like @val@ but for something that is already a @Value@. The use -- case it was written for was, given a @Value@ lift the @Key@ for that @Value@ -- into the query expression in a type safe way. However, the implementation is -- more generic than that so we call it @valJ@. -- -- Its important to note that the input entity and the output entity are -- constrained to be the same by the type signature on the function -- (). -- -- /Since: 1.4.2/ valJ :: (Esqueleto query expr backend, PersistField (Key entity)) => Value (Key entity) -> expr (Value (Key entity)) valJ = val . unValue ---------------------------------------------------------------------- -- | Synonym for 'Database.Persist.Store.delete' that does not -- clash with @esqueleto@'s 'delete'. deleteKey :: ( PersistStore (PersistEntityBackend val) , MonadIO m , PersistEntity val ) => Key val -> ReaderT (PersistEntityBackend val) m () deleteKey = Database.Persist.delete esqueleto-2.4.1/src/Database/Esqueleto/PostgreSQL.hs0000644000000000000000000000202012560460112020501 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | This module contain PostgreSQL-specific functions. -- -- /Since: 2.2.8/ module Database.Esqueleto.PostgreSQL ( arrayAgg , stringAgg , chr ) where import Database.Esqueleto.Internal.Language import Database.Esqueleto.Internal.Sql -- | (@array_agg@) Concatenate input values, including @NULL@s, -- into an array. -- -- /Since: 2.2.8/ arrayAgg :: SqlExpr (Value a) -> SqlExpr (Value [a]) arrayAgg = unsafeSqlFunction "array_agg" -- | (@string_agg@) Concatenate input values separated by a -- delimiter. -- -- /Since: 2.2.8/ stringAgg :: SqlString s => SqlExpr (Value s) -- ^ Input values. -> SqlExpr (Value s) -- ^ Delimiter. -> SqlExpr (Value s) -- ^ Concatenation. stringAgg expr delim = unsafeSqlFunction "string_agg" (expr, delim) -- | (@chr@) Translate the given integer to a character. (Note the result will -- depend on the character set of your database.) -- -- /Since: 2.2.11/ chr :: SqlString s => SqlExpr (Value Int) -> SqlExpr (Value s) chr = unsafeSqlFunction "chr" esqueleto-2.4.1/src/Database/Esqueleto/Internal/Language.hs0000644000000000000000000010472012562407464022024 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable , EmptyDataDecls , FlexibleContexts , FlexibleInstances , FunctionalDependencies , MultiParamTypeClasses , TypeFamilies , UndecidableInstances , GADTs #-} -- | This is an internal module, anything exported by this module -- may change without a major version bump. Please use only -- "Database.Esqueleto" if possible. module Database.Esqueleto.Internal.Language ( -- * The pretty face Esqueleto(..) , from , Value(..) , unValue , ValueList(..) , SomeValue(..) , ToSomeValues(..) , InnerJoin(..) , CrossJoin(..) , LeftOuterJoin(..) , RightOuterJoin(..) , FullOuterJoin(..) , OnClauseWithoutMatchingJoinException(..) , OrderBy , DistinctOn , Update , Insertion , LockingKind(..) , SqlString -- * The guts , JoinKind(..) , IsJoinKind(..) , PreprocessedFrom , From , FromPreprocess , when_ , then_ , else_ ) where import Control.Applicative (Applicative(..), (<$>)) import Control.Exception (Exception) import Data.Int (Int64) import Data.Typeable (Typeable) import Database.Esqueleto.Internal.PersistentImport import Text.Blaze.Html (Html) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL 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 -- | (Internal) Start a 'from' query with an entity. 'from' -- does two kinds of magic using 'fromStart', 'fromJoin' and -- 'fromFinish': -- -- 1. The simple but tedious magic of allowing tuples to be -- used. -- -- 2. The more advanced magic of creating @JOIN@s. The -- @JOIN@ is processed from right to left. The rightmost -- entity of the @JOIN@ is created with 'fromStart'. Each -- @JOIN@ step is then translated into a call to 'fromJoin'. -- In the end, 'fromFinish' is called to materialize the -- @JOIN@. fromStart :: ( PersistEntity a , PersistEntityBackend a ~ backend ) => query (expr (PreprocessedFrom (expr (Entity a)))) -- | (Internal) Same as 'fromStart', but entity may be missing. fromStartMaybe :: ( PersistEntity a , PersistEntityBackend a ~ backend ) => query (expr (PreprocessedFrom (expr (Maybe (Entity a))))) -- | (Internal) Do a @JOIN@. fromJoin :: IsJoinKind join => expr (PreprocessedFrom a) -> expr (PreprocessedFrom b) -> query (expr (PreprocessedFrom (join a b))) -- | (Internal) Finish a @JOIN@. fromFinish :: expr (PreprocessedFrom a) -> query a -- | @WHERE@ clause: restrict the query's result. where_ :: expr (Value Bool) -> query () -- | @ON@ clause: restrict the a @JOIN@'s result. The @ON@ -- clause will be applied to the /last/ @JOIN@ that does not -- have an @ON@ clause yet. If there are no @JOIN@s without -- @ON@ clauses (either because you didn't do any @JOIN@, or -- because all @JOIN@s already have their own @ON@ clauses), a -- runtime exception 'OnClauseWithoutMatchingJoinException' is -- thrown. @ON@ clauses are optional when doing @JOIN@s. -- -- On the simple case of doing just one @JOIN@, for example -- -- @ -- select $ -- 'from' $ \\(foo `'InnerJoin`` bar) -> do -- 'on' (foo '^.' FooId '==.' bar '^.' BarFooId) -- ... -- @ -- -- there's no ambiguity and the rules above just mean that -- you're allowed to call 'on' only once (as in SQL). If you -- have many joins, then the 'on's are applied on the /reverse/ -- order that the @JOIN@s appear. For example: -- -- @ -- select $ -- 'from' $ \\(foo `'InnerJoin`` bar `'InnerJoin`` baz) -> do -- 'on' (baz '^.' BazId '==.' bar '^.' BarBazId) -- 'on' (foo '^.' FooId '==.' bar '^.' BarFooId) -- ... -- @ -- -- The order is /reversed/ in order to improve composability. -- For example, consider @query1@ and @query2@ below: -- -- @ -- let query1 = -- 'from' $ \\(foo `'InnerJoin`` bar) -> do -- 'on' (foo '^.' FooId '==.' bar '^.' BarFooId) -- query2 = -- 'from' $ \\(mbaz `'LeftOuterJoin`` quux) -> do -- return (mbaz '?.' BazName, quux) -- test1 = (,) \<$\> query1 \<*\> query2 -- test2 = flip (,) \<$\> query2 \<*\> query1 -- @ -- -- If the order was /not/ reversed, then @test2@ would be -- broken: @query1@'s 'on' would refer to @query2@'s -- 'LeftOuterJoin'. on :: expr (Value Bool) -> query () -- | @GROUP BY@ clause. You can enclose multiple columns -- in a tuple. -- -- @ -- select $ 'from' \\(foo `'InnerJoin`` bar) -> do -- 'on' (foo '^.' FooBarId '==.' bar '^.' BarId) -- 'groupBy' (bar '^.' BarId, bar '^.' BarName) -- return (bar '^.' BarId, bar '^.' BarName, countRows) -- @ -- -- With groupBy you can sort by aggregate functions, like so -- (we used @let@ to restrict the more general 'countRows' to -- @SqlExpr (Value Int)@ to avoid ambiguity---the second use of -- 'countRows' has its type restricted by the @:: Int@ below): -- -- @ -- r \<- select $ 'from' \\(foo `'InnerJoin`` bar) -> do -- 'on' (foo '^.' FooBarId '==.' bar '^.' BarId) -- 'groupBy' $ bar '^.' BarName -- let countRows' = 'countRows' -- 'orderBy' ['asc' countRows'] -- return (bar '^.' BarName, countRows') -- forM_ r $ \\('Value' name, 'Value' count) -> do -- print name -- print (count :: Int) -- @ groupBy :: (ToSomeValues expr a) => a -> query () -- | @ORDER BY@ clause. See also 'asc' and 'desc'. -- -- Multiple calls to 'orderBy' get concatenated on the final -- query, including 'distinctOnOrderBy'. orderBy :: [expr OrderBy] -> query () -- | Ascending order of this field or expression. asc :: PersistField a => expr (Value a) -> expr OrderBy -- | Descending order of this field or expression. desc :: PersistField a => expr (Value a) -> expr OrderBy -- | @LIMIT@. Limit the number of returned rows. limit :: Int64 -> query () -- | @OFFSET@. Usually used with 'limit'. offset :: Int64 -> query () -- | @DISTINCT@. Change the current @SELECT@ into @SELECT -- DISTINCT@. For example: -- -- @ -- select $ distinct $ -- 'from' \\foo -> do -- ... -- @ -- -- Note that this also has the same effect: -- -- @ -- select $ -- 'from' \\foo -> do -- distinct (return ()) -- ... -- @ -- -- /Since: 2.2.4/ distinct :: query a -> query a -- | @DISTINCT ON@. Change the current @SELECT@ into -- @SELECT DISTINCT ON (expressions)@. For example: -- -- @ -- select $ -- 'from' \\foo -> -- 'distinctOn' ['don' (foo ^. FooName), 'don' (foo ^. FooState)] $ do -- ... -- @ -- -- You can also chain different calls to 'distinctOn'. The -- above is equivalent to: -- -- @ -- select $ -- 'from' \\foo -> -- 'distinctOn' ['don' (foo ^. FooName)] $ -- 'distinctOn' ['don' (foo ^. FooState)] $ do -- ... -- @ -- -- Each call to 'distinctOn' adds more expressions. Calls to -- 'distinctOn' override any calls to 'distinct'. -- -- Note that PostgreSQL requires the expressions on @DISTINCT -- ON@ to be the first ones to appear on a @ORDER BY@. This is -- not managed automatically by esqueleto, keeping its spirit -- of trying to be close to raw SQL. -- -- Supported by PostgreSQL only. -- -- /Since: 2.2.4/ distinctOn :: [expr DistinctOn] -> query a -> query a -- | Erase an expression's type so that it's suitable to -- be used by 'distinctOn'. -- -- /Since: 2.2.4/ don :: expr (Value a) -> expr DistinctOn -- | A convenience function that calls both 'distinctOn' and -- 'orderBy'. In other words, -- -- @ -- 'distinctOnOrderBy' [asc foo, desc bar, desc quux] $ do -- ... -- @ -- -- is the same as: -- -- @ -- 'distinctOn' [don foo, don bar, don quux] $ do -- 'orderBy' [asc foo, desc bar, desc quux] -- ... -- @ -- -- /Since: 2.2.4/ distinctOnOrderBy :: [expr OrderBy] -> query a -> query a -- | @ORDER BY random()@ clause. -- -- /Since: 1.3.10/ rand :: expr OrderBy -- | @HAVING@. -- -- /Since: 1.2.2/ having :: expr (Value Bool) -> query () -- | Add a locking clause to the query. Please read -- 'LockingKind' documentation and your RDBMS manual. -- -- If multiple calls to 'locking' are made on the same query, -- the last one is used. -- -- /Since: 2.2.7/ locking :: LockingKind -> query () -- | Execute a subquery @SELECT@ in an expression. Returns a -- simple value so should be used only when the @SELECT@ query -- 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 a field of an entity that may be null. (?.) :: (PersistEntity val, PersistField typ) => expr (Maybe (Entity val)) -> EntityField val typ -> expr (Value (Maybe typ)) -- | Lift a constant value from Haskell-land to the query. val :: PersistField typ => typ -> expr (Value typ) -- | @IS NULL@ comparison. isNothing :: PersistField typ => expr (Value (Maybe typ)) -> expr (Value Bool) -- | Analogous to 'Just', promotes a value of type @typ@ into -- one of type @Maybe typ@. It should hold that @'val' . Just -- === just . 'val'@. just :: expr (Value typ) -> expr (Value (Maybe typ)) -- | @NULL@ value. nothing :: expr (Value (Maybe typ)) -- | Join nested 'Maybe's in a 'Value' into one. This is useful when -- calling aggregate functions on nullable fields. joinV :: expr (Value (Maybe (Maybe typ))) -> expr (Value (Maybe typ)) -- | @COUNT(*)@ value. countRows :: Num a => expr (Value a) -- | @COUNT@. count :: Num a => expr (Value typ) -> expr (Value a) -- | @COUNT(DISTINCT x)@. -- -- /Since: 2.4.1/ countDistinct :: Num a => expr (Value typ) -> expr (Value a) not_ :: expr (Value Bool) -> expr (Value Bool) (==.) :: PersistField typ => expr (Value typ) -> expr (Value typ) -> expr (Value Bool) (>=.) :: PersistField typ => expr (Value typ) -> expr (Value typ) -> expr (Value Bool) (>.) :: PersistField typ => expr (Value typ) -> expr (Value typ) -> expr (Value Bool) (<=.) :: PersistField typ => expr (Value typ) -> expr (Value typ) -> expr (Value Bool) (<.) :: PersistField typ => expr (Value typ) -> expr (Value typ) -> expr (Value Bool) (!=.) :: PersistField typ => expr (Value typ) -> expr (Value typ) -> expr (Value Bool) (&&.) :: expr (Value Bool) -> expr (Value Bool) -> expr (Value Bool) (||.) :: expr (Value Bool) -> expr (Value Bool) -> expr (Value Bool) (+.) :: PersistField a => expr (Value a) -> expr (Value a) -> expr (Value a) (-.) :: PersistField a => expr (Value a) -> expr (Value a) -> expr (Value a) (/.) :: PersistField a => expr (Value a) -> expr (Value a) -> expr (Value a) (*.) :: PersistField a => expr (Value a) -> expr (Value a) -> expr (Value a) random_ :: (PersistField a, Num a) => expr (Value a) round_ :: (PersistField a, Num a, PersistField b, Num b) => expr (Value a) -> expr (Value b) ceiling_ :: (PersistField a, Num a, PersistField b, Num b) => expr (Value a) -> expr (Value b) floor_ :: (PersistField a, Num a, PersistField b, Num b) => expr (Value a) -> expr (Value b) sum_ :: (PersistField a, PersistField b) => expr (Value a) -> expr (Value (Maybe b)) min_ :: (PersistField a) => expr (Value a) -> expr (Value (Maybe a)) max_ :: (PersistField a) => expr (Value a) -> expr (Value (Maybe a)) avg_ :: (PersistField a, PersistField b) => expr (Value a) -> expr (Value (Maybe b)) -- | Allow a number of one type to be used as one of another -- type via an implicit cast. An explicit cast is not made, -- this function changes only the types on the Haskell side. -- -- /Caveat/: Trying to use @castNum@ from @Double@ to @Int@ -- will not result in an integer, the original fractional -- number will still be used! Use 'round_', 'ceiling_' or -- 'floor_' instead. -- -- /Safety/: This operation is mostly safe due to the 'Num' -- constraint between the types and the fact that RDBMSs -- usually allow numbers of different types to be used -- interchangeably. However, there may still be issues with -- the query not being accepted by the RDBMS or @persistent@ -- not being able to parse it. -- -- /Since: 2.2.9/ castNum :: (Num a, Num b) => expr (Value a) -> expr (Value b) -- | Same as 'castNum', but for nullable values. -- -- /Since: 2.2.9/ castNumM :: (Num a, Num b) => expr (Value (Maybe a)) -> expr (Value (Maybe b)) -- | @COALESCE@ function. Evaluates the arguments in order and -- returns the value of the first non-NULL expression, or NULL -- (Nothing) otherwise. Some RDBMSs (such as SQLite) require -- at least two arguments; please refer to the appropriate -- documentation. -- -- /Since: 1.4.3/ coalesce :: PersistField a => [expr (Value (Maybe a))] -> expr (Value (Maybe a)) -- | Like @coalesce@, but takes a non-nullable expression -- placed at the end of the expression list, which guarantees -- a non-NULL result. -- -- /Since: 1.4.3/ coalesceDefault :: PersistField a => [expr (Value (Maybe a))] -> expr (Value a) -> expr (Value a) -- | @LOWER@ function. lower_ :: SqlString s => expr (Value s) -> expr (Value s) -- | @LIKE@ operator. like :: SqlString s => expr (Value s) -> expr (Value s) -> expr (Value Bool) -- | @ILIKE@ operator (case-insensitive @LIKE@). -- -- Supported by PostgreSQL only. -- -- /Since: 2.2.3/ ilike :: SqlString s => expr (Value s) -> expr (Value s) -> expr (Value Bool) -- | The string @'%'@. May be useful while using 'like' and -- concatenation ('concat_' or '++.', depending on your -- database). Note that you always to type the parenthesis, -- for example: -- -- @ -- name `'like`` (%) ++. 'val' \"John\" ++. (%) -- @ (%) :: SqlString s => expr (Value s) -- | The @CONCAT@ function with a variable number of -- parameters. Supported by MySQL and PostgreSQL. concat_ :: SqlString s => [expr (Value s)] -> expr (Value s) -- | The @||@ string concatenation operator (named after -- Haskell's '++' in order to avoid naming clash with '||.'). -- Supported by SQLite and PostgreSQL. (++.) :: SqlString s => expr (Value s) -> expr (Value s) -> expr (Value s) -- | Cast a string type into 'Text'. This function -- is very useful if you want to use @newtype@s, or if you want -- to apply functions such as 'like' to strings of different -- types. -- -- /Safety:/ This is a slightly unsafe function, especially if -- you have defined your own instances of 'SqlString'. Also, -- since 'Maybe' is an instance of 'SqlString', it's possible -- to turn a nullable value into a non-nullable one. Avoid -- using this function if possible. castString :: (SqlString s, SqlString r) => expr (Value s) -> expr (Value r) -- | Execute a subquery @SELECT@ in an expression. Returns a -- 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) -- | Same as 'just' but for 'ValueList'. Most of the time you -- won't need it, though, because you can use 'just' from -- inside 'subList_select' or 'Just' from inside 'valList'. -- -- /Since: 2.2.12/ justList :: expr (ValueList typ) -> expr (ValueList (Maybe typ)) -- | @IN@ operator. in_ :: PersistField typ => expr (Value typ) -> expr (ValueList typ) -> expr (Value Bool) -- | @NOT IN@ operator. notIn :: PersistField typ => expr (Value typ) -> expr (ValueList typ) -> expr (Value Bool) -- | @EXISTS@ operator. For example: -- -- @ -- select $ -- 'from' $ \\person -> do -- 'where_' $ 'exists' $ -- 'from' $ \\post -> do -- 'where_' (post '^.' BlogPostAuthorId '==.' person '^.' PersonId) -- return person -- @ exists :: query () -> expr (Value Bool) -- | @NOT EXISTS@ operator. notExists :: query () -> expr (Value Bool) -- | @SET@ clause used on @UPDATE@s. Note that while it's not -- a type error to use this function on a @SELECT@, it will -- most certainly result in a runtime error. set :: PersistEntity val => expr (Entity val) -> [expr (Update val)] -> query () (=.) :: (PersistEntity val, PersistField typ) => EntityField val typ -> expr (Value typ) -> expr (Update val) (+=.) :: (PersistEntity val, PersistField a) => EntityField val a -> expr (Value a) -> expr (Update val) (-=.) :: (PersistEntity val, PersistField a) => EntityField val a -> expr (Value a) -> expr (Update val) (*=.) :: (PersistEntity val, PersistField a) => EntityField val a -> expr (Value a) -> expr (Update val) (/=.) :: (PersistEntity val, PersistField a) => EntityField val a -> expr (Value a) -> expr (Update val) -- | Apply a 'PersistField' constructor to @expr Value@ arguments. (<#) :: (a -> b) -> expr (Value a) -> expr (Insertion b) -- | Apply extra @expr Value@ arguments to a 'PersistField' constructor (<&>) :: expr (Insertion (a -> b)) -> expr (Value a) -> expr (Insertion b) -- | @CASE@ statement. For example: -- -- @ -- 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)) -- @ -- -- This query is a bit complicated, but basically it checks if a person -- named @\"Mike\"@ exists, and if that person does, run the subquery to find -- out how many people have a ranking (by Fav Num) higher than @\"Mike\"@. -- -- __NOTE:__ There are a few things to be aware about this statement. -- -- * This only implements the full CASE statement, it does not -- implement the \"simple\" CASE statement. -- -- -- * At least one 'when_' and 'then_' is mandatory otherwise it will -- emit an error. -- -- -- * The 'else_' is also mandatory, unlike the SQL statement in which -- if the @ELSE@ is omitted it will return a @NULL@. You can -- reproduce this via 'nothing'. -- -- /Since: 2.1.2/ case_ :: PersistField a => [(expr (Value Bool), expr (Value a))] -> expr (Value a) -> expr (Value a) {-# DEPRECATED sub_selectDistinct "Since 2.2.4: use 'sub_select' and 'distinct'." #-} {-# DEPRECATED subList_selectDistinct "Since 2.2.4: use 'subList_select' and 'distinct'." #-} -- Fixity declarations infixl 9 ^. infixl 7 *., /. infixl 6 +., -. infixr 5 ++. infix 4 ==., >=., >., <=., <., !=. infixr 3 &&., =., +=., -=., *=., /=. infixr 2 ||., `like`, `ilike` infixl 2 `InnerJoin`, `CrossJoin`, `LeftOuterJoin`, `RightOuterJoin`, `FullOuterJoin` -- | Syntax sugar for 'case_'. -- -- /Since: 2.1.2/ when_ :: expr (Value Bool) -> () -> expr a -> (expr (Value Bool), expr a) when_ cond _ expr = (cond, expr) -- | Syntax sugar for 'case_'. -- -- /Since: 2.1.2/ then_ :: () then_ = () -- | Syntax sugar for 'case_'. -- -- /Since: 2.1.2/ else_ :: expr a -> expr a else_ = id -- | 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@. -- -- | /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 -- | 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@. -- -- | A wrapper type for for any @expr (Value a)@ for all a. data SomeValue expr where SomeValue :: Esqueleto query expr backend => expr (Value a) -> SomeValue expr -- | A class of things that can be converted into a list of SomeValue. It has -- instances for tuples and is the reason why 'groupBy' can take tuples, like -- @'groupBy' (foo '^.' FooId, foo '^.' FooName, foo '^.' FooType)@. class ToSomeValues expr a where toSomeValues :: a -> [SomeValue expr] instance ( ToSomeValues expr a , ToSomeValues expr b ) => ToSomeValues expr (a, b) where toSomeValues (a,b) = toSomeValues a ++ toSomeValues b instance ( ToSomeValues expr a , ToSomeValues expr b , ToSomeValues expr c ) => ToSomeValues expr (a, b, c) where toSomeValues (a,b,c) = toSomeValues a ++ toSomeValues b ++ toSomeValues c instance ( ToSomeValues expr a , ToSomeValues expr b , ToSomeValues expr c , ToSomeValues expr d ) => ToSomeValues expr (a, b, c, d) where toSomeValues (a,b,c,d) = toSomeValues a ++ toSomeValues b ++ toSomeValues c ++ toSomeValues d instance ( ToSomeValues expr a , ToSomeValues expr b , ToSomeValues expr c , ToSomeValues expr d , ToSomeValues expr e ) => ToSomeValues expr (a, b, c, d, e) where toSomeValues (a,b,c,d,e) = toSomeValues a ++ toSomeValues b ++ toSomeValues c ++ toSomeValues d ++ toSomeValues e instance ( ToSomeValues expr a , ToSomeValues expr b , ToSomeValues expr c , ToSomeValues expr d , ToSomeValues expr e , ToSomeValues expr f ) => ToSomeValues expr (a, b, c, d, e, f) where toSomeValues (a,b,c,d,e,f) = toSomeValues a ++ toSomeValues b ++ toSomeValues c ++ toSomeValues d ++ toSomeValues e ++ toSomeValues f instance ( ToSomeValues expr a , ToSomeValues expr b , ToSomeValues expr c , ToSomeValues expr d , ToSomeValues expr e , ToSomeValues expr f , ToSomeValues expr g ) => ToSomeValues expr (a, b, c, d, e, f, g) where toSomeValues (a,b,c,d,e,f,g) = toSomeValues a ++ toSomeValues b ++ toSomeValues c ++ toSomeValues d ++ toSomeValues e ++ toSomeValues f ++ toSomeValues g instance ( ToSomeValues expr a , ToSomeValues expr b , ToSomeValues expr c , ToSomeValues expr d , ToSomeValues expr e , ToSomeValues expr f , ToSomeValues expr g , ToSomeValues expr h ) => ToSomeValues expr (a, b, c, d, e, f, g, h) where toSomeValues (a,b,c,d,e,f,g,h) = toSomeValues a ++ toSomeValues b ++ toSomeValues c ++ toSomeValues d ++ toSomeValues e ++ toSomeValues f ++ toSomeValues g ++ toSomeValues h -- | Data type that represents an @INNER JOIN@ (see 'LeftOuterJoin' for an example). data InnerJoin a b = a `InnerJoin` b -- | Data type that represents a @CROSS JOIN@ (see 'LeftOuterJoin' for an example). data CrossJoin a b = a `CrossJoin` b -- | Data type that represents a @LEFT OUTER JOIN@. For example, -- -- @ -- select $ -- 'from' $ \\(person `'LeftOuterJoin`` pet) -> -- ... -- @ -- -- is translated into -- -- @ -- SELECT ... -- FROM Person LEFT OUTER JOIN Pet -- ... -- @ -- -- See also: 'from'. data LeftOuterJoin a b = a `LeftOuterJoin` b -- | Data type that represents a @RIGHT OUTER JOIN@ (see 'LeftOuterJoin' for an example). data RightOuterJoin a b = a `RightOuterJoin` b -- | Data type that represents a @FULL OUTER JOIN@ (see 'LeftOuterJoin' for an example). data FullOuterJoin a b = a `FullOuterJoin` b -- | (Internal) A kind of @JOIN@. data JoinKind = InnerJoinKind -- ^ @INNER JOIN@ | CrossJoinKind -- ^ @CROSS JOIN@ | LeftOuterJoinKind -- ^ @LEFT OUTER JOIN@ | RightOuterJoinKind -- ^ @RIGHT OUTER JOIN@ | FullOuterJoinKind -- ^ @FULL OUTER JOIN@ deriving Eq -- | (Internal) Functions that operate on types (that should be) -- of kind 'JoinKind'. class IsJoinKind join where -- | (Internal) @smartJoin a b@ is a @JOIN@ of the correct kind. smartJoin :: a -> b -> join a b -- | (Internal) Reify a @JoinKind@ from a @JOIN@. This -- function is non-strict. reifyJoinKind :: join a b -> JoinKind instance IsJoinKind InnerJoin where smartJoin a b = a `InnerJoin` b reifyJoinKind _ = InnerJoinKind instance IsJoinKind CrossJoin where smartJoin a b = a `CrossJoin` b reifyJoinKind _ = CrossJoinKind instance IsJoinKind LeftOuterJoin where smartJoin a b = a `LeftOuterJoin` b reifyJoinKind _ = LeftOuterJoinKind instance IsJoinKind RightOuterJoin where smartJoin a b = a `RightOuterJoin` b reifyJoinKind _ = RightOuterJoinKind instance IsJoinKind FullOuterJoin where smartJoin a b = a `FullOuterJoin` b reifyJoinKind _ = FullOuterJoinKind -- | Exception thrown whenever 'on' is used to create an @ON@ -- clause but no matching @JOIN@ is found. data OnClauseWithoutMatchingJoinException = OnClauseWithoutMatchingJoinException String deriving (Eq, Ord, Show, Typeable) instance Exception OnClauseWithoutMatchingJoinException where -- | (Internal) Phantom type used to process 'from' (see 'fromStart'). data PreprocessedFrom a -- | Phantom type used by 'orderBy', 'asc' and 'desc'. data OrderBy -- | Phantom type used by 'distinctOn' and 'don'. data DistinctOn -- | Phantom type for a @SET@ operation on an entity of the given -- type (see 'set' and '(=.)'). data Update typ -- | Phantom type used by 'insertSelect'. data Insertion a -- | Different kinds of locking clauses supported by 'locking'. -- -- Note that each RDBMS has different locking support. The -- constructors of this datatype specify only the /syntax/ of the -- locking mechanism, not its /semantics/. For example, even -- though both MySQL and PostgreSQL support 'ForUpdate', there -- are no guarantees that they will behave the same. -- -- /Since: 2.2.7/ data LockingKind = ForUpdate -- ^ @FOR UPDATE@ syntax. Supported by MySQL, Oracle and -- PostgreSQL. -- -- /Since: 2.2.7/ | ForShare -- ^ @FOR SHARE@ syntax. Supported by PostgreSQL. -- -- /Since: 2.2.7/ | LockInShareMode -- ^ @LOCK IN SHARE MODE@ syntax. Supported by MySQL. -- -- /Since: 2.2.7/ -- | Phantom class of data types that are treated as strings by the -- RDBMS. It has no methods because it's only used to avoid type -- errors such as trying to concatenate integers. -- -- If you have a custom data type or @newtype@, feel free to make -- it an instance of this class. -- -- /Since: 2.4.0/ class PersistField a => SqlString a where -- | /Since: 2.3.0/ instance (a ~ Char) => SqlString [a] where -- | /Since: 2.3.0/ instance SqlString T.Text where -- | /Since: 2.3.0/ instance SqlString TL.Text where -- | /Since: 2.3.0/ instance SqlString B.ByteString where -- | /Since: 2.3.0/ instance SqlString Html where -- | /Since: 2.4.0/ instance SqlString a => SqlString (Maybe a) where -- | @FROM@ clause: bring entities into scope. -- -- This function internally uses two type classes in order to -- provide some flexibility of how you may call it. Internally -- we refer to these type classes as the two different magics. -- -- The innermost magic allows you to use @from@ with the -- following types: -- -- * @expr (Entity val)@, which brings a single entity into -- scope. -- -- * @expr (Maybe (Entity val))@, which brings a single entity -- that may be @NULL@ into scope. Used for @OUTER JOIN@s. -- -- * A @JOIN@ of any other two types allowed by the innermost -- magic, where a @JOIN@ may be an 'InnerJoin', a 'CrossJoin', a -- 'LeftOuterJoin', a 'RightOuterJoin', or a 'FullOuterJoin'. -- The @JOINs@ have left fixity. -- -- The outermost magic allows you to use @from@ on any tuples of -- types supported by innermost magic (and also tuples of tuples, -- and so on), up to 8-tuples. -- -- Note that using @from@ for the same entity twice does work and -- corresponds to a self-join. You don't even need to use two -- different calls to @from@, you may use a @JOIN@ or a tuple. -- -- The following are valid examples of uses of @from@ (the types -- of the arguments of the lambda are inside square brackets): -- -- @ -- 'from' $ \\person -> ... -- 'from' $ \\(person, blogPost) -> ... -- 'from' $ \\(p `'LeftOuterJoin`` mb) -> ... -- 'from' $ \\(p1 `'InnerJoin`` f `'InnerJoin`` p2) -> ... -- 'from' $ \\((p1 `'InnerJoin`` f) `'InnerJoin`` p2) -> ... -- @ -- -- The types of the arguments to the lambdas above are, -- respectively: -- -- @ -- person -- :: ( Esqueleto query expr backend -- , PersistEntity Person -- , PersistEntityBackend Person ~ backend -- ) => expr (Entity Person) -- (person, blogPost) -- :: (...) => (expr (Entity Person), expr (Entity BlogPost)) -- (p `'LeftOuterJoin`` mb) -- :: (...) => InnerJoin (expr (Entity Person)) (expr (Maybe (Entity BlogPost))) -- (p1 `'InnerJoin`` f `'InnerJoin`` p2) -- :: (...) => InnerJoin -- (InnerJoin (expr (Entity Person)) -- (expr (Entity Follow))) -- (expr (Entity Person)) -- (p1 `'InnerJoin`` (f `'InnerJoin`` p2)) :: -- :: (...) => InnerJoin -- (expr (Entity Person)) -- (InnerJoin (expr (Entity Follow)) -- (expr (Entity Person))) -- @ -- -- Note that some backends may not support all kinds of @JOIN@s. from :: From query expr backend a => (a -> query b) -> query b from = (from_ >>=) -- | (Internal) Class that implements the tuple 'from' magic (see -- 'fromStart'). class Esqueleto query expr backend => From query expr backend a where from_ :: query a instance ( Esqueleto query expr backend , FromPreprocess query expr backend (expr (Entity val)) ) => From query expr backend (expr (Entity val)) where from_ = fromPreprocess >>= fromFinish instance ( Esqueleto query expr backend , FromPreprocess query expr backend (expr (Maybe (Entity val))) ) => From query expr backend (expr (Maybe (Entity val))) where from_ = fromPreprocess >>= fromFinish instance ( Esqueleto query expr backend , FromPreprocess query expr backend (InnerJoin a b) ) => From query expr backend (InnerJoin a b) where from_ = fromPreprocess >>= fromFinish instance ( Esqueleto query expr backend , FromPreprocess query expr backend (CrossJoin a b) ) => From query expr backend (CrossJoin a b) where from_ = fromPreprocess >>= fromFinish instance ( Esqueleto query expr backend , FromPreprocess query expr backend (LeftOuterJoin a b) ) => From query expr backend (LeftOuterJoin a b) where from_ = fromPreprocess >>= fromFinish instance ( Esqueleto query expr backend , FromPreprocess query expr backend (RightOuterJoin a b) ) => From query expr backend (RightOuterJoin a b) where from_ = fromPreprocess >>= fromFinish instance ( Esqueleto query expr backend , FromPreprocess query expr backend (FullOuterJoin a b) ) => From query expr backend (FullOuterJoin a b) where from_ = fromPreprocess >>= fromFinish instance ( From query expr backend a , From query expr backend b ) => From query expr backend (a, b) where from_ = (,) <$> from_ <*> from_ instance ( From query expr backend a , From query expr backend b , From query expr backend c ) => From query expr backend (a, b, c) where from_ = (,,) <$> from_ <*> from_ <*> from_ instance ( From query expr backend a , From query expr backend b , From query expr backend c , From query expr backend d ) => From query expr backend (a, b, c, d) where from_ = (,,,) <$> from_ <*> from_ <*> from_ <*> from_ instance ( From query expr backend a , From query expr backend b , From query expr backend c , From query expr backend d , From query expr backend e ) => From query expr backend (a, b, c, d, e) where from_ = (,,,,) <$> from_ <*> from_ <*> from_ <*> from_ <*> from_ instance ( From query expr backend a , From query expr backend b , From query expr backend c , From query expr backend d , From query expr backend e , From query expr backend f ) => From query expr backend (a, b, c, d, e, f) where from_ = (,,,,,) <$> from_ <*> from_ <*> from_ <*> from_ <*> from_ <*> from_ instance ( From query expr backend a , From query expr backend b , From query expr backend c , From query expr backend d , From query expr backend e , From query expr backend f , From query expr backend g ) => From query expr backend (a, b, c, d, e, f, g) where from_ = (,,,,,,) <$> from_ <*> from_ <*> from_ <*> from_ <*> from_ <*> from_ <*> from_ instance ( From query expr backend a , From query expr backend b , From query expr backend c , From query expr backend d , From query expr backend e , From query expr backend f , From query expr backend g , From query expr backend h ) => From query expr backend (a, b, c, d, e, f, g, h) where from_ = (,,,,,,,) <$> from_ <*> from_ <*> from_ <*> from_ <*> from_ <*> from_ <*> from_ <*> from_ -- | (Internal) Class that implements the @JOIN@ 'from' magic -- (see 'fromStart'). class Esqueleto query expr backend => FromPreprocess query expr backend a where fromPreprocess :: query (expr (PreprocessedFrom a)) instance ( Esqueleto query expr backend , PersistEntity val , PersistEntityBackend val ~ backend ) => FromPreprocess query expr backend (expr (Entity val)) where fromPreprocess = fromStart instance ( Esqueleto query expr backend , PersistEntity val , PersistEntityBackend val ~ backend ) => FromPreprocess query expr backend (expr (Maybe (Entity val))) where fromPreprocess = fromStartMaybe instance ( Esqueleto query expr backend , FromPreprocess query expr backend a , FromPreprocess query expr backend b , IsJoinKind join ) => FromPreprocess query expr backend (join a b) where fromPreprocess = do a <- fromPreprocess b <- fromPreprocess fromJoin a b esqueleto-2.4.1/src/Database/Esqueleto/Internal/Sql.hs0000644000000000000000000016701612562407464021047 0ustar0000000000000000{-# LANGUAGE ConstraintKinds , EmptyDataDecls , FlexibleContexts , FlexibleInstances , FunctionalDependencies , GADTs , MultiParamTypeClasses , OverloadedStrings , UndecidableInstances , ScopedTypeVariables , InstanceSigs #-} -- | This is an internal module, anything exported by this module -- may change without a major version bump. Please use only -- "Database.Esqueleto" if possible. module Database.Esqueleto.Internal.Sql ( -- * The pretty face SqlQuery , SqlExpr , SqlEntity , select , selectSource , selectDistinct , selectDistinctSource , delete , deleteCount , update , updateCount , insertSelectDistinct , insertSelect -- * The guts , unsafeSqlCase , unsafeSqlBinOp , unsafeSqlBinOpComposite , unsafeSqlValue , unsafeSqlFunction , unsafeSqlExtractSubField , UnsafeSqlFunctionArgument , rawSelectSource , runSource , rawEsqueleto , toRawSql , Mode(..) , IdentState , initialIdentState , IdentInfo , SqlSelect(..) , veryUnsafeCoerceSqlExprValue , veryUnsafeCoerceSqlExprValueList ) where import Control.Applicative (Applicative(..), (<$>), (<$)) import Control.Arrow ((***), first) import Control.Exception (throw, throwIO) import Control.Monad (ap, MonadPlus(..), liftM) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Resource (MonadResource) import Data.Acquire (with, allocateAcquire, Acquire) import Data.Int (Int64) import Data.List (intersperse) import Data.Monoid (Last(..), Monoid(..), (<>)) import Data.Proxy (Proxy(..)) import Database.Esqueleto.Internal.PersistentImport import Database.Persist.Sql.Util (entityColumnNames, entityColumnCount, parseEntityValues, isIdField, hasCompositeKey) import qualified Control.Monad.Trans.Reader as R import qualified Control.Monad.Trans.State as S import qualified Control.Monad.Trans.Writer as W import qualified Data.Conduit as C import qualified Data.Conduit.List as CL import qualified Data.HashSet as HS import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TLB import Database.Esqueleto.Internal.Language -- | SQL backend for @esqueleto@ using 'SqlPersistT'. newtype SqlQuery a = Q { unQ :: W.WriterT SideData (S.State IdentState) a } instance Functor SqlQuery where fmap f = Q . fmap f . unQ instance Monad SqlQuery where return = Q . return m >>= f = Q (unQ m >>= unQ . f) instance Applicative SqlQuery where pure = return (<*>) = ap -- | Constraint synonym for @persistent@ entities whose backend -- is 'SqlPersistT'. type SqlEntity ent = (PersistEntity ent, PersistEntityBackend ent ~ SqlBackend) ---------------------------------------------------------------------- -- | Side data written by 'SqlQuery'. data SideData = SideData { sdDistinctClause :: !DistinctClause , sdFromClause :: ![FromClause] , sdSetClause :: ![SetClause] , sdWhereClause :: !WhereClause , sdGroupByClause :: !GroupByClause , sdHavingClause :: !HavingClause , sdOrderByClause :: ![OrderByClause] , sdLimitClause :: !LimitClause , 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' = SideData (d <> d') (f <> f') (s <> s') (w <> w') (g <> g') (h <> h') (o <> o') (l <> l') (k <> k') -- | The @DISTINCT@ "clause". data DistinctClause = DistinctAll -- ^ The default, everything. | DistinctStandard -- ^ Only @DISTINCT@, SQL standard. | DistinctOn [SqlExpr DistinctOn] -- ^ @DISTINCT ON@, PostgreSQL extension. 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 -- | A part of a @FROM@ clause. data FromClause = FromStart Ident EntityDef | FromJoin FromClause JoinKind FromClause (Maybe (SqlExpr (Value Bool))) | OnClause (SqlExpr (Value Bool)) -- | A part of a @SET@ clause. newtype SetClause = SetClause (SqlExpr (Value ())) -- | Collect 'OnClause's on 'FromJoin's. Returns the first -- unmatched 'OnClause's data on error. Returns a list without -- 'OnClauses' on success. collectOnClauses :: [FromClause] -> Either (SqlExpr (Value Bool)) [FromClause] collectOnClauses = go [] where go [] (f@(FromStart _ _):fs) = fmap (f:) (go [] fs) -- fast path go acc (OnClause expr :fs) = findMatching acc expr >>= flip go fs go acc (f:fs) = go (f:acc) fs go acc [] = return $ reverse acc findMatching (f : acc) expr = case tryMatch expr f of Just f' -> return (f' : acc) Nothing -> (f:) <$> findMatching acc expr findMatching [] expr = Left expr tryMatch expr (FromJoin l k r onClause) = matchR `mplus` matchC `mplus` matchL -- right to left where matchR = (\r' -> FromJoin l k r' onClause) <$> tryMatch expr r matchL = (\l' -> FromJoin l' k r onClause) <$> tryMatch expr l matchC = case onClause of Nothing | k /= CrossJoinKind -> return (FromJoin l k r (Just expr)) | otherwise -> mzero Just _ -> mzero tryMatch _ _ = mzero -- | A complete @WHERE@ clause. data WhereClause = Where (SqlExpr (Value Bool)) | NoWhere instance Monoid WhereClause where mempty = NoWhere NoWhere `mappend` w = w w `mappend` NoWhere = w Where e1 `mappend` Where e2 = Where (e1 &&. e2) -- | A @GROUP BY@ clause. newtype GroupByClause = GroupBy [SomeValue SqlExpr] instance Monoid GroupByClause where mempty = GroupBy [] GroupBy fs `mappend` GroupBy fs' = GroupBy (fs <> fs') -- | A @HAVING@ cause. type HavingClause = WhereClause -- | A @ORDER BY@ clause. type OrderByClause = SqlExpr OrderBy -- | 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 = 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. -- | A locking clause. type LockingClause = Last LockingKind ---------------------------------------------------------------------- -- | Identifier used for table names. newtype Ident = I T.Text -- | List of identifiers already in use and supply of temporary -- identifiers. newtype IdentState = IdentState { inUse :: HS.HashSet T.Text } initialIdentState :: IdentState initialIdentState = IdentState mempty -- | Create a fresh 'Ident'. If possible, use the given -- 'DBName'. newIdentFor :: DBName -> SqlQuery Ident newIdentFor = Q . lift . try . unDBName where try orig = do 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 (possibilities orig) possibilities t = t : map addNum [2..] where addNum :: Int -> T.Text addNum = T.append t . T.pack . show use t = do S.modify (\s -> s { inUse = HS.insert t (inUse s) }) return (I t) -- | Information needed to escape and use identifiers. type IdentInfo = (SqlBackend, IdentState) -- | Use an identifier. useIdent :: IdentInfo -> Ident -> TLB.Builder useIdent info (I ident) = fromDBName info $ DBName ident ---------------------------------------------------------------------- -- | An expression on the SQL backend. -- -- There are many comments describing the constructors of this -- data type. However, Haddock doesn't like GADTs, so you'll have to read them by hitting \"Source\". data SqlExpr a where -- An entity, created by 'from' (cf. 'fromStart'). EEntity :: Ident -> SqlExpr (Entity val) -- Just a tag stating that something is nullable. EMaybe :: SqlExpr a -> SqlExpr (Maybe a) -- Raw expression: states whether parenthesis are needed -- around this expression, and takes information about the SQL -- connection (mainly for escaping names) and returns both an -- string ('TLB.Builder') and a list of values to be -- interpolated by the SQL backend. ERaw :: NeedParens -> (IdentInfo -> (TLB.Builder, [PersistValue])) -> SqlExpr (Value a) -- A composite key. -- -- Persistent uses the same 'PersistList' constructor for both -- fields which are (homogeneous) lists of values and the -- (probably heterogeneous) values of a composite primary key. -- -- We need to treat composite keys as fields. For example, we -- have to support using ==., otherwise you wouldn't be able to -- join. OTOH, lists of values should be treated exactly the -- same as any other scalar value. -- -- In particular, this is valid for persistent via rawSql for -- an F field that is a list: -- -- A.F in ? -- [PersistList [foo, bar]] -- -- However, this is not for a composite key entity: -- -- A.ID = ? -- [PersistList [foo, bar]] -- -- The ID field doesn't exist on the DB for a composite key -- table, it exists only on the Haskell side. Those variations -- also don't work: -- -- (A.KeyA, A.KeyB) = ? -- [PersistList [foo, bar]] -- [A.KeyA, A.KeyB] = ? -- [PersistList [foo, bar]] -- -- We have to generate: -- -- A.KeyA = ? AND A.KeyB = ? -- [foo, bar] -- -- Note that the PersistList had to be deconstructed into its -- components. -- -- In order to disambiguate behaviors, this constructor is used -- /only/ to represent a composite field access. It does not -- represent a 'PersistList', not even if the 'PersistList' is -- used in the context of a composite key. That's because it's -- impossible, e.g., for 'val' to disambiguate between these -- uses. ECompositeKey :: (IdentInfo -> [TLB.Builder]) -> SqlExpr (Value a) -- 'EList' and 'EEmptyList' are used by list operators. EList :: SqlExpr (Value a) -> SqlExpr (ValueList a) EEmptyList :: SqlExpr (ValueList a) -- A 'SqlExpr' accepted only by 'orderBy'. EOrderBy :: OrderByType -> SqlExpr (Value a) -> SqlExpr OrderBy EOrderRandom :: SqlExpr OrderBy -- A 'SqlExpr' accepted only by 'distinctOn'. EDistinctOn :: SqlExpr (Value a) -> SqlExpr DistinctOn -- A 'SqlExpr' accepted only by 'set'. ESet :: (SqlExpr (Entity val) -> SqlExpr (Value ())) -> SqlExpr (Update val) -- An internal 'SqlExpr' used by the 'from' hack. EPreprocessedFrom :: a -> FromClause -> SqlExpr (PreprocessedFrom a) -- Used by 'insertSelect'. EInsert :: Proxy a -> (IdentInfo -> (TLB.Builder, [PersistValue])) -> SqlExpr (Insertion a) EInsertFinal :: PersistEntity a => SqlExpr (Insertion a) -> SqlExpr InsertFinal -- | Phantom type used to mark a @INSERT INTO@ query. data InsertFinal data NeedParens = Parens | Never parensM :: NeedParens -> TLB.Builder -> TLB.Builder parensM Never = id parensM Parens = parens data OrderByType = ASC | DESC instance Esqueleto SqlQuery SqlExpr SqlBackend where fromStart = x where x = do let ed = entityDef (getVal x) ident <- newIdentFor (entityDB ed) let ret = EEntity ident from_ = FromStart ident ed return (EPreprocessedFrom ret from_) getVal :: SqlQuery (SqlExpr (PreprocessedFrom (SqlExpr (Entity a)))) -> Proxy a getVal = const Proxy fromStartMaybe = maybelize <$> fromStart where maybelize :: SqlExpr (PreprocessedFrom (SqlExpr (Entity a))) -> SqlExpr (PreprocessedFrom (SqlExpr (Maybe (Entity a)))) maybelize (EPreprocessedFrom ret from_) = EPreprocessedFrom (EMaybe ret) from_ fromJoin (EPreprocessedFrom lhsRet lhsFrom) (EPreprocessedFrom rhsRet rhsFrom) = Q $ do let ret = smartJoin lhsRet rhsRet from_ = FromJoin lhsFrom -- LHS (reifyJoinKind ret) -- JOIN rhsFrom -- RHS Nothing -- ON return (EPreprocessedFrom ret from_) fromFinish (EPreprocessedFrom ret from_) = Q $ do W.tell mempty { sdFromClause = [from_] } return ret where_ expr = Q $ W.tell mempty { sdWhereClause = Where expr } on expr = Q $ W.tell mempty { sdFromClause = [OnClause expr] } groupBy expr = Q $ W.tell mempty { sdGroupByClause = GroupBy $ toSomeValues expr } having expr = Q $ W.tell mempty { sdHavingClause = Where expr } locking kind = Q $ W.tell mempty { sdLockingClause = Last (Just kind) } orderBy exprs = Q $ W.tell mempty { sdOrderByClause = exprs } asc = EOrderBy ASC desc = EOrderBy DESC rand = EOrderRandom limit n = Q $ W.tell mempty { sdLimitClause = Limit (Just n) Nothing } offset n = Q $ W.tell mempty { sdLimitClause = Limit Nothing (Just n) } distinct act = Q (W.tell mempty { sdDistinctClause = DistinctStandard }) >> act distinctOn exprs act = Q (W.tell mempty { sdDistinctClause = DistinctOn exprs }) >> act don = EDistinctOn distinctOnOrderBy exprs act = distinctOn (toDistinctOn <$> exprs) $ do orderBy exprs act where toDistinctOn :: SqlExpr OrderBy -> SqlExpr DistinctOn toDistinctOn (EOrderBy _ f) = EDistinctOn f 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) EEntity ident ^. field | isComposite = ECompositeKey $ \info -> dot info <$> compositeFields pdef | otherwise = ERaw Never $ \info -> (dot info $ persistFieldDef field, []) where isComposite = isIdField field && hasCompositeKey ed dot info x = useIdent info ident <> "." <> fromDBName info (fieldDB x) ed = entityDef $ getEntityVal (Proxy :: Proxy (SqlExpr (Entity val))) Just pdef = entityPrimary ed EMaybe r ?. field = just (r ^. field) val v = ERaw Never $ const ("?", [toPersistValue v]) isNothing (ERaw p f) = ERaw Parens $ first ((<> " IS NULL") . parensM p) . f isNothing (ECompositeKey f) = ERaw Parens $ flip (,) [] . (intersperseB " AND " . map (<> " IS NULL")) . f just (ERaw p f) = ERaw p f just (ECompositeKey f) = ECompositeKey f nothing = unsafeSqlValue "NULL" joinV (ERaw p f) = ERaw p f joinV (ECompositeKey f) = ECompositeKey f countRows = unsafeSqlValue "COUNT(*)" count = countHelper "" "" countDistinct = countHelper "(DISTINCT " ")" not_ (ERaw p f) = ERaw Never $ \info -> let (b, vals) = f info in ("NOT " <> parensM p b, vals) not_ (ECompositeKey _) = unexpectedCompositeKeyError "not_" (==.) = unsafeSqlBinOpComposite " = " " AND " (!=.) = unsafeSqlBinOpComposite " != " " OR " (>=.) = unsafeSqlBinOp " >= " (>.) = unsafeSqlBinOp " > " (<=.) = unsafeSqlBinOp " <= " (<.) = unsafeSqlBinOp " < " (&&.) = unsafeSqlBinOp " AND " (||.) = unsafeSqlBinOp " OR " (+.) = unsafeSqlBinOp " + " (-.) = unsafeSqlBinOp " - " (/.) = unsafeSqlBinOp " / " (*.) = unsafeSqlBinOp " * " random_ = unsafeSqlValue "RANDOM()" round_ = unsafeSqlFunction "ROUND" ceiling_ = unsafeSqlFunction "CEILING" floor_ = unsafeSqlFunction "FLOOR" sum_ = unsafeSqlFunction "SUM" min_ = unsafeSqlFunction "MIN" max_ = unsafeSqlFunction "MAX" avg_ = unsafeSqlFunction "AVG" castNum = veryUnsafeCoerceSqlExprValue castNumM = veryUnsafeCoerceSqlExprValue coalesce = unsafeSqlFunctionParens "COALESCE" coalesceDefault exprs = unsafeSqlFunctionParens "COALESCE" . (exprs ++) . return . just lower_ = unsafeSqlFunction "LOWER" like = unsafeSqlBinOp " LIKE " ilike = unsafeSqlBinOp " ILIKE " (%) = unsafeSqlValue "'%'" concat_ = unsafeSqlFunction "CONCAT" (++.) = unsafeSqlBinOp " || " castString = veryUnsafeCoerceSqlExprValue subList_select = EList . sub_select subList_selectDistinct = subList_select . distinct valList [] = EEmptyList valList vals = EList $ ERaw Parens $ const ( uncommas ("?" <$ vals) , map toPersistValue vals ) justList EEmptyList = EEmptyList justList (EList v) = EList (just v) v `in_` e = ifNotEmptyList e False $ unsafeSqlBinOp " IN " v (veryUnsafeCoerceSqlExprValueList e) v `notIn` e = ifNotEmptyList e True $ unsafeSqlBinOp " NOT IN " v (veryUnsafeCoerceSqlExprValueList e) exists = unsafeSqlFunction "EXISTS " . existsHelper notExists = unsafeSqlFunction "NOT EXISTS " . existsHelper set ent upds = Q $ W.tell mempty { sdSetClause = map apply upds } where apply (ESet f) = SetClause (f ent) field =. expr = setAux field (const expr) field +=. expr = setAux field (\ent -> ent ^. field +. expr) field -=. expr = setAux field (\ent -> ent ^. field -. expr) field *=. expr = setAux field (\ent -> ent ^. field *. expr) field /=. expr = setAux field (\ent -> ent ^. field /. expr) (<#) _ (ERaw _ f) = EInsert Proxy f (<#) _ (ECompositeKey _) = unexpectedCompositeKeyError "(<#)" (EInsert _ f) <&> (ERaw _ g) = EInsert Proxy $ \x -> let (fb, fv) = f x (gb, gv) = g x in (fb <> ", " <> gb, fv ++ gv) (EInsert _ _) <&> (ECompositeKey _) = unexpectedCompositeKeyError "(<&>)" case_ = unsafeSqlCase instance ToSomeValues SqlExpr (SqlExpr (Value a)) where toSomeValues a = [SomeValue a] fieldName :: (PersistEntity val, PersistField typ) => IdentInfo -> EntityField val typ -> TLB.Builder fieldName info = fromDBName info . fieldDB . persistFieldDef -- FIXME: Composite/non-id pKS not supported on set setAux :: (PersistEntity val, PersistField typ) => EntityField val typ -> (SqlExpr (Entity val) -> SqlExpr (Value typ)) -> SqlExpr (Update val) setAux field mkVal = ESet $ \ent -> unsafeSqlBinOp " = " name (mkVal ent) where name = ERaw Never $ \info -> (fieldName info field, mempty) sub :: PersistField a => Mode -> SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a) sub mode query = ERaw Parens $ \info -> toRawSql mode info query fromDBName :: IdentInfo -> DBName -> TLB.Builder fromDBName (conn, _) = TLB.fromText . connEscapeName conn existsHelper :: SqlQuery () -> SqlExpr (Value Bool) existsHelper = sub SELECT . (>> return true) where true :: SqlExpr (Value Bool) true = val True ifNotEmptyList :: SqlExpr (ValueList a) -> Bool -> SqlExpr (Value Bool) -> SqlExpr (Value Bool) ifNotEmptyList EEmptyList b _ = val b ifNotEmptyList (EList _) _ x = x countHelper :: Num a => TLB.Builder -> TLB.Builder -> SqlExpr (Value typ) -> SqlExpr (Value a) countHelper open close (ERaw _ f) = ERaw Never $ first (\b -> "COUNT" <> open <> parens b <> close) . f countHelper _ _ (ECompositeKey _) = countRows -- Assumes no NULLs on a PK ---------------------------------------------------------------------- -- | (Internal) Create a case statement. -- -- Since: 2.1.1 unsafeSqlCase :: PersistField a => [(SqlExpr (Value Bool), SqlExpr (Value a))] -> SqlExpr (Value a) -> SqlExpr (Value a) unsafeSqlCase when (ERaw p1 f1) = ERaw Never buildCase where buildCase :: IdentInfo -> (TLB.Builder, [PersistValue]) buildCase info = let (b1, vals1) = f1 info (b2, vals2) = mapWhen when info 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 when' info = foldl (foldHelp info) (mempty, mempty) when' foldHelp :: IdentInfo -> (TLB.Builder, [PersistValue]) -> (SqlExpr (Value Bool), SqlExpr (Value a)) -> (TLB.Builder, [PersistValue]) foldHelp info (b0, vals0) (ERaw p1' f1', ERaw p2 f2) = 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" -- | (Internal) Create a custom binary operator. You /should/ -- /not/ use this function directly since its type is very -- general, you should always use it with an explicit type -- signature. For example: -- -- @ -- (==.) :: SqlExpr (Value a) -> SqlExpr (Value a) -> SqlExpr (Value Bool) -- (==.) = unsafeSqlBinOp " = " -- @ -- -- In the example above, we constraint the arguments to be of the -- same type and constraint the result to be a boolean value. unsafeSqlBinOp :: TLB.Builder -> SqlExpr (Value a) -> SqlExpr (Value b) -> SqlExpr (Value c) unsafeSqlBinOp op (ERaw p1 f1) (ERaw p2 f2) = ERaw Parens f where f info = let (b1, vals1) = f1 info (b2, vals2) = f2 info in ( parensM p1 b1 <> op <> parensM p2 b2 , vals1 <> vals2 ) unsafeSqlBinOp _ _ _ = unexpectedCompositeKeyError "unsafeSqlBinOp" {-# INLINE unsafeSqlBinOp #-} -- | Similar to 'unsafeSqlBinOp', but may also be applied to -- composite keys. Uses the operator given as the second -- argument whenever applied to composite keys. -- -- Usage example: -- -- @ -- (==.) :: SqlExpr (Value a) -> SqlExpr (Value a) -> SqlExpr (Value Bool) -- (==.) = unsafeSqlBinOpComposite " = " " AND " -- @ -- -- Persistent has a hack for implementing composite keys (see -- 'ECompositeKey' doc for more details), so we're forced to use -- a hack here as well. We deconstruct 'ERaw' values based on -- two rules: -- -- - If it is a single placeholder, then it's assumed to be -- coming from a 'PersistList' and thus its components are -- separated so that they may be applied to a composite key. -- -- - If it is not a single placeholder, then it's assumed to be -- a foreign (composite or not) key, so we enforce that it has -- no placeholders and split it on the commas. unsafeSqlBinOpComposite :: TLB.Builder -> TLB.Builder -> SqlExpr (Value a) -> SqlExpr (Value b) -> SqlExpr (Value c) unsafeSqlBinOpComposite op _ a@(ERaw _ _) b@(ERaw _ _) = unsafeSqlBinOp op a b unsafeSqlBinOpComposite op sep a b = ERaw Parens $ compose (listify a) (listify b) where listify :: SqlExpr (Value x) -> IdentInfo -> ([TLB.Builder], [PersistValue]) listify (ECompositeKey f) = flip (,) [] . f listify (ERaw _ f) = deconstruct . f 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 ++ "." compose f1 f2 info | not (null v1 || null v2) = err' "one side needs to have null placeholders" | length b1 /= length b2 = err' "mismatching lengths" | 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) unsafeSqlValue v = ERaw Never $ \_ -> (v, mempty) {-# INLINE unsafeSqlValue #-} -- | (Internal) A raw SQL function. Once again, the same warning -- from 'unsafeSqlBinOp' applies to this function as well. unsafeSqlFunction :: UnsafeSqlFunctionArgument a => TLB.Builder -> a -> SqlExpr (Value b) unsafeSqlFunction name arg = ERaw Never $ \info -> let (argsTLB, argsVals) = uncommas' $ map (\(ERaw _ f) -> f info) $ toArgList arg in (name <> parens argsTLB, argsVals) -- | (Internal) An unsafe SQL function to extract a subfield from a compound -- field, e.g. datetime. See 'unsafeSqlBinOp' for warnings. -- -- Since: 1.3.6. unsafeSqlExtractSubField :: UnsafeSqlFunctionArgument a => TLB.Builder -> a -> SqlExpr (Value b) unsafeSqlExtractSubField subField arg = ERaw Never $ \info -> let (argsTLB, argsVals) = uncommas' $ map (\(ERaw _ f) -> f info) $ toArgList arg in ("EXTRACT" <> parens (subField <> " FROM " <> argsTLB), argsVals) -- | (Internal) A raw SQL function. Preserves parentheses around arguments. -- See 'unsafeSqlBinOp' for warnings. unsafeSqlFunctionParens :: UnsafeSqlFunctionArgument a => TLB.Builder -> a -> SqlExpr (Value b) unsafeSqlFunctionParens name arg = ERaw Never $ \info -> let (argsTLB, argsVals) = uncommas' $ map (\(ERaw p f) -> first (parensM p) (f info)) $ toArgList arg in (name <> parens argsTLB, argsVals) class UnsafeSqlFunctionArgument a where toArgList :: a -> [SqlExpr (Value ())] instance (a ~ Value b) => UnsafeSqlFunctionArgument (SqlExpr a) where toArgList = (:[]) . veryUnsafeCoerceSqlExprValue instance UnsafeSqlFunctionArgument a => UnsafeSqlFunctionArgument [a] where toArgList = concatMap toArgList instance ( UnsafeSqlFunctionArgument a , UnsafeSqlFunctionArgument b ) => UnsafeSqlFunctionArgument (a, b) where toArgList (a, b) = toArgList a ++ toArgList b instance ( UnsafeSqlFunctionArgument a , UnsafeSqlFunctionArgument b , UnsafeSqlFunctionArgument c ) => UnsafeSqlFunctionArgument (a, b, c) where toArgList = toArgList . from3 instance ( UnsafeSqlFunctionArgument a , UnsafeSqlFunctionArgument b , UnsafeSqlFunctionArgument c , UnsafeSqlFunctionArgument d ) => UnsafeSqlFunctionArgument (a, b, c, d) where toArgList = toArgList . from4 -- | (Internal) Coerce a value's type from 'SqlExpr (Value a)' to -- 'SqlExpr (Value b)'. You should /not/ use this function -- unless you know what you're doing! veryUnsafeCoerceSqlExprValue :: SqlExpr (Value a) -> SqlExpr (Value b) veryUnsafeCoerceSqlExprValue (ERaw p f) = ERaw p f veryUnsafeCoerceSqlExprValue (ECompositeKey f) = ECompositeKey f -- | (Internal) Coerce a value's type from 'SqlExpr (ValueList -- 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." ---------------------------------------------------------------------- -- | (Internal) Execute an @esqueleto@ @SELECT@ 'SqlQuery' inside -- @persistent@'s 'SqlPersistT' monad. rawSelectSource :: ( SqlSelect a r , MonadIO m1 , MonadIO m2 ) => Mode -> SqlQuery a -> SqlPersistT m1 (Acquire (C.Source m2 r)) rawSelectSource mode query = do conn <- R.ask res <- run conn return $ (C.$= massage) `fmap` res where run conn = uncurry rawQueryRes $ first builderToText $ toRawSql mode (conn, initialIdentState) query massage = do mrow <- C.await case process <$> mrow of Just (Right r) -> C.yield r >> massage Just (Left err) -> liftIO $ throwIO $ PersistMarshalError err Nothing -> return () process = sqlSelectProcessRow -- | Execute an @esqueleto@ @SELECT@ query inside @persistent@'s -- 'SqlPersistT' monad and return a 'C.Source' of rows. selectSource :: ( SqlSelect a r , MonadResource m ) => SqlQuery a -> C.Source (SqlPersistT m) r selectSource query = do src <- lift $ do res <- rawSelectSource SELECT query fmap snd $ allocateAcquire res src -- | Execute an @esqueleto@ @SELECT@ query inside @persistent@'s -- 'SqlPersistT' monad and return a list of rows. -- -- We've seen that 'from' has some magic about which kinds of -- things you may bring into scope. This 'select' function also -- has some magic for which kinds of things you may bring back to -- Haskell-land by using @SqlQuery@'s @return@: -- -- * You may return a @SqlExpr ('Entity' v)@ for an entity @v@ -- (i.e., like the @*@ in SQL), which is then returned to -- Haskell-land as just @Entity v@. -- -- * You may return a @SqlExpr (Maybe (Entity v))@ for an entity -- @v@ that may be @NULL@, which is then returned to -- Haskell-land as @Maybe (Entity v)@. Used for @OUTER JOIN@s. -- -- * You may return a @SqlExpr ('Value' t)@ for a value @t@ -- (i.e., a single column), where @t@ is any instance of -- 'PersistField', which is then returned to Haskell-land as -- @Value t@. You may use @Value@ to return projections of an -- @Entity@ (see @('^.')@ and @('?.')@) or to return any other -- value calculated on the query (e.g., 'countRows' or -- 'sub_select'). -- -- The @SqlSelect a r@ class has functional dependencies that -- allow type information to flow both from @a@ to @r@ and -- vice-versa. This means that you'll almost never have to give -- any type signatures for @esqueleto@ queries. For example, the -- query @'select' $ from $ \\p -> return p@ alone is ambiguous, but -- in the context of -- -- @ -- do ps <- 'select' $ -- 'from' $ \\p -> -- return p -- liftIO $ mapM_ (putStrLn . personName . entityVal) ps -- @ -- -- we are able to infer from that single @personName . entityVal@ -- function composition that the @p@ inside the query is of type -- @SqlExpr (Entity Person)@. select :: ( SqlSelect a r , MonadIO m ) => SqlQuery a -> SqlPersistT 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 (SqlPersistT m) r -> SqlPersistT m [r] runSource src = src C.$$ CL.consume ---------------------------------------------------------------------- -- | (Internal) Execute an @esqueleto@ statement inside -- @persistent@'s 'SqlPersistT' monad. rawEsqueleto :: ( MonadIO m, SqlSelect a r ) => Mode -> SqlQuery a -> SqlPersistT m Int64 rawEsqueleto mode query = do conn <- R.ask uncurry rawExecuteCount $ first builderToText $ toRawSql mode (conn, initialIdentState) query -- | Execute an @esqueleto@ @DELETE@ query inside @persistent@'s -- 'SqlPersistT' monad. Note that currently there are no type -- checks for statements that should not appear on a @DELETE@ -- query. -- -- Example of usage: -- -- @ -- 'delete' $ -- 'from' $ \\appointment -> -- 'where_' (appointment '^.' AppointmentDate '<.' 'val' now) -- @ -- -- Unlike 'select', there is a useful way of using 'delete' that -- will lead to type ambiguities. If you want to delete all rows -- (i.e., no 'where_' clause), you'll have to use a type signature: -- -- @ -- 'delete' $ -- 'from' $ \\(appointment :: 'SqlExpr' ('Entity' Appointment)) -> -- return () -- @ delete :: ( MonadIO m ) => SqlQuery () -> SqlPersistT m () delete = liftM (const ()) . deleteCount -- | Same as 'delete', but returns the number of rows affected. deleteCount :: ( MonadIO m ) => SqlQuery () -> SqlPersistT m Int64 deleteCount = rawEsqueleto DELETE -- | Execute an @esqueleto@ @UPDATE@ query inside @persistent@'s -- 'SqlPersistT' monad. Note that currently there are no type -- checks for statements that should not appear on a @UPDATE@ -- query. -- -- Example of usage: -- -- @ -- 'update' $ \p -> do -- 'set' p [ PersonAge '=.' 'just' ('val' thisYear) -. p '^.' PersonBorn ] -- 'where_' $ isNothing (p '^.' PersonAge) -- @ update :: ( MonadIO m , SqlEntity val ) => (SqlExpr (Entity val) -> SqlQuery ()) -> SqlPersistT m () update = liftM (const ()) . updateCount -- | Same as 'update', but returns the number of rows affected. updateCount :: ( MonadIO m , SqlEntity val ) => (SqlExpr (Entity val) -> SqlQuery ()) -> SqlPersistT m Int64 updateCount = rawEsqueleto UPDATE . from ---------------------------------------------------------------------- builderToText :: TLB.Builder -> T.Text builderToText = TL.toStrict . TLB.toLazyTextWith defaultChunkSize where defaultChunkSize = 1024 - 32 -- | (Internal) Pretty prints a 'SqlQuery' into a SQL query. -- -- Note: if you're curious about the SQL query being generated by -- @esqueleto@, instead of manually using this function (which is -- possible but tedious), you may just turn on query logging of -- @persistent@. toRawSql :: SqlSelect a r => Mode -> IdentInfo -> SqlQuery a -> (TLB.Builder, [PersistValue]) toRawSql mode (conn, firstIdentState) query = let ((ret, sd), finalIdentState) = flip S.runState firstIdentState $ W.runWriterT $ unQ query SideData distinctClause fromClauses setClauses whereClauses groupByClause havingClause orderByClauses limitClause lockingClause = sd -- Pass the finalIdentState (containing all identifiers -- 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 = (conn, finalIdentState) in mconcat [ makeInsertInto info mode ret , makeSelect info mode distinctClause ret , makeFrom info mode fromClauses , makeSet info setClauses , makeWhere info whereClauses , makeGroupBy info groupByClause , makeHaving info havingClause , makeOrderBy info orderByClauses , makeLimit info limitClause orderByClauses , makeLocking lockingClause ] -- | (Internal) Mode of query being converted by 'toRawSql'. data Mode = SELECT | DELETE | UPDATE | INSERT_INTO uncommas :: [TLB.Builder] -> TLB.Builder uncommas = intersperseB ", " intersperseB :: TLB.Builder -> [TLB.Builder] -> TLB.Builder intersperseB a = mconcat . intersperse a . filter (/= mempty) uncommas' :: Monoid a => [(TLB.Builder, a)] -> (TLB.Builder, a) uncommas' = (uncommas *** mconcat) . unzip makeInsertInto :: SqlSelect a r => IdentInfo -> Mode -> a -> (TLB.Builder, [PersistValue]) makeInsertInto info INSERT_INTO ret = sqlInsertInto info ret makeInsertInto _ _ _ = mempty makeSelect :: SqlSelect a r => IdentInfo -> Mode -> DistinctClause -> a -> (TLB.Builder, [PersistValue]) makeSelect info mode_ distinctClause ret = process mode_ where process mode = case mode of SELECT -> withCols selectKind DELETE -> plain "DELETE " UPDATE -> plain "UPDATE " INSERT_INTO -> process SELECT selectKind = case distinctClause of DistinctAll -> ("SELECT ", []) DistinctStandard -> ("SELECT DISTINCT ", []) DistinctOn exprs -> first (("SELECT DISTINCT ON (" <>) . (<> ") ")) $ uncommas' (processExpr <$> exprs) where processExpr (EDistinctOn f) = materializeExpr info f withCols v = v <> (sqlSelectCols info ret) plain v = (v, []) makeFrom :: IdentInfo -> Mode -> [FromClause] -> (TLB.Builder, [PersistValue]) makeFrom _ _ [] = mempty makeFrom info mode fs = ret where ret = case collectOnClauses fs of Left expr -> throw $ mkExc expr Right fs' -> keyword $ uncommas' (map (mk Never) fs') keyword = case mode of UPDATE -> id _ -> first ("\nFROM " <>) mk _ (FromStart i def) = base i def mk paren (FromJoin lhs kind rhs monClause) = first (parensM paren) $ mconcat [ mk Never lhs , (fromKind kind, mempty) , mk Parens rhs , maybe mempty makeOnClause monClause ] mk _ (OnClause _) = error "Esqueleto/Sql/makeFrom: never here (is collectOnClauses working?)" base ident@(I identText) def = let db@(DBName dbText) = entityDB def in ( if dbText == identText then fromDBName info db else fromDBName info db <> (" AS " <> useIdent info ident) , mempty ) fromKind InnerJoinKind = " INNER JOIN " fromKind CrossJoinKind = " CROSS JOIN " fromKind LeftOuterJoinKind = " LEFT OUTER JOIN " fromKind RightOuterJoinKind = " RIGHT OUTER JOIN " fromKind FullOuterJoinKind = " FULL OUTER JOIN " makeOnClause (ERaw _ f) = first (" ON " <>) (f info) makeOnClause (ECompositeKey _) = unexpectedCompositeKeyError "makeFrom/makeOnClause" 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" 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 makeWhere :: IdentInfo -> WhereClause -> (TLB.Builder, [PersistValue]) makeWhere _ NoWhere = mempty makeWhere info (Where (ERaw _ f)) = first ("\nWHERE " <>) (f info) makeWhere _ (Where (ECompositeKey _)) = unexpectedCompositeKeyError "makeWhere" makeGroupBy :: IdentInfo -> GroupByClause -> (TLB.Builder, [PersistValue]) makeGroupBy _ (GroupBy []) = (mempty, []) makeGroupBy info (GroupBy fields) = first ("\nGROUP BY " <>) build where build = uncommas' $ map (\(SomeValue (ERaw _ f)) -> f info) fields makeHaving :: IdentInfo -> WhereClause -> (TLB.Builder, [PersistValue]) makeHaving _ NoWhere = mempty makeHaving info (Where (ERaw _ f)) = first ("\nHAVING " <>) (f info) makeHaving _ (Where (ECompositeKey _ )) = unexpectedCompositeKeyError "makeHaving" makeOrderBy :: IdentInfo -> [OrderByClause] -> (TLB.Builder, [PersistValue]) makeOrderBy _ [] = mempty makeOrderBy info os = first ("\nORDER BY " <>) . uncommas' $ concatMap mk os where mk :: OrderByClause -> [(TLB.Builder, [PersistValue])] mk (EOrderBy t (ERaw p f)) = [first ((<> orderByType t) . parensM p) (f info)] mk (EOrderBy t (ECompositeKey f)) = let fs = f info vals = repeat [] in zip (map (<> orderByType t) fs) vals mk EOrderRandom = [first ((<> "RANDOM()")) mempty] orderByType ASC = " ASC" orderByType DESC = " DESC" makeLimit :: IdentInfo -> LimitClause -> [OrderByClause] -> (TLB.Builder, [PersistValue]) makeLimit (conn, _) (Limit ml mo) orderByClauses = let limitRaw = connLimitOffset conn (v ml, v mo) hasOrderClause "\n" hasOrderClause = not (null orderByClauses) v = maybe 0 fromIntegral in (TLB.fromText limitRaw, mempty) makeLocking :: LockingClause -> (TLB.Builder, [PersistValue]) makeLocking = flip (,) [] . maybe mempty toTLB . getLast where toTLB ForUpdate = "\nFOR UPDATE" toTLB ForShare = "\nFOR SHARE" toTLB LockInShareMode = "\nLOCK IN SHARE MODE" parens :: TLB.Builder -> TLB.Builder parens b = "(" <> (b <> ")") ---------------------------------------------------------------------- -- | (Internal) Class for mapping results coming from 'SqlQuery' -- into actual results. -- -- This looks very similar to @RawSql@, and it is! However, -- there are some crucial differences and ultimately they're -- different classes. class SqlSelect a r | a -> r, r -> a where -- | Creates the variable part of the @SELECT@ query and -- returns the list of 'PersistValue's that will be given to -- 'rawQuery'. sqlSelectCols :: IdentInfo -> a -> (TLB.Builder, [PersistValue]) -- | Number of columns that will be consumed. sqlSelectColCount :: Proxy a -> Int -- | Transform a row of the result into the data type. sqlSelectProcessRow :: [PersistValue] -> Either T.Text r -- | Create @INSERT INTO@ clause instead. sqlInsertInto :: IdentInfo -> a -> (TLB.Builder, [PersistValue]) sqlInsertInto = error "Type does not support sqlInsertInto." -- | @INSERT INTO@ hack. instance SqlSelect (SqlExpr InsertFinal) InsertFinal where sqlInsertInto info (EInsertFinal (EInsert p _)) = let fields = uncommas $ map (fromDBName info . fieldDB) $ entityFields $ entityDef p table = fromDBName info . entityDB . entityDef $ p 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" -- | Not useful for 'select', but used for 'update' and 'delete'. instance SqlSelect () () where sqlSelectCols _ _ = ("1", []) sqlSelectColCount _ = 1 sqlSelectProcessRow _ = Right () -- | You may return an 'Entity' from a 'select' query. instance PersistEntity a => SqlSelect (SqlExpr (Entity a)) (Entity a) where sqlSelectCols info expr@(EEntity ident) = ret where process ed = uncommas $ map ((name <>) . TLB.fromText) $ entityColumnNames ed (fst info) -- 'name' is the biggest difference between 'RawSql' and -- 'SqlSelect'. We automatically create names for tables -- (since it's not the user who's writing the FROM -- clause), while 'rawSql' assumes that it's just the -- name of the table (which doesn't allow self-joins, for -- example). name = useIdent info ident <> "." ret = let ed = entityDef $ getEntityVal $ return expr in (process ed, mempty) sqlSelectColCount = entityColumnCount . entityDef . getEntityVal sqlSelectProcessRow = parseEntityValues ed where ed = entityDef $ getEntityVal $ (Proxy :: Proxy (SqlExpr (Entity a))) getEntityVal :: Proxy (SqlExpr (Entity a)) -> Proxy a getEntityVal = const Proxy -- | You may return a possibly-@NULL@ 'Entity' from a 'select' query. instance PersistEntity a => SqlSelect (SqlExpr (Maybe (Entity a))) (Maybe (Entity a)) where sqlSelectCols info (EMaybe ent) = sqlSelectCols info ent sqlSelectColCount = sqlSelectColCount . fromEMaybe where fromEMaybe :: Proxy (SqlExpr (Maybe e)) -> Proxy (SqlExpr e) fromEMaybe = const Proxy sqlSelectProcessRow cols | all (== PersistNull) cols = return Nothing | otherwise = Just <$> sqlSelectProcessRow cols -- | You may return any single value (i.e. a single column) from -- a 'select' query. instance PersistField a => SqlSelect (SqlExpr (Value a)) (Value a) where sqlSelectCols = materializeExpr sqlSelectColCount = const 1 sqlSelectProcessRow [pv] = Value <$> fromPersistValue pv sqlSelectProcessRow pvs = Value <$> fromPersistValue (PersistList pvs) -- | Materialize a @SqlExpr (Value a)@. materializeExpr :: IdentInfo -> SqlExpr (Value a) -> (TLB.Builder, [PersistValue]) materializeExpr info (ERaw p f) = let (b, vals) = f info in (parensM p b, vals) materializeExpr info (ECompositeKey f) = let bs = f info in (uncommas $ map (parensM Parens) bs, []) -- | You may return tuples (up to 16-tuples) and tuples of tuples -- from a 'select' query. instance ( SqlSelect a ra , SqlSelect b rb ) => SqlSelect (a, b) (ra, rb) where sqlSelectCols esc (a, b) = uncommas' [ sqlSelectCols esc a , sqlSelectCols esc b ] sqlSelectColCount = uncurry (+) . (sqlSelectColCount *** sqlSelectColCount) . fromTuple where fromTuple :: Proxy (a,b) -> (Proxy a, Proxy b) fromTuple = const (Proxy, Proxy) sqlSelectProcessRow = let x = getType processRow getType :: SqlSelect a r => (z -> Either y (r,x)) -> Proxy a getType = const Proxy colCountFst = sqlSelectColCount x processRow row = let (rowFst, rowSnd) = splitAt colCountFst row in (,) <$> sqlSelectProcessRow rowFst <*> sqlSelectProcessRow rowSnd in colCountFst `seq` processRow -- Avoids recalculating 'colCountFst'. instance ( SqlSelect a ra , SqlSelect b rb , SqlSelect c rc ) => SqlSelect (a, b, c) (ra, rb, rc) where sqlSelectCols esc (a, b, c) = uncommas' [ sqlSelectCols esc a , sqlSelectCols esc b , sqlSelectCols esc c ] sqlSelectColCount = sqlSelectColCount . from3P sqlSelectProcessRow = fmap to3 . sqlSelectProcessRow from3P :: Proxy (a,b,c) -> Proxy ((a,b),c) from3P = const Proxy from3 :: (a,b,c) -> ((a,b),c) from3 (a,b,c) = ((a,b),c) to3 :: ((a,b),c) -> (a,b,c) to3 ((a,b),c) = (a,b,c) instance ( SqlSelect a ra , SqlSelect b rb , SqlSelect c rc , SqlSelect d rd ) => SqlSelect (a, b, c, d) (ra, rb, rc, rd) where sqlSelectCols esc (a, b, c, d) = uncommas' [ sqlSelectCols esc a , sqlSelectCols esc b , sqlSelectCols esc c , sqlSelectCols esc d ] sqlSelectColCount = sqlSelectColCount . from4P sqlSelectProcessRow = fmap to4 . sqlSelectProcessRow from4P :: Proxy (a,b,c,d) -> Proxy ((a,b),(c,d)) from4P = const Proxy from4 :: (a,b,c,d) -> ((a,b),(c,d)) from4 (a,b,c,d) = ((a,b),(c,d)) to4 :: ((a,b),(c,d)) -> (a,b,c,d) to4 ((a,b),(c,d)) = (a,b,c,d) instance ( SqlSelect a ra , SqlSelect b rb , SqlSelect c rc , SqlSelect d rd , SqlSelect e re ) => SqlSelect (a, b, c, d, e) (ra, rb, rc, rd, re) where sqlSelectCols esc (a, b, c, d, e) = uncommas' [ sqlSelectCols esc a , sqlSelectCols esc b , sqlSelectCols esc c , sqlSelectCols esc d , sqlSelectCols esc e ] sqlSelectColCount = sqlSelectColCount . from5P sqlSelectProcessRow = fmap to5 . sqlSelectProcessRow from5P :: Proxy (a,b,c,d,e) -> Proxy ((a,b),(c,d),e) from5P = const Proxy to5 :: ((a,b),(c,d),e) -> (a,b,c,d,e) to5 ((a,b),(c,d),e) = (a,b,c,d,e) instance ( SqlSelect a ra , SqlSelect b rb , SqlSelect c rc , SqlSelect d rd , SqlSelect e re , SqlSelect f rf ) => SqlSelect (a, b, c, d, e, f) (ra, rb, rc, rd, re, rf) where sqlSelectCols esc (a, b, c, d, e, f) = uncommas' [ sqlSelectCols esc a , sqlSelectCols esc b , sqlSelectCols esc c , sqlSelectCols esc d , sqlSelectCols esc e , sqlSelectCols esc f ] sqlSelectColCount = sqlSelectColCount . from6P sqlSelectProcessRow = fmap to6 . sqlSelectProcessRow from6P :: Proxy (a,b,c,d,e,f) -> Proxy ((a,b),(c,d),(e,f)) from6P = const Proxy to6 :: ((a,b),(c,d),(e,f)) -> (a,b,c,d,e,f) to6 ((a,b),(c,d),(e,f)) = (a,b,c,d,e,f) instance ( SqlSelect a ra , SqlSelect b rb , SqlSelect c rc , SqlSelect d rd , SqlSelect e re , SqlSelect f rf , SqlSelect g rg ) => SqlSelect (a, b, c, d, e, f, g) (ra, rb, rc, rd, re, rf, rg) where sqlSelectCols esc (a, b, c, d, e, f, g) = uncommas' [ sqlSelectCols esc a , sqlSelectCols esc b , sqlSelectCols esc c , sqlSelectCols esc d , sqlSelectCols esc e , sqlSelectCols esc f , sqlSelectCols esc g ] sqlSelectColCount = sqlSelectColCount . from7P sqlSelectProcessRow = fmap to7 . sqlSelectProcessRow from7P :: Proxy (a,b,c,d,e,f,g) -> Proxy ((a,b),(c,d),(e,f),g) from7P = const Proxy to7 :: ((a,b),(c,d),(e,f),g) -> (a,b,c,d,e,f,g) to7 ((a,b),(c,d),(e,f),g) = (a,b,c,d,e,f,g) instance ( SqlSelect a ra , SqlSelect b rb , SqlSelect c rc , SqlSelect d rd , SqlSelect e re , SqlSelect f rf , SqlSelect g rg , SqlSelect h rh ) => SqlSelect (a, b, c, d, e, f, g, h) (ra, rb, rc, rd, re, rf, rg, rh) where sqlSelectCols esc (a, b, c, d, e, f, g, h) = uncommas' [ sqlSelectCols esc a , sqlSelectCols esc b , sqlSelectCols esc c , sqlSelectCols esc d , sqlSelectCols esc e , sqlSelectCols esc f , sqlSelectCols esc g , sqlSelectCols esc h ] sqlSelectColCount = sqlSelectColCount . from8P sqlSelectProcessRow = fmap to8 . sqlSelectProcessRow from8P :: Proxy (a,b,c,d,e,f,g,h) -> Proxy ((a,b),(c,d),(e,f),(g,h)) from8P = const Proxy to8 :: ((a,b),(c,d),(e,f),(g,h)) -> (a,b,c,d,e,f,g,h) to8 ((a,b),(c,d),(e,f),(g,h)) = (a,b,c,d,e,f,g,h) instance ( SqlSelect a ra , SqlSelect b rb , SqlSelect c rc , SqlSelect d rd , SqlSelect e re , SqlSelect f rf , SqlSelect g rg , SqlSelect h rh , SqlSelect i ri ) => SqlSelect (a, b, c, d, e, f, g, h, i) (ra, rb, rc, rd, re, rf, rg, rh, ri) where sqlSelectCols esc (a, b, c, d, e, f, g, h, i) = uncommas' [ sqlSelectCols esc a , sqlSelectCols esc b , sqlSelectCols esc c , sqlSelectCols esc d , sqlSelectCols esc e , sqlSelectCols esc f , sqlSelectCols esc g , sqlSelectCols esc h , sqlSelectCols esc i ] sqlSelectColCount = sqlSelectColCount . from9P sqlSelectProcessRow = fmap to9 . sqlSelectProcessRow from9P :: Proxy (a,b,c,d,e,f,g,h,i) -> Proxy ((a,b),(c,d),(e,f),(g,h),i) from9P = const Proxy to9 :: ((a,b),(c,d),(e,f),(g,h),i) -> (a,b,c,d,e,f,g,h,i) to9 ((a,b),(c,d),(e,f),(g,h),i) = (a,b,c,d,e,f,g,h,i) instance ( SqlSelect a ra , SqlSelect b rb , SqlSelect c rc , SqlSelect d rd , SqlSelect e re , SqlSelect f rf , SqlSelect g rg , SqlSelect h rh , SqlSelect i ri , SqlSelect j rj ) => SqlSelect (a, b, c, d, e, f, g, h, i, j) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj) where sqlSelectCols esc (a, b, c, d, e, f, g, h, i, j) = uncommas' [ sqlSelectCols esc a , sqlSelectCols esc b , sqlSelectCols esc c , sqlSelectCols esc d , sqlSelectCols esc e , sqlSelectCols esc f , sqlSelectCols esc g , sqlSelectCols esc h , sqlSelectCols esc i , sqlSelectCols esc j ] sqlSelectColCount = sqlSelectColCount . from10P sqlSelectProcessRow = fmap to10 . sqlSelectProcessRow from10P :: Proxy (a,b,c,d,e,f,g,h,i,j) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j)) from10P = const Proxy to10 :: ((a,b),(c,d),(e,f),(g,h),(i,j)) -> (a,b,c,d,e,f,g,h,i,j) to10 ((a,b),(c,d),(e,f),(g,h),(i,j)) = (a,b,c,d,e,f,g,h,i,j) instance ( SqlSelect a ra , SqlSelect b rb , SqlSelect c rc , SqlSelect d rd , SqlSelect e re , SqlSelect f rf , SqlSelect g rg , SqlSelect h rh , SqlSelect i ri , SqlSelect j rj , SqlSelect k rk ) => SqlSelect (a, b, c, d, e, f, g, h, i, j, k) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj, rk) where sqlSelectCols esc (a, b, c, d, e, f, g, h, i, j, k) = uncommas' [ sqlSelectCols esc a , sqlSelectCols esc b , sqlSelectCols esc c , sqlSelectCols esc d , sqlSelectCols esc e , sqlSelectCols esc f , sqlSelectCols esc g , sqlSelectCols esc h , sqlSelectCols esc i , sqlSelectCols esc j , sqlSelectCols esc k ] sqlSelectColCount = sqlSelectColCount . from11P sqlSelectProcessRow = fmap to11 . sqlSelectProcessRow from11P :: Proxy (a,b,c,d,e,f,g,h,i,j,k) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),k) from11P = const Proxy to11 :: ((a,b),(c,d),(e,f),(g,h),(i,j),k) -> (a,b,c,d,e,f,g,h,i,j,k) to11 ((a,b),(c,d),(e,f),(g,h),(i,j),k) = (a,b,c,d,e,f,g,h,i,j,k) instance ( SqlSelect a ra , SqlSelect b rb , SqlSelect c rc , SqlSelect d rd , SqlSelect e re , SqlSelect f rf , SqlSelect g rg , SqlSelect h rh , SqlSelect i ri , SqlSelect j rj , SqlSelect k rk , SqlSelect l rl ) => SqlSelect (a, b, c, d, e, f, g, h, i, j, k, l) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj, rk, rl) where sqlSelectCols esc (a, b, c, d, e, f, g, h, i, j, k, l) = uncommas' [ sqlSelectCols esc a , sqlSelectCols esc b , sqlSelectCols esc c , sqlSelectCols esc d , sqlSelectCols esc e , sqlSelectCols esc f , sqlSelectCols esc g , sqlSelectCols esc h , sqlSelectCols esc i , sqlSelectCols esc j , sqlSelectCols esc k , sqlSelectCols esc l ] sqlSelectColCount = sqlSelectColCount . from12P sqlSelectProcessRow = fmap to12 . sqlSelectProcessRow from12P :: Proxy (a,b,c,d,e,f,g,h,i,j,k,l) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l)) from12P = const Proxy to12 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l)) -> (a,b,c,d,e,f,g,h,i,j,k,l) to12 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l)) = (a,b,c,d,e,f,g,h,i,j,k,l) instance ( SqlSelect a ra , SqlSelect b rb , SqlSelect c rc , SqlSelect d rd , SqlSelect e re , SqlSelect f rf , SqlSelect g rg , SqlSelect h rh , SqlSelect i ri , SqlSelect j rj , SqlSelect k rk , SqlSelect l rl , SqlSelect m rm ) => SqlSelect (a, b, c, d, e, f, g, h, i, j, k, l, m) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj, rk, rl, rm) where sqlSelectCols esc (a, b, c, d, e, f, g, h, i, j, k, l, m) = uncommas' [ sqlSelectCols esc a , sqlSelectCols esc b , sqlSelectCols esc c , sqlSelectCols esc d , sqlSelectCols esc e , sqlSelectCols esc f , sqlSelectCols esc g , sqlSelectCols esc h , sqlSelectCols esc i , sqlSelectCols esc j , sqlSelectCols esc k , sqlSelectCols esc l , sqlSelectCols esc m ] sqlSelectColCount = sqlSelectColCount . from13P sqlSelectProcessRow = fmap to13 . sqlSelectProcessRow from13P :: Proxy (a,b,c,d,e,f,g,h,i,j,k,l,m) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),m) from13P = const Proxy to13 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),m) -> (a,b,c,d,e,f,g,h,i,j,k,l,m) to13 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),m) = (a,b,c,d,e,f,g,h,i,j,k,l,m) instance ( SqlSelect a ra , SqlSelect b rb , SqlSelect c rc , SqlSelect d rd , SqlSelect e re , SqlSelect f rf , SqlSelect g rg , SqlSelect h rh , SqlSelect i ri , SqlSelect j rj , SqlSelect k rk , SqlSelect l rl , SqlSelect m rm , SqlSelect n rn ) => SqlSelect (a, b, c, d, e, f, g, h, i, j, k, l, m, n) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj, rk, rl, rm, rn) where sqlSelectCols esc (a, b, c, d, e, f, g, h, i, j, k, l, m, n) = uncommas' [ sqlSelectCols esc a , sqlSelectCols esc b , sqlSelectCols esc c , sqlSelectCols esc d , sqlSelectCols esc e , sqlSelectCols esc f , sqlSelectCols esc g , sqlSelectCols esc h , sqlSelectCols esc i , sqlSelectCols esc j , sqlSelectCols esc k , sqlSelectCols esc l , sqlSelectCols esc m , sqlSelectCols esc n ] sqlSelectColCount = sqlSelectColCount . from14P sqlSelectProcessRow = fmap to14 . sqlSelectProcessRow from14P :: Proxy (a,b,c,d,e,f,g,h,i,j,k,l,m,n) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n)) from14P = const Proxy to14 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n)) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n) to14 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n)) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n) instance ( SqlSelect a ra , SqlSelect b rb , SqlSelect c rc , SqlSelect d rd , SqlSelect e re , SqlSelect f rf , SqlSelect g rg , SqlSelect h rh , SqlSelect i ri , SqlSelect j rj , SqlSelect k rk , SqlSelect l rl , SqlSelect m rm , SqlSelect n rn , SqlSelect o ro ) => SqlSelect (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj, rk, rl, rm, rn, ro) where sqlSelectCols esc (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) = uncommas' [ sqlSelectCols esc a , sqlSelectCols esc b , sqlSelectCols esc c , sqlSelectCols esc d , sqlSelectCols esc e , sqlSelectCols esc f , sqlSelectCols esc g , sqlSelectCols esc h , sqlSelectCols esc i , sqlSelectCols esc j , sqlSelectCols esc k , sqlSelectCols esc l , sqlSelectCols esc m , sqlSelectCols esc n , sqlSelectCols esc o ] sqlSelectColCount = sqlSelectColCount . from15P sqlSelectProcessRow = fmap to15 . sqlSelectProcessRow from15P :: Proxy (a,b,c,d,e,f,g,h,i,j,k,l,m,n, o) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),o) from15P = const Proxy to15 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),o) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) to15 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),o) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) instance ( SqlSelect a ra , SqlSelect b rb , SqlSelect c rc , SqlSelect d rd , SqlSelect e re , SqlSelect f rf , SqlSelect g rg , SqlSelect h rh , SqlSelect i ri , SqlSelect j rj , SqlSelect k rk , SqlSelect l rl , SqlSelect m rm , SqlSelect n rn , SqlSelect o ro , SqlSelect p rp ) => SqlSelect (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj, rk, rl, rm, rn, ro, rp) where sqlSelectCols esc (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) = uncommas' [ sqlSelectCols esc a , sqlSelectCols esc b , sqlSelectCols esc c , sqlSelectCols esc d , sqlSelectCols esc e , sqlSelectCols esc f , sqlSelectCols esc g , sqlSelectCols esc h , sqlSelectCols esc i , sqlSelectCols esc j , sqlSelectCols esc k , sqlSelectCols esc l , sqlSelectCols esc m , sqlSelectCols esc n , sqlSelectCols esc o , sqlSelectCols esc p ] sqlSelectColCount = sqlSelectColCount . from16P sqlSelectProcessRow = fmap to16 . sqlSelectProcessRow from16P :: Proxy (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p)) from16P = const Proxy to16 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p)) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) to16 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p)) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) -- | Insert a 'PersistField' for every selected value. insertSelect :: (MonadIO m, PersistEntity a) => SqlQuery (SqlExpr (Insertion a)) -> SqlPersistT m () insertSelect = liftM (const ()) . rawEsqueleto INSERT_INTO . fmap EInsertFinal -- | Insert a 'PersistField' for every unique selected value. insertSelectDistinct :: (MonadIO m, PersistEntity a) => SqlQuery (SqlExpr (Insertion a)) -> SqlPersistT m () insertSelectDistinct = insertSelect . distinct {-# DEPRECATED insertSelectDistinct "Since 2.2.4: use 'insertSelect' and 'distinct'." #-} esqueleto-2.4.1/src/Database/Esqueleto/Internal/PersistentImport.hs0000644000000000000000000000107712406216242023622 0ustar0000000000000000-- | Re-export "Database.Persist.Sql" without any clashes with -- @esqueleto@. module Database.Esqueleto.Internal.PersistentImport ( module Database.Persist.Sql ) where import Database.Persist.Sql hiding ( BackendSpecificFilter, Filter(..), PersistQuery(..), SelectOpt(..) , Update(..), delete, deleteWhereCount, updateWhereCount, selectList , selectKeysList, deleteCascadeWhere, (=.), (+=.), (-=.), (*=.), (/=.) , (==.), (!=.), (<.), (>.), (<=.), (>=.), (<-.), (/<-.), (||.) , listToJSON, mapToJSON, getPersistMap, limitOffsetOrder, selectSource , update ) esqueleto-2.4.1/test/Test.hs0000644000000000000000000014756512562407464014200 0ustar0000000000000000{-# 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.Applicative ((<$>)) import Control.Arrow ((&&&)) import Control.Exception (IOException) 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.List (sortBy) import Data.Monoid ((<>)) import Data.Ord (comparing) import Database.Esqueleto #if defined (WITH_POSTGRESQL) import Database.Persist.Postgresql (withPostgresqlConn) #elif defined (WITH_MYSQL) import Database.Persist.MySQL ( withMySQLConn , connectHost , connectDatabase , connectUser , connectPassword , defaultConnectInfo) #else import Database.Persist.Sqlite (withSqliteConn) #if MIN_VERSION_persistent_sqlite(2,1,3) import Database.Sqlite (SqliteException) #endif #endif import Database.Persist.TH import Test.Hspec 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.PostgreSQL as EP 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 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 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 "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` 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` 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))) #if MIN_VERSION_persistent_sqlite(2,1,3) ) `shouldThrow` (\(_ :: SqliteException) -> True) #else ) `shouldThrow` (\(_ :: IOException) -> True) #endif #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 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 -- 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 "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 -> do 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 , PersistStore (PersistEntityBackend val) , MonadIO m , PersistEntity val ) => val -> ReaderT (PersistEntityBackend val) 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 BlogPost)) -> return () delete $ from $ \(_ :: SqlExpr (Entity Follow)) -> return () delete $ from $ \(_ :: SqlExpr (Entity Person)) -> 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 esqueleto-2.4.1/LICENSE0000644000000000000000000000276212021120012012703 0ustar0000000000000000Copyright (c) 2012, Felipe Lessa All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Felipe Lessa nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. esqueleto-2.4.1/Setup.hs0000644000000000000000000000005612021120012013324 0ustar0000000000000000import Distribution.Simple main = defaultMain esqueleto-2.4.1/esqueleto.cabal0000644000000000000000000000772112562407464014725 0ustar0000000000000000name: esqueleto version: 2.4.1 synopsis: Type-safe EDSL for SQL queries on persistent backends. homepage: https://github.com/prowdsponsor/esqueleto license: BSD3 license-file: LICENSE author: Felipe Lessa maintainer: felipe.lessa@gmail.com copyright: (c) 2012-2015 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 . . 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. source-repository head type: git location: git://github.com/prowdsponsor/esqueleto.git Flag postgresql Description: test postgresql. default is to test sqlite. Default: False Flag mysql Description: test MySQL/MariaDB. default is to test sqlite. Default: False library exposed-modules: Database.Esqueleto Database.Esqueleto.PostgreSQL Database.Esqueleto.Internal.Language Database.Esqueleto.Internal.Sql other-modules: Database.Esqueleto.Internal.PersistentImport build-depends: base >= 4.5 && < 4.9 , bytestring , text >= 0.11 && < 1.3 , persistent >= 2.1.1.7 && < 2.3 , transformers >= 0.2 , unordered-containers >= 0.2 , tagged >= 0.2 , monad-logger , conduit >= 1.1 , resourcet >= 1.1 , blaze-html hs-source-dirs: src/ ghc-options: -Wall test-suite test type: exitcode-stdio-1.0 ghc-options: -Wall hs-source-dirs: test main-is: Test.hs 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 , containers , HUnit , QuickCheck , hspec >= 1.8 , persistent-sqlite >= 2.1 , 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 if flag(mysql) build-depends: mysql-simple >= 0.2.2.3 , mysql >= 0.1.1.3 , persistent-mysql >= 2.0 cpp-options: -DWITH_MYSQL