esqueleto-3.3.3.2/src/0000755000000000000000000000000013454457034012654 5ustar0000000000000000esqueleto-3.3.3.2/src/Database/0000755000000000000000000000000013640147635014360 5ustar0000000000000000esqueleto-3.3.3.2/src/Database/Esqueleto/0000755000000000000000000000000013640147635016326 5ustar0000000000000000esqueleto-3.3.3.2/src/Database/Esqueleto/Internal/0000755000000000000000000000000013674150634020102 5ustar0000000000000000esqueleto-3.3.3.2/src/Database/Esqueleto/PostgreSQL/0000755000000000000000000000000013523055213020317 5ustar0000000000000000esqueleto-3.3.3.2/src/Database/Esqueleto/PostgreSQL/JSON/0000755000000000000000000000000013523055213021070 5ustar0000000000000000esqueleto-3.3.3.2/test/0000755000000000000000000000000013640147635013044 5ustar0000000000000000esqueleto-3.3.3.2/test/Common/0000755000000000000000000000000013674150634014274 5ustar0000000000000000esqueleto-3.3.3.2/test/MySQL/0000755000000000000000000000000013554623526014013 5ustar0000000000000000esqueleto-3.3.3.2/test/PostgreSQL/0000755000000000000000000000000013640445040015036 5ustar0000000000000000esqueleto-3.3.3.2/test/SQLite/0000755000000000000000000000000013462122000014162 5ustar0000000000000000esqueleto-3.3.3.2/src/Database/Esqueleto.hs0000644000000000000000000003326013640147635016666 0ustar0000000000000000{-# LANGUAGE FlexibleContexts, FlexibleInstances, GADTs, RankNTypes #-} -- | 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.Persist as P -- @ -- -- or import @esqueleto@ itself qualified: -- -- @ -- -- For a module that uses esqueleto just on some queries. -- import Database.Persist -- 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 where_, on, groupBy, orderBy, rand, asc, desc, limit, offset , distinct, distinctOn, don, distinctOnOrderBy, having, locking , sub_select, (^.), (?.) , val, isNothing, just, nothing, joinV, withNonNull , countRows, count, countDistinct , not_, (==.), (>=.), (>.), (<=.), (<.), (!=.), (&&.), (||.) , between, (+.), (-.), (/.), (*.) , random_, round_, ceiling_, floor_ , min_, max_, sum_, avg_, castNum, castNumM , coalesce, coalesceDefault , lower_, upper_, trim_, ltrim_, rtrim_, length_, left_, right_ , like, ilike, (%), concat_, (++.), castString , subList_select, valList, justList , in_, notIn, exists, notExists , set, (=.), (+=.), (-=.), (*=.), (/=.) , case_, toBaseId , subSelect , subSelectMaybe , subSelectCount , subSelectForeign , subSelectList , subSelectUnsafe , ToBaseId(..) , when_ , then_ , else_ , from , Value(..) , ValueList(..) , OrderBy , DistinctOn , LockingKind(..) , SqlString -- ** Joins , InnerJoin(..) , CrossJoin(..) , LeftOuterJoin(..) , RightOuterJoin(..) , FullOuterJoin(..) , JoinKind(..) , OnClauseWithoutMatchingJoinException(..) -- * SQL backend , SqlQuery , SqlExpr , SqlEntity , select , selectSource , delete , deleteCount , update , updateCount , insertSelect , insertSelectCount , (<#) , (<&>) -- ** Rendering Queries , renderQueryToText , renderQuerySelect , renderQueryUpdate , renderQueryDelete , renderQueryInsertInto -- * Internal.Language , From -- * RDBMS-specific modules -- $rdbmsSpecificModules -- * Helpers , valkey , valJ , associateJoin -- * 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 qualified Data.Map.Strict as Map 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 most widely 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' to 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, you 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 -- of the @Follow@ entity: -- -- @ -- SELECT P1.*, Follow.*, P2.* -- FROM Person AS P1 -- INNER JOIN Follow ON P1.id = Follow.follower -- INNER JOIN Person AS 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' (p1 '^.' PersonId '==.' f '^.' FollowFollower) -- 'on' (p2 '^.' PersonId '==.' f '^.' FollowFollowed) -- return (p1, f, p2) -- @ -- -- 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 :: (ToBackendKey SqlBackend entity, PersistField (Key entity)) => Int64 -> SqlExpr (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 :: (PersistField (Key entity)) => Value (Key entity) -> SqlExpr (Value (Key entity)) valJ = val . unValue ---------------------------------------------------------------------- -- | Synonym for 'Database.Persist.Store.delete' that does not -- clash with @esqueleto@'s 'delete'. deleteKey :: ( PersistStore backend , BaseBackend backend ~ PersistEntityBackend val , MonadIO m , PersistEntity val ) => Key val -> ReaderT backend m () deleteKey = Database.Persist.delete -- | Avoid N+1 queries and join entities into a map structure -- @ -- getFoosAndNestedBarsFromParent :: ParentId -> (Map (Key Foo) (Foo, [Maybe (Entity Bar)])) -- getFoosAndNestedBarsFromParent parentId = 'fmap' associateJoin $ 'select' $ -- 'from' $ \\(foo `'LeftOuterJoin`` bar) -> do -- 'on' (bar '?.' BarFooId '==.' foo '^.' FooId) -- 'where_' (foo '^.' FooParentId '==.' 'val' parentId) -- 'pure' (foo, bar) -- @ -- -- @since 3.1.2 associateJoin :: forall e1 e0 . Ord (Key e0) => [(Entity e0, e1)] -> Map.Map (Key e0) (e0, [e1]) associateJoin = foldr f start where start = Map.empty f (one, many) = Map.insertWith (\(oneOld, manyOld) (_, manyNew) -> (oneOld, manyNew ++ manyOld )) (entityKey one) (entityVal one, [many]) esqueleto-3.3.3.2/src/Database/Esqueleto/Experimental.hs0000644000000000000000000007211013640147635021320 0ustar0000000000000000{-# LANGUAGE CPP , DataKinds , FlexibleContexts , FlexibleInstances , FunctionalDependencies , GADTs , MultiParamTypeClasses , TypeOperators , TypeFamilies , UndecidableInstances , OverloadedStrings #-} module Database.Esqueleto.Experimental ( -- * Setup -- $setup -- * Introduction -- $introduction -- * A New Syntax -- $new-syntax -- * Documentation SqlSetOperation(..) , From(..) , on , from , (:&)(..) -- * Internals , ToFrom(..) , ToFromT , ToMaybe(..) , ToMaybeT , ToAlias(..) , ToAliasT , ToAliasReference(..) , ToAliasReferenceT ) where import qualified Control.Monad.Trans.Writer as W import qualified Control.Monad.Trans.State as S import Control.Monad.Trans.Class (lift) #if __GLASGOW_HASKELL__ < 804 import Data.Semigroup #endif import Data.Proxy (Proxy(..)) import Database.Esqueleto.Internal.PersistentImport import Database.Esqueleto.Internal.Internal ( SqlExpr(..) , InnerJoin(..) , CrossJoin(..) , LeftOuterJoin(..) , RightOuterJoin(..) , FullOuterJoin(..) , FromClause(..) , SqlQuery(..) , SideData(..) , Value(..) , JoinKind(..) , newIdentFor , SqlSelect(..) , Mode(..) , toRawSql , Ident(..) , to3, to4, to5, to6, to7, to8 , from3, from4, from5, from6, from7, from8 , veryUnsafeCoerceSqlExprValue ) import GHC.TypeLits -- $setup -- -- If you're already using "Database.Esqueleto", then you can get -- started using this module just by changing your imports slightly, -- as well as enabling the [TypeApplications](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#extension-TypeApplications) extension. -- -- @ -- {-\# LANGUAGE TypeApplications \#-} -- -- ... -- -- import Database.Esqueleto hiding (on, from) -- import Database.Esqueleto.Experimental -- @ ---------------------------------------------------------------------- -- $introduction -- -- This module is fully backwards-compatible extension to the @esqueleto@ -- EDSL that expands subquery functionality and enables -- [SQL set operations](https://en.wikipedia.org/wiki/Set_operations_(SQL\)) -- to be written directly in Haskell. Specifically, this enables: -- -- * Subqueries in 'JOIN' statements -- * 'UNION' -- * 'UNION' 'ALL' -- * 'INTERSECT' -- * 'EXCEPT' -- -- As a consequence of this, several classes of runtime errors are now -- caught at compile time. This includes missing 'on' clauses and improper -- handling of @Maybe@ values in outer joins. -- -- This module can be used in conjunction with the main "Database.Esqueleto" -- module, but doing so requires qualified imports to avoid ambiguous -- definitions of 'on' and 'from', which are defined in both modules. -- -- Below we will give an overview of how to use this module and the -- features it enables. ---------------------------------------------------------------------- -- $new-syntax -- -- This module introduces a new syntax that serves to enable the aforementioned -- features. This new syntax also changes how joins written in the @esqueleto@ -- EDSL to more closely resemble the underlying SQL. -- -- For our examples, we'll use a schema similar to the one in the Getting Started -- section of "Database.Esqueleto": -- -- @ -- 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 -- |] -- @ -- -- === Example 1: Simple select -- -- Let's select all people who are named \"John\". -- -- ==== "Database.Esqueleto": -- -- @ -- select $ -- from $ \\people -> do -- where_ (people ^. PersonName ==. val \"John\") -- pure people -- @ -- -- ==== "Database.Esqueleto.Experimental": -- -- @ -- select $ do -- people <- from $ Table \@Person -- where_ (people ^. PersonName ==. val \"John\") -- pure people -- @ -- -- -- === Example 2: Select with join -- -- Let's select all people and their blog posts who are over -- the age of 18. -- -- ==== "Database.Esqueleto": -- -- @ -- select $ -- from $ \\(people \`LeftOuterJoin\` blogPosts) -> do -- on (people ^. PersonId ==. blogPosts ?. BlogPostAuthorId) -- where_ (people ^. PersonAge >. val 18) -- pure (people, blogPosts) -- @ -- -- ==== "Database.Esqueleto.Experimental": -- -- Here we use the ':&' operator to pattern match against the joined tables. -- -- @ -- select $ do -- (people :& blogPosts) <- -- from $ Table \@Person -- \`LeftOuterJoin\` Table \@BlogPost -- \`on\` (\\(people :& blogPosts) -> -- people ^. PersonId ==. blogPosts ?. BlogPostAuthorId) -- where_ (people ^. PersonAge >. val 18) -- pure (people, blogPosts) -- @ -- -- === Example 3: Select with multi-table join -- -- Let's select all people who follow a person named \"John\", including -- the name of each follower. -- -- ==== "Database.Esqueleto": -- -- @ -- select $ -- from $ \\( -- people1 -- \`InnerJoin\` followers -- \`InnerJoin\` people2 -- ) -> do -- on (people1 ^. PersonId ==. followers ^. FollowFollowed) -- on (followers ^. FollowFollower ==. people2 ^. PersonId) -- where_ (people1 ^. PersonName ==. val \"John\") -- pure (followers, people2) -- @ -- -- ==== "Database.Esqueleto.Experimental": -- -- In this version, with each successive 'on' clause, only the tables -- we have already joined into are in scope, so we must pattern match -- accordingly. In this case, in the second 'InnerJoin', we do not use -- the first `Person` reference, so we use @_@ as a placeholder to -- ignore it. This prevents a possible runtime error where a table -- is referenced before it appears in the sequence of 'JOIN's. -- -- @ -- select $ do -- (people1 :& followers :& people2) <- -- from $ Table \@Person -- \`InnerJoin` Table \@Follow -- \`on\` (\\(people1 :& followers) -> -- people1 ^. PersonId ==. followers ^. FollowFollowed) -- \`InnerJoin` Table \@Person -- \`on\` (\\(_ :& followers :& people2) -> -- followers ^. FollowFollower ==. people2 ^. PersonId) -- where_ (people1 ^. PersonName ==. val \"John\") -- pure (followers, people2) -- @ -- -- === Example 4: Counting results of a subquery -- -- Let's count the number of people who have posted at least 10 posts -- -- ==== "Database.Esqueleto": -- -- @ -- select $ pure $ subSelectCount $ -- from $ \\( -- people -- \`InnerJoin\` blogPosts -- ) -> do -- on (people ^. PersonId ==. blogPosts ^. BlogPostAuthorId) -- groupBy (people ^. PersonId) -- having ((count $ blogPosts ^. BlogPostId) >. val 10) -- pure people -- @ -- -- ==== "Database.Esqueleto.Experimental": -- -- @ -- select $ do -- peopleWithPosts <- -- from $ SelectQuery $ do -- (people :& blogPosts) <- -- from $ Table \@Person -- \`InnerJoin\` Table \@BlogPost -- \`on\` (\\(p :& bP) -> -- p ^. PersonId ==. bP ^. BlogPostAuthorId) -- groupBy (people ^. PersonId) -- having ((count $ blogPosts ^. BlogPostId) >. val 10) -- pure people -- pure $ count (peopleWithPosts ^. PersonId) -- @ -- -- We now have the ability to refactor this -- -- === Example 5: Sorting the results of a UNION with limits -- -- Out of all of the posts created by a person and the people they follow, -- generate a list of the first 25 posts, sorted alphabetically. -- -- ==== "Database.Esqueleto": -- -- Since 'UNION' is not supported, this requires using `Database.Esqueleto.rawSql`. (Not shown) -- -- ==== "Database.Esqueleto.Experimental": -- -- Since this module supports all set operations (see `SqlSetOperation`), we can use -- `Union` to write this query. -- -- @ -- select $ do -- (authors, blogPosts) <- from $ -- (SelectQuery $ do -- (author :& blogPost) <- -- from $ Table \@Person -- \`InnerJoin\` Table \@BlogPost -- \`on\` (\\(a :& bP) -> -- a ^. PersonId ==. bP ^. BlogPostAuthorId) -- where_ (author ^. PersonId ==. val currentPersonId) -- pure (author, blogPost) -- ) -- \`Union\` -- (SelectQuery $ do -- (follow :& blogPost :& author) <- -- from $ Table \@Follow -- \`InnerJoin\` Table \@BlogPost -- \`on\` (\\(f :& bP) -> -- f ^. FollowFollowed ==. bP ^. BlogPostAuthorId) -- \`InnerJoin\` Table \@Person -- \`on\` (\\(_ :& bP :& a) -> -- bP ^. BlogPostAuthorId ==. a ^. PersonId) -- where_ (follow ^. FollowFollower ==. val currentPersonId) -- pure (author, blogPost) -- ) -- orderBy [ asc (blogPosts ^. BlogPostTitle) ] -- limit 25 -- pure (authors, blogPosts) -- @ -- | A left-precedence pair. Pronounced \"and\". Used to represent expressions -- that have been joined together. -- -- The precedence behavior can be demonstrated by: -- -- @ -- a :& b :& c == ((a :& b) :& c) -- @ -- -- See the examples at the beginning of this module to see how this -- operator is used in 'JOIN' operations. data (:&) a b = a :& b infixl 2 :& -- | Data type that represents SQL set operations. This includes -- 'UNION', 'UNION' 'ALL', 'EXCEPT', and 'INTERSECT'. This data -- type is defined as a binary tree, with @SelectQuery@ on the leaves. -- -- Each constructor corresponding to the aforementioned set operations -- can be used as an infix function in a @from@ to help with readability -- and lead to code that closely resembles the underlying SQL. For example, -- -- @ -- select $ from $ -- (SelectQuery ...) -- \`Union\` -- (SelectQuery ...) -- @ -- -- is translated into -- -- @ -- SELECT * FROM ( -- (SELECT * FROM ...) -- UNION -- (SELECT * FROM ...) -- ) -- @ -- -- @SelectQuery@ can be used without any of the set operations to construct -- a subquery. This can be used in 'JOIN' trees. For example, -- -- @ -- select $ from $ -- Table \@SomeTable -- \`InnerJoin\` (SelectQuery ...) -- \`on\` ... -- @ -- -- is translated into -- -- @ -- SELECT * -- FROM SomeTable -- INNER JOIN (SELECT * FROM ...) -- ON ... -- @ data SqlSetOperation a = Union (SqlSetOperation a) (SqlSetOperation a) | UnionAll (SqlSetOperation a) (SqlSetOperation a) | Except (SqlSetOperation a) (SqlSetOperation a) | Intersect (SqlSetOperation a) (SqlSetOperation a) | SelectQuery (SqlQuery a) -- | Data type that represents the syntax of a 'JOIN' tree. In practice, -- only the @Table@ constructor is used directly when writing queries. For example, -- -- @ -- select $ from $ Table \@People -- @ data From a where Table :: PersistEntity ent => From (SqlExpr (Entity ent)) SubQuery :: (SqlSelect a' r, SqlSelect a'' r', ToAlias a, a' ~ ToAliasT a, ToAliasReference a', ToAliasReferenceT a' ~ a'') => SqlQuery a -> From a'' SqlSetOperation :: (SqlSelect a' r, ToAlias a, a' ~ ToAliasT a, ToAliasReference a', ToAliasReferenceT a' ~ a'') => SqlSetOperation a -> From a'' InnerJoinFrom :: From a -> (From b, (a :& b) -> SqlExpr (Value Bool)) -> From (a :& b) CrossJoinFrom :: From a -> From b -> From (a :& b) LeftJoinFrom :: ToMaybe b => From a -> (From b, (a :& ToMaybeT b) -> SqlExpr (Value Bool)) -> From (a :& ToMaybeT b) RightJoinFrom :: ToMaybe a => From a -> (From b, (ToMaybeT a :& b) -> SqlExpr (Value Bool)) -> From (ToMaybeT a :& b) FullJoinFrom :: (ToMaybe a, ToMaybe b ) => From a -> (From b, (ToMaybeT a :& ToMaybeT b) -> SqlExpr (Value Bool)) -> From (ToMaybeT a :& ToMaybeT b) -- | An @ON@ clause that describes how two tables are related. This should be -- used as an infix operator after a 'JOIN'. For example, -- -- @ -- select $ -- from $ Table \@Person -- \`InnerJoin\` Table \@BlogPost -- \`on\` (\\(p :& bP) -> -- p ^. PersonId ==. bP ^. BlogPostAuthorId) -- @ -- on :: ToFrom a => a -> (b -> SqlExpr (Value Bool)) -> (a, b -> SqlExpr (Value Bool)) on = (,) infix 9 `on` type JoinErrorMsg jk = 'Text "Missing on statement for " ':<>: 'Text jk type family ToFromT a where ToFromT (From a) = a ToFromT (SqlSetOperation a) = ToAliasReferenceT (ToAliasT a) ToFromT (LeftOuterJoin a (b, c -> SqlExpr (Value Bool))) = c ToFromT (FullOuterJoin a (b, c -> SqlExpr (Value Bool))) = c ToFromT (RightOuterJoin a (b, c -> SqlExpr (Value Bool))) = c ToFromT (InnerJoin a (b, c -> SqlExpr (Value Bool))) = c ToFromT (CrossJoin a b) = (ToFromT a :& ToFromT b) ToFromT (InnerJoin a b) = TypeError (JoinErrorMsg "InnerJoin") ToFromT (LeftOuterJoin a b) = TypeError (JoinErrorMsg "LeftOuterJoin") ToFromT (RightOuterJoin a b) = TypeError (JoinErrorMsg "RightOuterJoin") ToFromT (FullOuterJoin a b) = TypeError (JoinErrorMsg "FullOuterJoin") {-- Type class magic to allow the use of the `InnerJoin` family of data constructors in from --} class ToFrom a where toFrom :: a -> From (ToFromT a) instance ToFrom (From a) where toFrom = id instance {-# OVERLAPPABLE #-} ToFrom (InnerJoin a b) where toFrom = undefined instance {-# OVERLAPPABLE #-} ToFrom (LeftOuterJoin a b) where toFrom = undefined instance {-# OVERLAPPABLE #-} ToFrom (RightOuterJoin a b) where toFrom = undefined instance {-# OVERLAPPABLE #-} ToFrom (FullOuterJoin a b) where toFrom = undefined instance (SqlSelect a' r,SqlSelect a'' r', ToAlias a, a' ~ ToAliasT a, ToAliasReference a', ToAliasReferenceT a' ~ a'') => ToFrom (SqlSetOperation a) where -- If someone uses just a plain SelectQuery it should behave like a normal subquery toFrom (SelectQuery q) = SubQuery q -- Otherwise use the SqlSetOperation toFrom q = SqlSetOperation q instance (ToFrom a, ToFromT a ~ a', ToFrom b, ToFromT b ~ b', ToMaybe b', mb ~ ToMaybeT b') => ToFrom (LeftOuterJoin a (b, (a' :& mb) -> SqlExpr (Value Bool))) where toFrom (LeftOuterJoin lhs (rhs, on')) = LeftJoinFrom (toFrom lhs) (toFrom rhs, on') instance (ToFrom a, ToFromT a ~ a', ToFrom b, ToFromT b ~ b', ToMaybe a', ma ~ ToMaybeT a', ToMaybe b', mb ~ ToMaybeT b') => ToFrom (FullOuterJoin a (b, (ma :& mb) -> SqlExpr (Value Bool))) where toFrom (FullOuterJoin lhs (rhs, on')) = FullJoinFrom (toFrom lhs) (toFrom rhs, on') instance (ToFrom a, ToFromT a ~ a', ToFrom b, ToFromT b ~ b', ToMaybe a', ma ~ ToMaybeT a') => ToFrom (RightOuterJoin a (b, (ma :& b') -> SqlExpr (Value Bool))) where toFrom (RightOuterJoin lhs (rhs, on')) = RightJoinFrom (toFrom lhs) (toFrom rhs, on') instance (ToFrom a, ToFromT a ~ a', ToFrom b, ToFromT b ~ b') => ToFrom (InnerJoin a (b, (a' :& b') -> SqlExpr (Value Bool))) where toFrom (InnerJoin lhs (rhs, on')) = InnerJoinFrom (toFrom lhs) (toFrom rhs, on') instance (ToFrom a, ToFrom b) => ToFrom (CrossJoin a b) where toFrom (CrossJoin lhs rhs) = CrossJoinFrom (toFrom lhs) (toFrom rhs) type family Nullable a where Nullable (Maybe a) = a Nullable a = a type family ToMaybeT a where ToMaybeT (SqlExpr (Maybe a)) = SqlExpr (Maybe a) ToMaybeT (SqlExpr (Entity a)) = SqlExpr (Maybe (Entity a)) ToMaybeT (SqlExpr (Value a)) = SqlExpr (Value (Maybe (Nullable a))) ToMaybeT (a :& b) = (ToMaybeT a :& ToMaybeT b) ToMaybeT (a, b) = (ToMaybeT a, ToMaybeT b) ToMaybeT (a, b, c) = (ToMaybeT a, ToMaybeT b, ToMaybeT c) ToMaybeT (a, b, c, d) = (ToMaybeT a, ToMaybeT b, ToMaybeT c, ToMaybeT d) ToMaybeT (a, b, c, d, e) = (ToMaybeT a, ToMaybeT b, ToMaybeT c, ToMaybeT d, ToMaybeT e) ToMaybeT (a, b, c, d, e, f) = (ToMaybeT a, ToMaybeT b, ToMaybeT c, ToMaybeT d, ToMaybeT e, ToMaybeT f) ToMaybeT (a, b, c, d, e, f, g) = (ToMaybeT a, ToMaybeT b, ToMaybeT c, ToMaybeT d, ToMaybeT e, ToMaybeT f, ToMaybeT g) ToMaybeT (a, b, c, d, e, f, g, h) = (ToMaybeT a, ToMaybeT b, ToMaybeT c, ToMaybeT d, ToMaybeT e, ToMaybeT f, ToMaybeT g, ToMaybeT h) class ToMaybe a where toMaybe :: a -> ToMaybeT a instance ToMaybe (SqlExpr (Maybe a)) where toMaybe = id instance ToMaybe (SqlExpr (Entity a)) where toMaybe = EMaybe instance ToMaybe (SqlExpr (Value a)) where toMaybe = veryUnsafeCoerceSqlExprValue instance (ToMaybe a, ToMaybe b) => ToMaybe (a :& b) where toMaybe (a :& b) = (toMaybe a :& toMaybe b) instance (ToMaybe a, ToMaybe b) => ToMaybe (a,b) where toMaybe (a, b) = (toMaybe a, toMaybe b) instance ( ToMaybe a , ToMaybe b , ToMaybe c ) => ToMaybe (a,b,c) where toMaybe = to3 . toMaybe . from3 instance ( ToMaybe a , ToMaybe b , ToMaybe c , ToMaybe d ) => ToMaybe (a,b,c,d) where toMaybe = to4 . toMaybe . from4 instance ( ToMaybe a , ToMaybe b , ToMaybe c , ToMaybe d , ToMaybe e ) => ToMaybe (a,b,c,d,e) where toMaybe = to5 . toMaybe . from5 instance ( ToMaybe a , ToMaybe b , ToMaybe c , ToMaybe d , ToMaybe e , ToMaybe f ) => ToMaybe (a,b,c,d,e,f) where toMaybe = to6 . toMaybe . from6 instance ( ToMaybe a , ToMaybe b , ToMaybe c , ToMaybe d , ToMaybe e , ToMaybe f , ToMaybe g ) => ToMaybe (a,b,c,d,e,f,g) where toMaybe = to7 . toMaybe . from7 instance ( ToMaybe a , ToMaybe b , ToMaybe c , ToMaybe d , ToMaybe e , ToMaybe f , ToMaybe g , ToMaybe h ) => ToMaybe (a,b,c,d,e,f,g,h) where toMaybe = to8 . toMaybe . from8 -- | 'FROM' clause, used to bring entities into scope. -- -- Internally, this function uses the `From` datatype and the -- `ToFrom` typeclass. Unlike the old `Database.Esqueleto.from`, -- this does not take a function as a parameter, but rather -- a value that represents a 'JOIN' tree constructed out of -- instances of `ToFrom`. This implementation eliminates certain -- types of runtime errors by preventing the construction of -- invalid SQL (e.g. illegal nested-@from@). from :: ToFrom a => a -> SqlQuery (ToFromT a) from parts = do (a, clause) <- runFrom $ toFrom parts Q $ W.tell mempty{sdFromClause=[clause]} pure a where runFrom :: From a -> SqlQuery (a, FromClause) runFrom e@Table = do let ed = entityDef $ getVal e ident <- newIdentFor (entityDB ed) let entity = EEntity ident pure $ (entity, FromStart ident ed) where getVal :: PersistEntity ent => From (SqlExpr (Entity ent)) -> Proxy ent getVal = const Proxy runFrom (SubQuery subquery) = do -- We want to update the IdentState without writing the query to side data (ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ subquery aliasedValue <- toAlias ret -- Make a fake query with the aliased results, this allows us to ensure that the query is only run once let aliasedQuery = Q $ W.WriterT $ pure (aliasedValue, sideData) -- Add the FromQuery that renders the subquery to our side data subqueryAlias <- newIdentFor (DBName "q") -- Pass the aliased results of the subquery to the outer query -- create aliased references from the outer query results (e.g value from subquery will be `subquery`.`value`), -- this is probably overkill as the aliases should already be unique but seems to be good practice. ref <- toAliasReference subqueryAlias aliasedValue pure (ref , FromQuery subqueryAlias (\info -> toRawSql SELECT info aliasedQuery)) runFrom (SqlSetOperation operation) = do (aliasedOperation, ret) <- aliasQueries operation ident <- newIdentFor (DBName "u") ref <- toAliasReference ident ret pure (ref, FromQuery ident $ operationToSql aliasedOperation) where aliasQueries o = case o of SelectQuery q -> do (ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ q prevState <- Q $ lift S.get aliasedRet <- toAlias ret Q $ lift $ S.put prevState pure (SelectQuery $ Q $ W.WriterT $ pure (aliasedRet, sideData), aliasedRet) Union o1 o2 -> do (o1', ret) <- aliasQueries o1 (o2', _ ) <- aliasQueries o2 pure (Union o1' o2', ret) UnionAll o1 o2 -> do (o1', ret) <- aliasQueries o1 (o2', _ ) <- aliasQueries o2 pure (UnionAll o1' o2', ret) Except o1 o2 -> do (o1', ret) <- aliasQueries o1 (o2', _ ) <- aliasQueries o2 pure (Except o1' o2', ret) Intersect o1 o2 -> do (o1', ret) <- aliasQueries o1 (o2', _ ) <- aliasQueries o2 pure (Intersect o1' o2', ret) operationToSql o info = case o of SelectQuery q -> toRawSql SELECT info q Union o1 o2 -> doSetOperation "UNION" info o1 o2 UnionAll o1 o2 -> doSetOperation "UNION ALL" info o1 o2 Except o1 o2 -> doSetOperation "EXCEPT" info o1 o2 Intersect o1 o2 -> doSetOperation "INTERSECT" info o1 o2 doSetOperation operationText info o1 o2 = let (q1, v1) = operationToSql o1 info (q2, v2) = operationToSql o2 info in (q1 <> " " <> operationText <> " " <> q2, v1 <> v2) runFrom (InnerJoinFrom leftPart (rightPart, on')) = do (leftVal, leftFrom) <- runFrom leftPart (rightVal, rightFrom) <- runFrom rightPart let ret = leftVal :& rightVal pure $ (ret, FromJoin leftFrom InnerJoinKind rightFrom (Just (on' ret))) runFrom (CrossJoinFrom leftPart rightPart) = do (leftVal, leftFrom) <- runFrom leftPart (rightVal, rightFrom) <- runFrom rightPart let ret = leftVal :& rightVal pure $ (ret, FromJoin leftFrom CrossJoinKind rightFrom Nothing) runFrom (LeftJoinFrom leftPart (rightPart, on')) = do (leftVal, leftFrom) <- runFrom leftPart (rightVal, rightFrom) <- runFrom rightPart let ret = leftVal :& (toMaybe rightVal) pure $ (ret, FromJoin leftFrom LeftOuterJoinKind rightFrom (Just (on' ret))) runFrom (RightJoinFrom leftPart (rightPart, on')) = do (leftVal, leftFrom) <- runFrom leftPart (rightVal, rightFrom) <- runFrom rightPart let ret = (toMaybe leftVal) :& rightVal pure $ (ret, FromJoin leftFrom RightOuterJoinKind rightFrom (Just (on' ret))) runFrom (FullJoinFrom leftPart (rightPart, on')) = do (leftVal, leftFrom) <- runFrom leftPart (rightVal, rightFrom) <- runFrom rightPart let ret = (toMaybe leftVal) :& (toMaybe rightVal) pure $ (ret, FromJoin leftFrom FullOuterJoinKind rightFrom (Just (on' ret))) type family ToAliasT a where ToAliasT (SqlExpr (Value a)) = SqlExpr (Value a) ToAliasT (SqlExpr (Entity a)) = SqlExpr (Entity a) ToAliasT (a, b) = (ToAliasT a, ToAliasT b) ToAliasT (a, b, c) = (ToAliasT a, ToAliasT b, ToAliasT c) ToAliasT (a, b, c, d) = (ToAliasT a, ToAliasT b, ToAliasT c, ToAliasT d) ToAliasT (a, b, c, d, e) = (ToAliasT a, ToAliasT b, ToAliasT c, ToAliasT d, ToAliasT e) ToAliasT (a, b, c, d, e, f) = (ToAliasT a, ToAliasT b, ToAliasT c, ToAliasT d, ToAliasT e, ToAliasT f) ToAliasT (a, b, c, d, e, f, g) = (ToAliasT a, ToAliasT b, ToAliasT c, ToAliasT d, ToAliasT e, ToAliasT f, ToAliasT g) ToAliasT (a, b, c, d, e, f, g, h) = (ToAliasT a, ToAliasT b, ToAliasT c, ToAliasT d, ToAliasT e, ToAliasT f, ToAliasT g, ToAliasT h) -- Tedious tuple magic class ToAlias a where toAlias :: a -> SqlQuery (ToAliasT a) instance ToAlias (SqlExpr (Value a)) where toAlias v@(EAliasedValue _ _) = pure v toAlias v = do ident <- newIdentFor (DBName "v") pure $ EAliasedValue ident v instance ToAlias (SqlExpr (Entity a)) where toAlias v@(EAliasedEntityReference _ _) = pure v toAlias v@(EAliasedEntity _ _) = pure v toAlias (EEntity tableIdent) = do ident <- newIdentFor (DBName "v") pure $ EAliasedEntity ident tableIdent instance (ToAlias a, ToAlias b) => ToAlias (a,b) where toAlias (a,b) = (,) <$> toAlias a <*> toAlias b instance ( ToAlias a , ToAlias b , ToAlias c ) => ToAlias (a,b,c) where toAlias x = to3 <$> (toAlias $ from3 x) instance ( ToAlias a , ToAlias b , ToAlias c , ToAlias d ) => ToAlias (a,b,c,d) where toAlias x = to4 <$> (toAlias $ from4 x) instance ( ToAlias a , ToAlias b , ToAlias c , ToAlias d , ToAlias e ) => ToAlias (a,b,c,d,e) where toAlias x = to5 <$> (toAlias $ from5 x) instance ( ToAlias a , ToAlias b , ToAlias c , ToAlias d , ToAlias e , ToAlias f ) => ToAlias (a,b,c,d,e,f) where toAlias x = to6 <$> (toAlias $ from6 x) instance ( ToAlias a , ToAlias b , ToAlias c , ToAlias d , ToAlias e , ToAlias f , ToAlias g ) => ToAlias (a,b,c,d,e,f,g) where toAlias x = to7 <$> (toAlias $ from7 x) instance ( ToAlias a , ToAlias b , ToAlias c , ToAlias d , ToAlias e , ToAlias f , ToAlias g , ToAlias h ) => ToAlias (a,b,c,d,e,f,g,h) where toAlias x = to8 <$> (toAlias $ from8 x) type family ToAliasReferenceT a where ToAliasReferenceT (SqlExpr (Value a)) = SqlExpr (Value a) ToAliasReferenceT (SqlExpr (Entity a)) = SqlExpr (Entity a) ToAliasReferenceT (a,b) = (ToAliasReferenceT a, ToAliasReferenceT b) ToAliasReferenceT (a,b,c) = (ToAliasReferenceT a, ToAliasReferenceT b, ToAliasReferenceT c) ToAliasReferenceT (a, b, c, d) = (ToAliasReferenceT a, ToAliasReferenceT b, ToAliasReferenceT c, ToAliasReferenceT d) ToAliasReferenceT (a, b, c, d, e) = (ToAliasReferenceT a, ToAliasReferenceT b, ToAliasReferenceT c, ToAliasReferenceT d, ToAliasReferenceT e) ToAliasReferenceT (a, b, c, d, e, f) = (ToAliasReferenceT a, ToAliasReferenceT b, ToAliasReferenceT c, ToAliasReferenceT d, ToAliasReferenceT e, ToAliasReferenceT f) ToAliasReferenceT (a, b, c, d, e, f, g) = (ToAliasReferenceT a, ToAliasReferenceT b, ToAliasReferenceT c, ToAliasReferenceT d, ToAliasReferenceT e, ToAliasReferenceT f, ToAliasReferenceT g) ToAliasReferenceT (a, b, c, d, e, f, g, h) = (ToAliasReferenceT a, ToAliasReferenceT b, ToAliasReferenceT c, ToAliasReferenceT d, ToAliasReferenceT e, ToAliasReferenceT f, ToAliasReferenceT g, ToAliasReferenceT h) -- more tedious tuple magic class ToAliasReference a where toAliasReference :: Ident -> a -> SqlQuery (ToAliasReferenceT a) instance ToAliasReference (SqlExpr (Value a)) where toAliasReference aliasSource (EAliasedValue aliasIdent _) = pure $ EValueReference aliasSource (\_ -> aliasIdent) toAliasReference _ v@(ERaw _ _) = toAlias v toAliasReference _ v@(ECompositeKey _) = toAlias v toAliasReference _ v@(EValueReference _ _) = pure v instance ToAliasReference (SqlExpr (Entity a)) where toAliasReference aliasSource (EAliasedEntity ident _) = pure $ EAliasedEntityReference aliasSource ident toAliasReference _ e@(EEntity _) = toAlias e toAliasReference _ e@(EAliasedEntityReference _ _) = pure e instance (ToAliasReference a, ToAliasReference b) => ToAliasReference (a, b) where toAliasReference ident (a,b) = (,) <$> (toAliasReference ident a) <*> (toAliasReference ident b) instance ( ToAliasReference a , ToAliasReference b , ToAliasReference c ) => ToAliasReference (a,b,c) where toAliasReference ident x = fmap to3 $ toAliasReference ident $ from3 x instance ( ToAliasReference a , ToAliasReference b , ToAliasReference c , ToAliasReference d ) => ToAliasReference (a,b,c,d) where toAliasReference ident x = fmap to4 $ toAliasReference ident $ from4 x instance ( ToAliasReference a , ToAliasReference b , ToAliasReference c , ToAliasReference d , ToAliasReference e ) => ToAliasReference (a,b,c,d,e) where toAliasReference ident x = fmap to5 $ toAliasReference ident $ from5 x instance ( ToAliasReference a , ToAliasReference b , ToAliasReference c , ToAliasReference d , ToAliasReference e , ToAliasReference f ) => ToAliasReference (a,b,c,d,e,f) where toAliasReference ident x = to6 <$> (toAliasReference ident $ from6 x) instance ( ToAliasReference a , ToAliasReference b , ToAliasReference c , ToAliasReference d , ToAliasReference e , ToAliasReference f , ToAliasReference g ) => ToAliasReference (a,b,c,d,e,f,g) where toAliasReference ident x = to7 <$> (toAliasReference ident $ from7 x) instance ( ToAliasReference a , ToAliasReference b , ToAliasReference c , ToAliasReference d , ToAliasReference e , ToAliasReference f , ToAliasReference g , ToAliasReference h ) => ToAliasReference (a,b,c,d,e,f,g,h) where toAliasReference ident x = to8 <$> (toAliasReference ident $ from8 x) esqueleto-3.3.3.2/src/Database/Esqueleto/Internal/Language.hs0000644000000000000000000000407113602674715022165 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 from , Value(..) , ValueList(..) , SomeValue(..) , ToSomeValues(..) , InnerJoin(..) , CrossJoin(..) , LeftOuterJoin(..) , RightOuterJoin(..) , FullOuterJoin(..) , OnClauseWithoutMatchingJoinException(..) , OrderBy , DistinctOn , Update , Insertion , LockingKind(..) , SqlString , ToBaseId(..) -- * The guts , JoinKind(..) , IsJoinKind(..) , BackendCompatible(..) , PreprocessedFrom , From , FromPreprocess , when_ , then_ , else_ , where_, on, groupBy, orderBy, rand, asc, desc, limit, offset , distinct, distinctOn, don, distinctOnOrderBy, having, locking , sub_select, (^.), (?.) , val, isNothing, just, nothing, joinV, withNonNull , countRows, count, countDistinct , not_, (==.), (>=.), (>.), (<=.), (<.), (!=.), (&&.), (||.) , between, (+.), (-.), (/.), (*.) , random_, round_, ceiling_, floor_ , min_, max_, sum_, avg_, castNum, castNumM , coalesce, coalesceDefault , lower_, upper_, trim_, ltrim_, rtrim_, length_, left_, right_ , like, ilike, (%), concat_, (++.), castString , subList_select, valList, justList , in_, notIn, exists, notExists , set, (=.), (+=.), (-=.), (*=.), (/=.) , case_, toBaseId, (<#), (<&>) , subSelect , subSelectMaybe , subSelectCount , subSelectList , subSelectForeign , subSelectUnsafe ) where import Database.Esqueleto.Internal.PersistentImport import Database.Esqueleto.Internal.Internal esqueleto-3.3.3.2/src/Database/Esqueleto/Internal/Sql.hs0000644000000000000000000000341613555674431021205 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable , EmptyDataDecls , FlexibleContexts , FlexibleInstances , FunctionalDependencies , MultiParamTypeClasses , TypeFamilies , UndecidableInstances , GADTs #-} {-# LANGUAGE ConstraintKinds , EmptyDataDecls , FlexibleContexts , FlexibleInstances , FunctionalDependencies , GADTs , MultiParamTypeClasses , OverloadedStrings , UndecidableInstances , ScopedTypeVariables , InstanceSigs , Rank2Types , CPP #-} -- | 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 , delete , deleteCount , update , updateCount , insertSelect , insertSelectCount -- * The guts , unsafeSqlCase , unsafeSqlBinOp , unsafeSqlBinOpComposite , unsafeSqlValue , unsafeSqlCastAs , unsafeSqlFunction , unsafeSqlExtractSubField , UnsafeSqlFunctionArgument , OrderByClause , rawSelectSource , runSource , rawEsqueleto , toRawSql , Mode(..) , NeedParens(..) , IdentState , renderExpr , initialIdentState , IdentInfo , SqlSelect(..) , veryUnsafeCoerceSqlExprValue , veryUnsafeCoerceSqlExprValueList -- * Helper functions , renderQueryToText , renderQuerySelect , renderQueryUpdate , renderQueryDelete , renderQueryInsertInto , makeOrderByNoNewline , uncommas' , parens , toArgList , builderToText , Ident(..) ) where import Database.Esqueleto.Internal.Internal esqueleto-3.3.3.2/src/Database/Esqueleto/Internal/Internal.hs0000644000000000000000000036305613674150634022227 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable , EmptyDataDecls , FlexibleContexts , FlexibleInstances , FunctionalDependencies , MultiParamTypeClasses , TypeFamilies , UndecidableInstances , GADTs #-} {-# LANGUAGE ConstraintKinds , EmptyDataDecls , FlexibleContexts , FlexibleInstances , FunctionalDependencies , GADTs , MultiParamTypeClasses , OverloadedStrings , UndecidableInstances , ScopedTypeVariables , InstanceSigs , Rank2Types , CPP #-} -- | This is an internal module, anything exported by this module -- may change without a major version bump. Please use only -- "Database.Esqueleto" if possible. -- -- If you use this module, please report what your use case is on the issue -- tracker so we can safely support it. module Database.Esqueleto.Internal.Internal where import Control.Applicative ((<|>)) import Control.Arrow ((***), first) import Control.Exception (Exception, throw, throwIO) import qualified Data.Maybe as Maybe import Control.Monad (guard, ap, MonadPlus(..), void) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Resource (MonadResource, release) import Data.Acquire (with, allocateAcquire, Acquire) import Data.Int (Int64) import Data.List (intersperse) #if __GLASGOW_HASKELL__ < 804 import Data.Semigroup #endif import qualified Data.Monoid as Monoid import Data.Proxy (Proxy(..)) import Database.Esqueleto.Internal.PersistentImport import Database.Persist.Sql.Util (entityColumnNames, entityColumnCount, parseEntityValues, isIdField, hasCompositeKey) import qualified Data.Set as Set import Data.Set (Set) 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.ByteString as B 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 Data.Typeable (Typeable) import Text.Blaze.Html (Html) import Database.Esqueleto.Internal.ExprParser (TableAccess(..), parseOnExpr) -- | (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 , BackendCompatible SqlBackend (PersistEntityBackend a) ) => SqlQuery (SqlExpr (PreprocessedFrom (SqlExpr (Entity a)))) fromStart = x where x = do let ed = entityDef (getVal x) ident <- newIdentFor (entityDB ed) let ret = EEntity ident f' = FromStart ident ed return (EPreprocessedFrom ret f') getVal :: SqlQuery (SqlExpr (PreprocessedFrom (SqlExpr (Entity a)))) -> Proxy a getVal = const Proxy -- | (Internal) Same as 'fromStart', but entity may be missing. fromStartMaybe :: ( PersistEntity a , BackendCompatible SqlBackend (PersistEntityBackend a) ) => SqlQuery (SqlExpr (PreprocessedFrom (SqlExpr (Maybe (Entity a))))) fromStartMaybe = maybelize <$> fromStart where maybelize :: SqlExpr (PreprocessedFrom (SqlExpr (Entity a))) -> SqlExpr (PreprocessedFrom (SqlExpr (Maybe (Entity a)))) maybelize (EPreprocessedFrom ret f') = EPreprocessedFrom (EMaybe ret) f' -- | (Internal) Do a @JOIN@. fromJoin :: IsJoinKind join => SqlExpr (PreprocessedFrom a) -> SqlExpr (PreprocessedFrom b) -> SqlQuery (SqlExpr (PreprocessedFrom (join a b))) 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') -- | (Internal) Finish a @JOIN@. fromFinish :: SqlExpr (PreprocessedFrom a) -> SqlQuery a fromFinish (EPreprocessedFrom ret f') = Q $ do W.tell mempty { sdFromClause = [f'] } return ret -- | @WHERE@ clause: restrict the query's result. where_ :: SqlExpr (Value Bool) -> SqlQuery () where_ expr = Q $ W.tell mempty { sdWhereClause = Where expr } -- | An @ON@ clause, useful to describe how two tables are related. Cross joins -- and tuple-joins do not need an 'on' clause, but 'InnerJoin' and the various -- outer joins do. -- -- If you don't include an 'on' clause (or include too many!) then a runtime -- exception will be thrown. -- -- As an example, consider this simple join: -- -- @ -- 'select' $ -- 'from' $ \\(foo `'InnerJoin`` bar) -> do -- 'on' (foo '^.' FooId '==.' bar '^.' BarFooId) -- ... -- @ -- -- We need to specify the clause for joining the two columns together. If we had -- this: -- -- @ -- 'select' $ -- 'from' $ \\(foo `'CrossJoin`` bar) -> do -- ... -- @ -- -- Then we can safely omit the 'on' clause, because the cross join will make -- pairs of all records possible. -- -- You can do multiple 'on' clauses in a query. This query joins three tables, -- and has two 'on' clauses: -- -- @ -- 'select' $ -- 'from' $ \\(foo `'InnerJoin`` bar `'InnerJoin`` baz) -> do -- 'on' (baz '^.' BazId '==.' bar '^.' BarBazId) -- 'on' (foo '^.' FooId '==.' bar '^.' BarFooId) -- ... -- @ -- -- Old versions of esqueleto required that you provide the 'on' clauses in -- reverse order. This restriction has been lifted - you can now provide 'on' -- clauses in any order, and the SQL should work itself out. The above query is -- now totally equivalent to this: -- -- @ -- 'select' $ -- 'from' $ \\(foo `'InnerJoin`` bar `'InnerJoin`` baz) -> do -- 'on' (foo '^.' FooId '==.' bar '^.' BarFooId) -- 'on' (baz '^.' BazId '==.' bar '^.' BarBazId) -- ... -- @ on :: SqlExpr (Value Bool) -> SqlQuery () on expr = Q $ W.tell mempty { sdFromClause = [OnClause expr] } -- | @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 -- @SqlSqlExpr (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) -- @ -- -- === Need more columns? -- -- The 'ToSomeValues' class is defined for 'SqlExpr' and tuples of 'SqlExpr's. -- We only have definitions for up to 8 elements in a tuple right now, so it's -- possible that you may need to have more than 8 elements. -- -- For example, consider a query with a 'groupBy' call like this: -- -- @ -- groupBy (e0, e1, e2, e3, e4, e5, e6, e7) -- @ -- -- This is the biggest you can get with a single tuple. However, you can easily -- nest the tuples to add more: -- -- @ -- groupBy ((e0, e1, e2, e3, e4, e5, e6, e7), e8, e9) -- @ groupBy :: (ToSomeValues a) => a -> SqlQuery () groupBy expr = Q $ W.tell mempty { sdGroupByClause = GroupBy $ toSomeValues expr } -- | @ORDER BY@ clause. See also 'asc' and 'desc'. -- -- Multiple calls to 'orderBy' get concatenated on the final -- query, including 'distinctOnOrderBy'. orderBy :: [SqlExpr OrderBy] -> SqlQuery () orderBy exprs = Q $ W.tell mempty { sdOrderByClause = exprs } -- | Ascending order of this field or SqlExpression. asc :: PersistField a => SqlExpr (Value a) -> SqlExpr OrderBy asc = EOrderBy ASC -- | Descending order of this field or SqlExpression. desc :: PersistField a => SqlExpr (Value a) -> SqlExpr OrderBy desc = EOrderBy DESC -- | @LIMIT@. Limit the number of returned rows. limit :: Int64 -> SqlQuery () limit n = Q $ W.tell mempty { sdLimitClause = Limit (Just n) Nothing } -- | @OFFSET@. Usually used with 'limit'. offset :: Int64 -> SqlQuery () offset n = Q $ W.tell mempty { sdLimitClause = Limit Nothing (Just n) } -- | @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 :: SqlQuery a -> SqlQuery a distinct act = Q (W.tell mempty { sdDistinctClause = DistinctStandard }) >> act -- | @DISTINCT ON@. Change the current @SELECT@ into -- @SELECT DISTINCT ON (SqlExpressions)@. 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 SqlExpressions. Calls to -- 'distinctOn' override any calls to 'distinct'. -- -- Note that PostgreSQL requires the SqlExpressions 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 :: [SqlExpr DistinctOn] -> SqlQuery a -> SqlQuery a distinctOn exprs act = Q (W.tell mempty { sdDistinctClause = DistinctOn exprs }) >> act -- | Erase an SqlExpression's type so that it's suitable to -- be used by 'distinctOn'. -- -- /Since: 2.2.4/ don :: SqlExpr (Value a) -> SqlExpr DistinctOn don = EDistinctOn -- | 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 :: [SqlExpr OrderBy] -> SqlQuery a -> SqlQuery a distinctOnOrderBy exprs act = distinctOn (toDistinctOn <$> exprs) $ do orderBy exprs act where toDistinctOn :: SqlExpr OrderBy -> SqlExpr DistinctOn toDistinctOn (EOrderBy _ f) = EDistinctOn f toDistinctOn EOrderRandom = error "We can't select distinct by a random order!" -- | @ORDER BY random()@ clause. -- -- /Since: 1.3.10/ rand :: SqlExpr OrderBy rand = EOrderRandom -- | @HAVING@. -- -- /Since: 1.2.2/ having :: SqlExpr (Value Bool) -> SqlQuery () having expr = Q $ W.tell mempty { sdHavingClause = Where expr } -- | 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 -> SqlQuery () locking kind = Q $ W.tell mempty { sdLockingClause = Monoid.Last (Just kind) } {-# DEPRECATED sub_select "sub_select \n \ sub_select is an unsafe function to use. If used with a SqlQuery that \n \ returns 0 results, then it may return NULL despite not mentioning Maybe \n \ in the return type. If it returns more than 1 result, then it will throw a \n \ SQL error.\n\n Instead, consider using one of the following alternatives: \n \ - subSelect: attaches a LIMIT 1 and the Maybe return type, totally safe. \n \ - subSelectMaybe: Attaches a LIMIT 1, useful for a query that already \n \ has a Maybe in the return type. \n \ - subSelectCount: Performs a count of the query - this is always safe. \n \ - subSelectUnsafe: Performs no checks or guarantees. Safe to use with \n \ countRows and friends." #-} -- | Execute a subquery @SELECT@ in an SqlExpression. Returns a -- simple value so should be used only when the @SELECT@ query -- is guaranteed to return just one row. -- -- Deprecated in 3.2.0. sub_select :: PersistField a => SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a) sub_select = sub SELECT -- | Execute a subquery @SELECT@ in a 'SqlExpr'. The query passed to this -- function will only return a single result - it has a @LIMIT 1@ passed in to -- the query to make it safe, and the return type is 'Maybe' to indicate that -- the subquery might result in 0 rows. -- -- If you find yourself writing @'joinV' . 'subSelect'@, then consider using -- 'subSelectMaybe'. -- -- If you're performing a 'countRows', then you can use 'subSelectCount' which -- is safe. -- -- If you know that the subquery will always return exactly one row (eg -- a foreign key constraint guarantees that you'll get exactly one row), then -- consider 'subSelectUnsafe', along with a comment explaining why it is safe. -- -- @since 3.2.0 subSelect :: PersistField a => SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value (Maybe a)) subSelect query = just (subSelectUnsafe (query <* limit 1)) -- | Execute a subquery @SELECT@ in a 'SqlExpr'. This function is a shorthand -- for the common @'joinV' . 'subSelect'@ idiom, where you are calling -- 'subSelect' on an expression that would be 'Maybe' already. -- -- As an example, you would use this function when calling 'sum_' or 'max_', -- which have 'Maybe' in the result type (for a 0 row query). -- -- @since 3.2.0 subSelectMaybe :: PersistField a => SqlQuery (SqlExpr (Value (Maybe a))) -> SqlExpr (Value (Maybe a)) subSelectMaybe = joinV . subSelect -- | Performs a @COUNT@ of the given query in a @subSelect@ manner. This is -- always guaranteed to return a result value, and is completely safe. -- -- @since 3.2.0 subSelectCount :: (Num a, PersistField a) => SqlQuery ignored -> SqlExpr (Value a) subSelectCount query = do subSelectUnsafe $ do _ <- query pure countRows -- | Execute a subquery @SELECT@ in a 'SqlExpr' that returns a list. This is an -- alias for 'subList_select' and is provided for symmetry with the other safe -- subselect functions. -- -- @since 3.2.0 subSelectList :: PersistField a => SqlQuery (SqlExpr (Value a)) -> SqlExpr (ValueList a) subSelectList = subList_select -- | Performs a sub-select using the given foreign key on the entity. This is -- useful to extract values that are known to be present by the database schema. -- -- As an example, consider the following persistent definition: -- -- @ -- User -- profile ProfileId -- -- Profile -- name Text -- @ -- -- The following query will return the name of the user. -- -- @ -- getUserWithName = -- 'select' $ -- 'from' $ \user -> -- 'pure' (user, 'subSelectForeign' user UserProfile (^. ProfileName) -- @ -- -- @since 3.2.0 subSelectForeign :: ( BackendCompatible SqlBackend (PersistEntityBackend val1) , PersistEntity val1, PersistEntity val2, PersistField a ) => SqlExpr (Entity val2) -- ^ An expression representing the table you have access to now. -> EntityField val2 (Key val1) -- ^ The foreign key field on the table. -> (SqlExpr (Entity val1) -> SqlExpr (Value a)) -- ^ A function to extract a value from the foreign reference table. -> SqlExpr (Value a) subSelectForeign expr foreignKey k = subSelectUnsafe $ from $ \table -> do where_ $ expr ^. foreignKey ==. table ^. persistIdField pure (k table) -- | Execute a subquery @SELECT@ in a 'SqlExpr'. This function is unsafe, -- because it can throw runtime exceptions in two cases: -- -- 1. If the query passed has 0 result rows, then it will return a @NULL@ value. -- The @persistent@ parsing operations will fail on an unexpected @NULL@. -- 2. If the query passed returns more than one row, then the SQL engine will -- fail with an error like "More than one row returned by a subquery used as -- an expression". -- -- This function is safe if you guarantee that exactly one row will be returned, -- or if the result already has a 'Maybe' type for some reason. -- -- For variants with the safety encoded already, see 'subSelect' and -- 'subSelectMaybe'. For the most common safe use of this, see 'subSelectCount'. -- -- @since 3.2.0 subSelectUnsafe :: PersistField a => SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a) subSelectUnsafe = sub SELECT -- | Project a field of an entity. (^.) :: forall typ val. (PersistEntity val, PersistField typ) => SqlExpr (Entity val) -> EntityField val typ -> SqlExpr (Value typ) (EAliasedEntityReference source base) ^. field = EValueReference source (aliasedEntityColumnIdent base fieldDef) where fieldDef = if isIdField field then -- TODO what about composite natural keys in a join this will ignore them head $ entityKeyFields ed else persistFieldDef field ed = entityDef $ getEntityVal (Proxy :: Proxy (SqlExpr (Entity val))) e ^. field | isIdField field = idFieldValue | otherwise = ERaw Never $ \info -> (dot info $ persistFieldDef field, []) where idFieldValue = case entityKeyFields ed of idField:[] -> ERaw Never $ \info -> (dot info idField, []) idFields -> ECompositeKey $ \info -> dot info <$> idFields ed = entityDef $ getEntityVal (Proxy :: Proxy (SqlExpr (Entity val))) dot info fieldDef = useIdent info sourceIdent <> "." <> fieldIdent where sourceIdent = case e of EEntity ident -> ident EAliasedEntity baseI _ -> baseI fieldIdent = case e of EEntity _ -> fromDBName info (fieldDB fieldDef) EAliasedEntity baseI _ -> useIdent info $ aliasedEntityColumnIdent baseI fieldDef info -- | Project an SqlExpression that may be null, guarding against null cases. withNonNull :: PersistField typ => SqlExpr (Value (Maybe typ)) -> (SqlExpr (Value typ) -> SqlQuery a) -> SqlQuery a withNonNull field f = do where_ $ not_ $ isNothing field f $ veryUnsafeCoerceSqlExprValue field -- | Project a field of an entity that may be null. (?.) :: (PersistEntity val, PersistField typ) => SqlExpr (Maybe (Entity val)) -> EntityField val typ -> SqlExpr (Value (Maybe typ)) EMaybe r ?. field = just (r ^. field) -- | Lift a constant value from Haskell-land to the query. val :: PersistField typ => typ -> SqlExpr (Value typ) val v = ERaw Never $ const ("?", [toPersistValue v]) -- | @IS NULL@ comparison. isNothing :: PersistField typ => SqlExpr (Value (Maybe typ)) -> SqlExpr (Value Bool) isNothing v = case v of ERaw p f -> isNullExpr $ first (parensM p) . f EAliasedValue i _ -> isNullExpr $ aliasedValueIdentToRawSql i EValueReference i i' -> isNullExpr $ valueReferenceToRawSql i i' ECompositeKey f -> ERaw Parens $ flip (,) [] . (intersperseB " AND " . map (<> " IS NULL")) . f where isNullExpr :: (IdentInfo -> (TLB.Builder, [PersistValue])) -> SqlExpr (Value Bool) isNullExpr g = ERaw Parens $ first ((<> " IS NULL")) . g -- | Analogous to 'Just', promotes a value of type @typ@ into -- one of type @Maybe typ@. It should hold that @'val' . Just -- === just . 'val'@. just :: SqlExpr (Value typ) -> SqlExpr (Value (Maybe typ)) just (ERaw p f) = ERaw p f just (ECompositeKey f) = ECompositeKey f just (EAliasedValue i v) = EAliasedValue i (just v) just (EValueReference i i') = EValueReference i i' -- | @NULL@ value. nothing :: SqlExpr (Value (Maybe typ)) nothing = unsafeSqlValue "NULL" -- | Join nested 'Maybe's in a 'Value' into one. This is useful when -- calling aggregate functions on nullable fields. joinV :: SqlExpr (Value (Maybe (Maybe typ))) -> SqlExpr (Value (Maybe typ)) joinV (ERaw p f) = ERaw p f joinV (ECompositeKey f) = ECompositeKey f joinV (EAliasedValue i v) = EAliasedValue i (joinV v) joinV (EValueReference i i') = EValueReference i i' countHelper :: Num a => TLB.Builder -> TLB.Builder -> SqlExpr (Value typ) -> SqlExpr (Value a) countHelper open close v = case v of ERaw _ f -> countRawSql f EAliasedValue i _ -> countRawSql $ aliasedValueIdentToRawSql i EValueReference i i' -> countRawSql $ valueReferenceToRawSql i i' ECompositeKey _ -> countRows where countRawSql :: (IdentInfo -> (TLB.Builder, [PersistValue])) -> SqlExpr (Value a) countRawSql x = ERaw Never $ first (\b -> "COUNT" <> open <> parens b <> close) . x -- | @COUNT(*)@ value. countRows :: Num a => SqlExpr (Value a) countRows = unsafeSqlValue "COUNT(*)" -- | @COUNT@. count :: Num a => SqlExpr (Value typ) -> SqlExpr (Value a) count = countHelper "" "" -- | @COUNT(DISTINCT x)@. -- -- /Since: 2.4.1/ countDistinct :: Num a => SqlExpr (Value typ) -> SqlExpr (Value a) countDistinct = countHelper "(DISTINCT " ")" not_ :: SqlExpr (Value Bool) -> SqlExpr (Value Bool) not_ v = ERaw Never (\info -> first ("NOT " <>) $ x info) where x info = case v of ERaw p f -> let (b, vals) = f info in (parensM p b, vals) ECompositeKey _ -> throw (CompositeKeyErr NotError) EAliasedValue i _ -> aliasedValueIdentToRawSql i info EValueReference i i' -> valueReferenceToRawSql i i' info (==.) :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (Value typ) -> SqlExpr (Value Bool) (==.) = unsafeSqlBinOpComposite " = " " AND " (>=.) :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (Value typ) -> SqlExpr (Value Bool) (>=.) = unsafeSqlBinOp " >= " (>.) :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (Value typ) -> SqlExpr (Value Bool) (>.) = unsafeSqlBinOp " > " (<=.) :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (Value typ) -> SqlExpr (Value Bool) (<=.) = unsafeSqlBinOp " <= " (<.) :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (Value typ) -> SqlExpr (Value Bool) (<.) = unsafeSqlBinOp " < " (!=.) :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (Value typ) -> SqlExpr (Value Bool) (!=.) = unsafeSqlBinOpComposite " != " " OR " (&&.) :: SqlExpr (Value Bool) -> SqlExpr (Value Bool) -> SqlExpr (Value Bool) (&&.) = unsafeSqlBinOp " AND " (||.) :: SqlExpr (Value Bool) -> SqlExpr (Value Bool) -> SqlExpr (Value Bool) (||.) = unsafeSqlBinOp " OR " (+.) :: PersistField a => SqlExpr (Value a) -> SqlExpr (Value a) -> SqlExpr (Value a) (+.) = unsafeSqlBinOp " + " (-.) :: PersistField a => SqlExpr (Value a) -> SqlExpr (Value a) -> SqlExpr (Value a) (-.) = unsafeSqlBinOp " - " (/.) :: PersistField a => SqlExpr (Value a) -> SqlExpr (Value a) -> SqlExpr (Value a) (/.) = unsafeSqlBinOp " / " (*.) :: PersistField a => SqlExpr (Value a) -> SqlExpr (Value a) -> SqlExpr (Value a) (*.) = unsafeSqlBinOp " * " -- | @BETWEEN@. -- -- @since: 3.1.0 between :: PersistField a => SqlExpr (Value a) -> (SqlExpr (Value a), SqlExpr (Value a)) -> SqlExpr (Value Bool) a `between` (b, c) = a >=. b &&. a <=. c random_ :: (PersistField a, Num a) => SqlExpr (Value a) random_ = unsafeSqlValue "RANDOM()" round_ :: (PersistField a, Num a, PersistField b, Num b) => SqlExpr (Value a) -> SqlExpr (Value b) round_ = unsafeSqlFunction "ROUND" ceiling_ :: (PersistField a, Num a, PersistField b, Num b) => SqlExpr (Value a) -> SqlExpr (Value b) ceiling_ = unsafeSqlFunction "CEILING" floor_ :: (PersistField a, Num a, PersistField b, Num b) => SqlExpr (Value a) -> SqlExpr (Value b) floor_ = unsafeSqlFunction "FLOOR" sum_ :: (PersistField a, PersistField b) => SqlExpr (Value a) -> SqlExpr (Value (Maybe b)) sum_ = unsafeSqlFunction "SUM" min_ :: (PersistField a) => SqlExpr (Value a) -> SqlExpr (Value (Maybe a)) min_ = unsafeSqlFunction "MIN" max_ :: (PersistField a) => SqlExpr (Value a) -> SqlExpr (Value (Maybe a)) max_ = unsafeSqlFunction "MAX" avg_ :: (PersistField a, PersistField b) => SqlExpr (Value a) -> SqlExpr (Value (Maybe b)) avg_ = unsafeSqlFunction "AVG" -- | 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) => SqlExpr (Value a) -> SqlExpr (Value b) castNum = veryUnsafeCoerceSqlExprValue -- | Same as 'castNum', but for nullable values. -- -- /Since: 2.2.9/ castNumM :: (Num a, Num b) => SqlExpr (Value (Maybe a)) -> SqlExpr (Value (Maybe b)) castNumM = veryUnsafeCoerceSqlExprValue -- | @COALESCE@ function. Evaluates the arguments in order and -- returns the value of the first non-NULL SqlExpression, 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 => [SqlExpr (Value (Maybe a))] -> SqlExpr (Value (Maybe a)) coalesce = unsafeSqlFunctionParens "COALESCE" -- | Like @coalesce@, but takes a non-nullable SqlExpression -- placed at the end of the SqlExpression list, which guarantees -- a non-NULL result. -- -- /Since: 1.4.3/ coalesceDefault :: PersistField a => [SqlExpr (Value (Maybe a))] -> SqlExpr (Value a) -> SqlExpr (Value a) coalesceDefault exprs = unsafeSqlFunctionParens "COALESCE" . (exprs ++) . return . just -- | @LOWER@ function. lower_ :: SqlString s => SqlExpr (Value s) -> SqlExpr (Value s) lower_ = unsafeSqlFunction "LOWER" -- | @UPPER@ function. -- /Since: 3.3.0/ upper_ :: SqlString s => SqlExpr (Value s) -> SqlExpr (Value s) upper_ = unsafeSqlFunction "UPPER" -- | @TRIM@ function. -- /Since: 3.3.0/ trim_ :: SqlString s => SqlExpr (Value s) -> SqlExpr (Value s) trim_ = unsafeSqlFunction "TRIM" -- | @RTRIM@ function. -- /Since: 3.3.0/ rtrim_ :: SqlString s => SqlExpr (Value s) -> SqlExpr (Value s) rtrim_ = unsafeSqlFunction "RTRIM" -- | @LTRIM@ function. -- /Since: 3.3.0/ ltrim_ :: SqlString s => SqlExpr (Value s) -> SqlExpr (Value s) ltrim_ = unsafeSqlFunction "LTRIM" -- | @LENGTH@ function. -- /Since: 3.3.0/ length_ :: (SqlString s, Num a) => SqlExpr (Value s) -> SqlExpr (Value a) length_ = unsafeSqlFunction "LENGTH" -- | @LEFT@ function. -- /Since: 3.3.0/ left_ :: (SqlString s, Num a) => (SqlExpr (Value s), SqlExpr (Value a)) -> SqlExpr (Value s) left_ = unsafeSqlFunction "LEFT" -- | @RIGHT@ function. -- /Since: 3.3.0/ right_ :: (SqlString s, Num a) => (SqlExpr (Value s), SqlExpr (Value a)) -> SqlExpr (Value s) right_ = unsafeSqlFunction "RIGHT" -- | @LIKE@ operator. like :: SqlString s => SqlExpr (Value s) -> SqlExpr (Value s) -> SqlExpr (Value Bool) like = unsafeSqlBinOp " LIKE " -- | @ILIKE@ operator (case-insensitive @LIKE@). -- -- Supported by PostgreSQL only. -- -- /Since: 2.2.3/ ilike :: SqlString s => SqlExpr (Value s) -> SqlExpr (Value s) -> SqlExpr (Value Bool) ilike = unsafeSqlBinOp " ILIKE " -- | The string @'%'@. May be useful while using 'like' and -- concatenation ('concat_' or '++.', depending on your -- database). Note that you always have to type the parenthesis, -- for example: -- -- @ -- name `'like`` (%) ++. 'val' \"John\" ++. (%) -- @ (%) :: SqlString s => SqlExpr (Value s) (%) = unsafeSqlValue "'%'" -- | The @CONCAT@ function with a variable number of -- parameters. Supported by MySQL and PostgreSQL. concat_ :: SqlString s => [SqlExpr (Value s)] -> SqlExpr (Value s) concat_ = unsafeSqlFunction "CONCAT" -- | The @||@ string concatenation operator (named after -- Haskell's '++' in order to avoid naming clash with '||.'). -- Supported by SQLite and PostgreSQL. (++.) :: SqlString s => SqlExpr (Value s) -> SqlExpr (Value s) -> SqlExpr (Value s) (++.) = unsafeSqlBinOp " || " -- | 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) => SqlExpr (Value s) -> SqlExpr (Value r) castString = veryUnsafeCoerceSqlExprValue -- | Execute a subquery @SELECT@ in an SqlExpression. Returns a -- list of values. subList_select :: PersistField a => SqlQuery (SqlExpr (Value a)) -> SqlExpr (ValueList a) subList_select = EList . sub_select -- | Lift a list of constant value from Haskell-land to the query. valList :: PersistField typ => [typ] -> SqlExpr (ValueList typ) valList [] = EEmptyList valList vals = EList $ ERaw Parens $ const ( uncommas ("?" <$ vals) , map toPersistValue vals ) -- | 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 :: SqlExpr (ValueList typ) -> SqlExpr (ValueList (Maybe typ)) justList EEmptyList = EEmptyList justList (EList v) = EList (just v) -- | @IN@ operator. For example if you want to select all @Person@s by a list -- of IDs: -- -- @ -- SELECT * -- FROM Person -- WHERE Person.id IN (?) -- @ -- -- In @esqueleto@, we may write the same query above as: -- -- @ -- select $ -- 'from' $ \\person -> do -- 'where_' $ person '^.' PersonId `'in_`` 'valList' personIds -- return person -- @ -- -- Where @personIds@ is of type @[Key Person]@. in_ :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (ValueList typ) -> SqlExpr (Value Bool) v `in_` e = ifNotEmptyList e False $ unsafeSqlBinOp " IN " v (veryUnsafeCoerceSqlExprValueList e) -- | @NOT IN@ operator. notIn :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (ValueList typ) -> SqlExpr (Value Bool) v `notIn` e = ifNotEmptyList e True $ unsafeSqlBinOp " NOT IN " v (veryUnsafeCoerceSqlExprValueList e) -- | @EXISTS@ operator. For example: -- -- @ -- select $ -- 'from' $ \\person -> do -- 'where_' $ 'exists' $ -- 'from' $ \\post -> do -- 'where_' (post '^.' BlogPostAuthorId '==.' person '^.' PersonId) -- return person -- @ exists :: SqlQuery () -> SqlExpr (Value Bool) exists = unsafeSqlFunction "EXISTS " . existsHelper -- | @NOT EXISTS@ operator. notExists :: SqlQuery () -> SqlExpr (Value Bool) notExists = unsafeSqlFunction "NOT EXISTS " . existsHelper -- | @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 => SqlExpr (Entity val) -> [SqlExpr (Update val)] -> SqlQuery () set ent upds = Q $ W.tell mempty { sdSetClause = map apply upds } where apply (ESet f) = SetClause (f ent) (=.) :: (PersistEntity val, PersistField typ) => EntityField val typ -> SqlExpr (Value typ) -> SqlExpr (Update val) field =. expr = setAux field (const expr) (+=.) :: (PersistEntity val, PersistField a) => EntityField val a -> SqlExpr (Value a) -> SqlExpr (Update val) field +=. expr = setAux field (\ent -> ent ^. field +. expr) (-=.) :: (PersistEntity val, PersistField a) => EntityField val a -> SqlExpr (Value a) -> SqlExpr (Update val) field -=. expr = setAux field (\ent -> ent ^. field -. expr) (*=.) :: (PersistEntity val, PersistField a) => EntityField val a -> SqlExpr (Value a) -> SqlExpr (Update val) field *=. expr = setAux field (\ent -> ent ^. field *. expr) (/=.) :: (PersistEntity val, PersistField a) => EntityField val a -> SqlExpr (Value a) -> SqlExpr (Update val) field /=. expr = setAux field (\ent -> ent ^. field /. expr) -- | Apply a 'PersistField' constructor to @SqlExpr Value@ arguments. (<#) :: (a -> b) -> SqlExpr (Value a) -> SqlExpr (Insertion b) (<#) _ (ERaw _ f) = EInsert Proxy f (<#) _ (ECompositeKey _) = throw (CompositeKeyErr ToInsertionError) (<#) _ (EAliasedValue i _) = EInsert Proxy $ aliasedValueIdentToRawSql i (<#) _ (EValueReference i i') = EInsert Proxy $ valueReferenceToRawSql i i' -- | Apply extra @SqlExpr Value@ arguments to a 'PersistField' constructor (<&>) :: SqlExpr (Insertion (a -> b)) -> SqlExpr (Value a) -> SqlExpr (Insertion b) (EInsert _ f) <&> v = EInsert Proxy $ \x -> let (fb, fv) = f x (gb, gv) = g x in (fb <> ", " <> gb, fv ++ gv) where g = case v of ERaw _ f' -> f' EAliasedValue i _ -> aliasedValueIdentToRawSql i EValueReference i i' -> valueReferenceToRawSql i i' ECompositeKey _ -> throw (CompositeKeyErr CombineInsertionError) -- | @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 => [(SqlExpr (Value Bool), SqlExpr (Value a))] -> SqlExpr (Value a) -> SqlExpr (Value a) case_ = unsafeSqlCase -- | Convert an entity's key into another entity's. -- -- This function is to be used when you change an entity's @Id@ to be -- that of another entity. For example: -- -- @ -- Bar -- barNum Int -- Foo -- bar BarId -- fooNum Int -- Primary bar -- @ -- -- In this example, Bar is said to be the BaseEnt(ity), and Foo the child. -- To model this in Esqueleto, declare: -- -- @ -- instance ToBaseId Foo where -- type BaseEnt Foo = Bar -- toBaseIdWitness barId = FooKey barId -- @ -- -- Now you're able to write queries such as: -- -- @ -- 'select' $ -- 'from' $ \(bar `'InnerJoin`` foo) -> do -- 'on' ('toBaseId' (foo '^.' FooId) '==.' bar '^.' BarId) -- return (bar, foo) -- @ -- -- Note: this function may be unsafe to use in conditions not like the -- one of the example above. -- -- /Since: 2.4.3/ toBaseId :: ToBaseId ent => SqlExpr (Value (Key ent)) -> SqlExpr (Value (Key (BaseEnt ent))) toBaseId = veryUnsafeCoerceSqlExprValue {-# DEPRECATED random_ "Since 2.6.0: `random_` is not uniform across all databases! Please use a specific one such as 'Database.Esqueleto.PostgreSQL.random_', 'Database.Esqueleto.MySQL.random_', or 'Database.Esqueleto.SQLite.random_'" #-} {-# DEPRECATED rand "Since 2.6.0: `rand` ordering function is not uniform across all databases! To avoid accidental partiality it will be removed in the next major version." #-} -- Fixity declarations infixl 9 ^. 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'. newtype Value a = Value { unValue :: a } deriving (Eq, Ord, Show, Typeable) -- | /Since: 1.4.4/ instance Functor Value where fmap f (Value a) = Value (f a) instance Applicative Value where (<*>) (Value f) (Value a) = Value (f a) pure = Value instance Monad Value where (>>=) x f = valueJoin $ fmap f x where valueJoin (Value v) = v -- | A list of single values. There's a limited set of functions -- able to work with this data type (such as 'subList_select', -- 'valList', 'in_' and 'exists'). newtype ValueList a = ValueList a deriving (Eq, Ord, Show, Typeable) -- | A wrapper type for for any @expr (Value a)@ for all a. data SomeValue where SomeValue :: SqlExpr (Value a) -> SomeValue -- | 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 a where toSomeValues :: a -> [SomeValue] instance ( ToSomeValues a , ToSomeValues b ) => ToSomeValues (a, b) where toSomeValues (a,b) = toSomeValues a ++ toSomeValues b instance ( ToSomeValues a , ToSomeValues b , ToSomeValues c ) => ToSomeValues (a, b, c) where toSomeValues (a,b,c) = toSomeValues a ++ toSomeValues b ++ toSomeValues c instance ( ToSomeValues a , ToSomeValues b , ToSomeValues c , ToSomeValues d ) => ToSomeValues (a, b, c, d) where toSomeValues (a,b,c,d) = toSomeValues a ++ toSomeValues b ++ toSomeValues c ++ toSomeValues d instance ( ToSomeValues a , ToSomeValues b , ToSomeValues c , ToSomeValues d , ToSomeValues e ) => ToSomeValues (a, b, c, d, e) where toSomeValues (a,b,c,d,e) = toSomeValues a ++ toSomeValues b ++ toSomeValues c ++ toSomeValues d ++ toSomeValues e instance ( ToSomeValues a , ToSomeValues b , ToSomeValues c , ToSomeValues d , ToSomeValues e , ToSomeValues f ) => ToSomeValues (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 a , ToSomeValues b , ToSomeValues c , ToSomeValues d , ToSomeValues e , ToSomeValues f , ToSomeValues g ) => ToSomeValues (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 a , ToSomeValues b , ToSomeValues c , ToSomeValues d , ToSomeValues e , ToSomeValues f , ToSomeValues g , ToSomeValues h ) => ToSomeValues (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 type family KnowResult a where KnowResult (i -> o) = KnowResult o KnowResult a = a -- | A class for constructors or function which result type is known. -- -- @since 3.1.3 class FinalResult a where finalR :: a -> KnowResult a instance FinalResult (Unique val) where finalR = id instance (FinalResult b) => FinalResult (a -> b) where finalR f = finalR (f undefined) -- | Convert a constructor for a 'Unique' key on a record to the 'UniqueDef' that defines it. You -- can supply just the constructor itself, or a value of the type - the library is capable of figuring -- it out from there. -- -- @since 3.1.3 toUniqueDef :: forall a val. (KnowResult a ~ (Unique val), PersistEntity val,FinalResult a) => a -> UniqueDef toUniqueDef uniqueConstructor = uniqueDef where proxy :: Proxy val proxy = Proxy unique :: Unique val unique = finalR uniqueConstructor -- there must be a better way to get the constrain name from a unique, make this not a list search filterF = (==) (persistUniqueToFieldNames unique) . uniqueFields uniqueDef = head . filter filterF . entityUniques . entityDef $ proxy -- | Render updates to be use in a SET clause for a given sql backend. -- -- @since 3.1.3 renderUpdates :: (BackendCompatible SqlBackend backend) => backend -> [SqlExpr (Update val)] -> (TLB.Builder, [PersistValue]) renderUpdates conn = uncommas' . concatMap renderUpdate where mk :: SqlExpr (Value ()) -> [(TLB.Builder, [PersistValue])] mk (ERaw _ f) = [f info] mk (ECompositeKey _) = throw (CompositeKeyErr MakeSetError) -- FIXME mk (EAliasedValue i _) = [aliasedValueIdentToRawSql i info] mk (EValueReference i i') = [valueReferenceToRawSql i i' info] renderUpdate :: SqlExpr (Update val) -> [(TLB.Builder, [PersistValue])] renderUpdate (ESet f) = mk (f undefined) -- second parameter of f is always unused info = (projectBackend conn, initialIdentState) -- | 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, Show) -- | (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/ | ForUpdateSkipLocked -- ^ @FOR UPDATE SKIP LOCKED@ 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 -- | Class that enables one to use 'toBaseId' to convert an entity's -- key on a query into another (cf. 'toBaseId'). class ToBaseId ent where -- | e.g. @type BaseEnt MyBase = MyChild@ type BaseEnt ent :: * -- | Convert from the key of the BaseEnt(ity) to the key of the child entity. -- This function is not actually called, but that it typechecks proves this operation is safe. toBaseIdWitness :: Key (BaseEnt ent) -> Key ent -- | @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 a => (a -> SqlQuery b) -> SqlQuery b from = (from_ >>=) -- | (Internal) Class that implements the tuple 'from' magic (see -- 'fromStart'). class From a where from_ :: SqlQuery a instance ( FromPreprocess (SqlExpr (Entity val)) ) => From (SqlExpr (Entity val)) where from_ = fromPreprocess >>= fromFinish instance ( FromPreprocess (SqlExpr (Maybe (Entity val))) ) => From (SqlExpr (Maybe (Entity val))) where from_ = fromPreprocess >>= fromFinish instance ( FromPreprocess (InnerJoin a b) ) => From (InnerJoin a b) where from_ = fromPreprocess >>= fromFinish instance ( FromPreprocess (CrossJoin a b) ) => From (CrossJoin a b) where from_ = fromPreprocess >>= fromFinish instance ( FromPreprocess (LeftOuterJoin a b) ) => From (LeftOuterJoin a b) where from_ = fromPreprocess >>= fromFinish instance ( FromPreprocess (RightOuterJoin a b) ) => From (RightOuterJoin a b) where from_ = fromPreprocess >>= fromFinish instance ( FromPreprocess (FullOuterJoin a b) ) => From (FullOuterJoin a b) where from_ = fromPreprocess >>= fromFinish instance ( From a , From b ) => From (a, b) where from_ = (,) <$> from_ <*> from_ instance ( From a , From b , From c ) => From (a, b, c) where from_ = (,,) <$> from_ <*> from_ <*> from_ instance ( From a , From b , From c , From d ) => From (a, b, c, d) where from_ = (,,,) <$> from_ <*> from_ <*> from_ <*> from_ instance ( From a , From b , From c , From d , From e ) => From (a, b, c, d, e) where from_ = (,,,,) <$> from_ <*> from_ <*> from_ <*> from_ <*> from_ instance ( From a , From b , From c , From d , From e , From f ) => From (a, b, c, d, e, f) where from_ = (,,,,,) <$> from_ <*> from_ <*> from_ <*> from_ <*> from_ <*> from_ instance ( From a , From b , From c , From d , From e , From f , From g ) => From (a, b, c, d, e, f, g) where from_ = (,,,,,,) <$> from_ <*> from_ <*> from_ <*> from_ <*> from_ <*> from_ <*> from_ instance ( From a , From b , From c , From d , From e , From f , From g , From h ) => From (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 FromPreprocess a where fromPreprocess :: SqlQuery (SqlExpr (PreprocessedFrom a)) instance ( PersistEntity val , BackendCompatible SqlBackend (PersistEntityBackend val) ) => FromPreprocess (SqlExpr (Entity val)) where fromPreprocess = fromStart instance ( PersistEntity val , BackendCompatible SqlBackend (PersistEntityBackend val) ) => FromPreprocess (SqlExpr (Maybe (Entity val))) where fromPreprocess = fromStartMaybe instance ( FromPreprocess a , FromPreprocess b , IsJoinKind join ) => FromPreprocess (join a b) where fromPreprocess = do a <- fromPreprocess b <- fromPreprocess fromJoin a b -- | Exception data type for @esqueleto@ internal errors data EsqueletoError = CompositeKeyErr CompositeKeyError | AliasedValueErr UnexpectedValueError | UnexpectedCaseErr UnexpectedCaseError | SqlBinOpCompositeErr SqlBinOpCompositeError deriving (Show) instance Exception EsqueletoError data UnexpectedValueError = NotError | ToInsertionError | CombineInsertionError | FoldHelpError | SqlCaseError | SqlCastAsError | SqlFunctionError | MakeOnClauseError | MakeExcError | MakeSetError | MakeWhereError | MakeHavingError deriving (Show) type CompositeKeyError = UnexpectedValueError data UnexpectedCaseError = EmptySqlExprValueList | MakeFromError | UnsupportedSqlInsertIntoType | InsertionFinalError | NewIdentForError | UnsafeSqlCaseError | OperationNotSupported | NotImplemented deriving (Show) data SqlBinOpCompositeError = MismatchingLengthsError | NullPlaceholdersError | DeconstructionError deriving (Show) -- | SQL backend for @esqueleto@ using 'SqlPersistT'. newtype SqlQuery a = Q { unQ :: W.WriterT SideData (S.State IdentState) a } 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 Semigroup SideData where SideData d f s w g h o l k <> SideData d' f' s' w' g' h' o' l' k' = SideData (d <> d') (f <> f') (s <> s') (w <> w') (g <> g') (h <> h') (o <> o') (l <> l') (k <> k') instance Monoid SideData where mempty = SideData mempty mempty mempty mempty mempty mempty mempty mempty mempty mappend = (<>) -- | The @DISTINCT@ "clause". data DistinctClause = DistinctAll -- ^ The default, everything. | DistinctStandard -- ^ Only @DISTINCT@, SQL standard. | DistinctOn [SqlExpr DistinctOn] -- ^ @DISTINCT ON@, PostgreSQL extension. instance Semigroup DistinctClause where DistinctOn a <> DistinctOn b = DistinctOn (a <> b) DistinctOn a <> _ = DistinctOn a DistinctStandard <> _ = DistinctStandard DistinctAll <> b = b instance Monoid DistinctClause where mempty = DistinctAll mappend = (<>) -- | A part of a @FROM@ clause. data FromClause = FromStart Ident EntityDef | FromJoin FromClause JoinKind FromClause (Maybe (SqlExpr (Value Bool))) | OnClause (SqlExpr (Value Bool)) | FromQuery Ident (IdentInfo -> (TLB.Builder, [PersistValue])) collectIdents :: FromClause -> Set Ident collectIdents fc = case fc of FromStart i _ -> Set.singleton i FromJoin lhs _ rhs _ -> collectIdents lhs <> collectIdents rhs OnClause _ -> mempty FromQuery _ _ -> mempty instance Show FromClause where show fc = case fc of FromStart i _ -> "(FromStart " <> show i <> ")" FromJoin lhs jk rhs mexpr -> mconcat [ "(FromJoin " , show lhs , " " , show jk , " " , case mexpr of Nothing -> "(no on clause)" Just expr -> "(" <> render' expr <> ")" , " " , show rhs , ")" ] OnClause expr -> "(OnClause " <> render' expr <> ")" FromQuery ident _-> "(FromQuery " <> show ident <> ")" where dummy = SqlBackend { connEscapeName = \(DBName x) -> x } render' = T.unpack . renderExpr dummy -- | 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 :: SqlBackend -> [FromClause] -> Either (SqlExpr (Value Bool)) [FromClause] collectOnClauses sqlBackend = go Set.empty [] -- . (\fc -> Debug.trace ("From Clauses: " <> show fc) fc) where go is [] (f@(FromStart i _) : fs) = fmap (f:) (go (Set.insert i is) [] fs) -- fast path go idents acc (OnClause expr : fs) = do (idents', a) <- findMatching idents acc expr go idents' a fs go idents acc (f:fs) = go idents (f:acc) fs go _ acc [] = return $ reverse acc findMatching :: Set Ident -> [FromClause] -> SqlExpr (Value Bool) -> Either (SqlExpr (Value Bool)) (Set Ident, [FromClause]) findMatching idents fromClauses expr = -- Debug.trace ("From Clause: " <> show fromClauses) $ case fromClauses of f : acc -> let idents' = idents <> Set.fromList (Maybe.catMaybes [findLeftmostIdent f, findRightmostIdent f]) in case tryMatch idents' expr f of Just (idents'', f') -> return (idents'', f' : acc) Nothing -> fmap (f:) <$> findMatching idents' acc expr [] -> Left expr findRightmostIdent (FromStart i _) = Just i findRightmostIdent (FromJoin _ _ r _) = findRightmostIdent r findRightmostIdent (OnClause {}) = Nothing findRightmostIdent (FromQuery _ _) = Nothing findLeftmostIdent (FromStart i _) = Just i findLeftmostIdent (FromJoin l _ _ _) = findLeftmostIdent l findLeftmostIdent (OnClause {}) = Nothing findLeftmostIdent (FromQuery _ _) = Nothing tryMatch :: Set Ident -> SqlExpr (Value Bool) -> FromClause -> Maybe (Set Ident, FromClause) tryMatch idents expr fromClause = case fromClause of FromJoin l k r onClause -> matchTable <|> matchR <|> matchC <|> matchL <|> matchPartial -- right to left where matchR = fmap (\r' -> FromJoin l k r' onClause) <$> tryMatch idents expr r matchL = fmap (\l' -> FromJoin l' k r onClause) <$> tryMatch idents expr l matchPartial = do --Debug.traceM $ "matchPartial" --Debug.traceM $ "matchPartial: identsInOnClause: " <> show identsInOnClause i1 <- findLeftmostIdent l i2 <- findLeftmostIdent r let leftIdents = collectIdents l -- Debug.traceM $ "matchPartial: i1: " <> show i1 -- Debug.traceM $ "matchPartial: i2: " <> show i2 -- Debug.traceM $ "matchPartial: idents: " <> show idents guard $ Set.isSubsetOf identsInOnClause (Set.fromList [i1, i2] <> leftIdents) guard $ k /= CrossJoinKind guard $ Maybe.isNothing onClause pure (idents, FromJoin l k r (Just expr)) matchC = case onClause of Nothing | "?" `T.isInfixOf` renderedExpr -> return (idents, FromJoin l k r (Just expr)) | Set.null identsInOnClause -> return (idents, FromJoin l k r (Just expr)) | otherwise -> Nothing Just _ -> Nothing matchTable = do i1 <- findLeftmostIdent r i2 <- findRightmostIdent l guard $ Set.fromList [i1, i2] `Set.isSubsetOf` identsInOnClause guard $ k /= CrossJoinKind guard $ Maybe.isNothing onClause pure (Set.fromList [i1, i2] <> idents, FromJoin l k r (Just expr)) _ -> Nothing where identsInOnClause = onExprToTableIdentifiers renderedExpr = renderExpr sqlBackend expr onExprToTableIdentifiers = Set.map (I . tableAccessTable) . either error id . parseOnExpr sqlBackend $ renderedExpr -- | A complete @WHERE@ clause. data WhereClause = Where (SqlExpr (Value Bool)) | NoWhere instance Semigroup WhereClause where NoWhere <> w = w w <> NoWhere = w Where e1 <> Where e2 = Where (e1 &&. e2) instance Monoid WhereClause where mempty = NoWhere mappend = (<>) -- | A @GROUP BY@ clause. newtype GroupByClause = GroupBy [SomeValue] instance Semigroup GroupByClause where GroupBy fs <> GroupBy fs' = GroupBy (fs <> fs') instance Monoid GroupByClause where mempty = GroupBy [] mappend = (<>) -- | 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 Semigroup LimitClause where Limit l1 o1 <> Limit l2 o2 = Limit (l2 `mplus` l1) (o2 `mplus` o1) -- More than one 'limit' or 'offset' is issued, we want to -- keep the latest one. That's why we use mplus with -- "reversed" arguments. instance Monoid LimitClause where mempty = Limit mzero mzero mappend = (<>) -- | A locking clause. type LockingClause = Monoid.Last LockingKind ---------------------------------------------------------------------- -- | Identifier used for table names. newtype Ident = I T.Text deriving (Eq, Ord, Show) -- | 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 (DBName original) = Q $ lift $ findFree Nothing where findFree msuffix = do let withSuffix = maybe id (\suffix -> (<> T.pack (show suffix))) msuffix original isInUse <- S.gets (HS.member withSuffix . inUse) if isInUse then findFree (succ <$> (msuffix <|> Just (1 :: Int))) else do S.modify (\s -> s { inUse = HS.insert withSuffix (inUse s) }) pure (I withSuffix) -- | 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) -- Base Table EAliasedEntity :: Ident -> Ident -> SqlExpr (Entity val) -- Source Base EAliasedEntityReference :: Ident -> 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 raw expression with an alias EAliasedValue :: Ident -> SqlExpr (Value a) -> SqlExpr (Value a) -- A reference to an aliased field in a table or subquery EValueReference :: Ident -> (IdentInfo -> Ident) -> 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 ToSomeValues (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 ---------------------------------------------------------------------- -- | (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 v = ERaw Never buildCase where buildCase :: IdentInfo -> (TLB.Builder, [PersistValue]) buildCase info = let (elseText, elseVals) = valueToSql v info (whenText, whenVals) = mapWhen when info in ( "CASE" <> whenText <> " ELSE " <> elseText <> " END", whenVals <> elseVals) mapWhen :: [(SqlExpr (Value Bool), SqlExpr (Value a))] -> IdentInfo -> (TLB.Builder, [PersistValue]) mapWhen [] _ = throw (UnexpectedCaseErr UnsafeSqlCaseError) mapWhen when' info = foldl (foldHelp info) (mempty, mempty) when' foldHelp :: IdentInfo -> (TLB.Builder, [PersistValue]) -> (SqlExpr (Value Bool), SqlExpr (Value a)) -> (TLB.Builder, [PersistValue]) foldHelp _ _ (ECompositeKey _, _) = throw (CompositeKeyErr FoldHelpError) foldHelp _ _ (_, ECompositeKey _) = throw (CompositeKeyErr FoldHelpError) foldHelp info (b0, vals0) (v1, v2) = let (b1, vals1) = valueToSql v1 info (b2, vals2) = valueToSql v2 info in ( b0 <> " WHEN " <> b1 <> " THEN " <> b2, vals0 <> vals1 <> vals2 ) valueToSql :: SqlExpr (Value a) -> IdentInfo -> (TLB.Builder, [PersistValue]) valueToSql (ERaw p f) = (first (parensM p)) . f valueToSql (ECompositeKey _) = throw (CompositeKeyErr SqlCaseError) valueToSql (EAliasedValue i _) = aliasedValueIdentToRawSql i valueToSql (EValueReference i i') = valueReferenceToRawSql i i' -- | (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 op a b = unsafeSqlBinOp op (construct a) (construct b) where construct :: SqlExpr (Value a) -> SqlExpr (Value a) construct (ERaw p f) = ERaw Parens $ \info -> let (b1, vals) = f info build ("?", [PersistList vals']) = (uncommas $ replicate (length vals') "?", vals') build expr = expr in build (parensM p b1, vals) construct (ECompositeKey f) = ERaw Parens $ \info -> (uncommas $ f info, mempty) construct (EAliasedValue i _) = ERaw Never $ aliasedValueIdentToRawSql i construct (EValueReference i i') = ERaw Never $ valueReferenceToRawSql i i' {-# 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 listify (EAliasedValue i _) = deconstruct . (aliasedValueIdentToRawSql i) listify (EValueReference i i') = deconstruct . (valueReferenceToRawSql i i') deconstruct :: (TLB.Builder, [PersistValue]) -> ([TLB.Builder], [PersistValue]) deconstruct ("?", [PersistList vals]) = (replicate (length vals) "?", vals) deconstruct (b', []) = (TLB.fromLazyText <$> TL.splitOn "," (TLB.toLazyText b'), []) deconstruct _ = throw (SqlBinOpCompositeErr DeconstructionError) compose f1 f2 info | not (null v1 || null v2) = throw (SqlBinOpCompositeErr NullPlaceholdersError) | length b1 /= length b2 = throw (SqlBinOpCompositeErr MismatchingLengthsError) | otherwise = (bc, vc) where (b1, v1) = f1 info (b2, v2) = f2 info bc = intersperseB sep [x <> op <> y | (x, y) <- zip b1 b2] vc = v1 <> v2 -- | (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 $ const (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 valueToFunctionArg v = case v of ERaw _ f -> f info EAliasedValue i _ -> aliasedValueIdentToRawSql i info EValueReference i i' -> valueReferenceToRawSql i i' info ECompositeKey _ -> throw (CompositeKeyErr SqlFunctionError) (argsTLB, argsVals) = uncommas' $ map valueToFunctionArg $ 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) -- | (Internal) An explicit SQL type cast using CAST(value as type). -- See 'unsafeSqlBinOp' for warnings. unsafeSqlCastAs :: T.Text -> SqlExpr (Value a) -> SqlExpr (Value b) unsafeSqlCastAs t v = ERaw Never ((first (\value -> "CAST" <> parens (value <> " AS " <> TLB.fromText t))) . valueToText) where valueToText info = case v of (ERaw p f) -> let (b, vals) = f info in (parensM p b, vals) EAliasedValue i _ -> aliasedValueIdentToRawSql i info EValueReference i i' -> valueReferenceToRawSql i i' info ECompositeKey _ -> throw (CompositeKeyErr SqlCastAsError) -- | (Internal) This class allows 'unsafeSqlFunction' to work with different -- numbers of arguments; specifically it allows providing arguments to a sql -- function via an n-tuple of @SqlExpr (Value _)@ values, which are not all -- necessarily required to be the same type. There are instances for up to -- 10-tuples, but for sql functions which take more than 10 arguments, you can -- also nest tuples, as e.g. @toArgList ((a,b),(c,d))@ is the same as -- @toArgList (a,b,c,d)@. class UnsafeSqlFunctionArgument a where toArgList :: a -> [SqlExpr (Value ())] -- | Useful for 0-argument functions, like @now@ in Postgresql. -- -- @since 3.2.1 instance UnsafeSqlFunctionArgument () where toArgList _ = [] 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 -- | @since 3.2.3 instance ( UnsafeSqlFunctionArgument a , UnsafeSqlFunctionArgument b , UnsafeSqlFunctionArgument c , UnsafeSqlFunctionArgument d , UnsafeSqlFunctionArgument e ) => UnsafeSqlFunctionArgument (a, b, c, d, e) where toArgList = toArgList . from5 -- | @since 3.2.3 instance ( UnsafeSqlFunctionArgument a , UnsafeSqlFunctionArgument b , UnsafeSqlFunctionArgument c , UnsafeSqlFunctionArgument d , UnsafeSqlFunctionArgument e , UnsafeSqlFunctionArgument f ) => UnsafeSqlFunctionArgument (a, b, c, d, e, f) where toArgList = toArgList . from6 -- | @since 3.2.3 instance ( UnsafeSqlFunctionArgument a , UnsafeSqlFunctionArgument b , UnsafeSqlFunctionArgument c , UnsafeSqlFunctionArgument d , UnsafeSqlFunctionArgument e , UnsafeSqlFunctionArgument f , UnsafeSqlFunctionArgument g ) => UnsafeSqlFunctionArgument (a, b, c, d, e, f, g) where toArgList = toArgList . from7 -- | @since 3.2.3 instance ( UnsafeSqlFunctionArgument a , UnsafeSqlFunctionArgument b , UnsafeSqlFunctionArgument c , UnsafeSqlFunctionArgument d , UnsafeSqlFunctionArgument e , UnsafeSqlFunctionArgument f , UnsafeSqlFunctionArgument g , UnsafeSqlFunctionArgument h ) => UnsafeSqlFunctionArgument (a, b, c, d, e, f, g, h) where toArgList = toArgList . from8 -- | @since 3.2.3 instance ( UnsafeSqlFunctionArgument a , UnsafeSqlFunctionArgument b , UnsafeSqlFunctionArgument c , UnsafeSqlFunctionArgument d , UnsafeSqlFunctionArgument e , UnsafeSqlFunctionArgument f , UnsafeSqlFunctionArgument g , UnsafeSqlFunctionArgument h , UnsafeSqlFunctionArgument i ) => UnsafeSqlFunctionArgument (a, b, c, d, e, f, g, h, i) where toArgList = toArgList . from9 -- | @since 3.2.3 instance ( UnsafeSqlFunctionArgument a , UnsafeSqlFunctionArgument b , UnsafeSqlFunctionArgument c , UnsafeSqlFunctionArgument d , UnsafeSqlFunctionArgument e , UnsafeSqlFunctionArgument f , UnsafeSqlFunctionArgument g , UnsafeSqlFunctionArgument h , UnsafeSqlFunctionArgument i , UnsafeSqlFunctionArgument j ) => UnsafeSqlFunctionArgument (a, b, c, d, e, f, g, h, i, j) where toArgList = toArgList . from10 -- | (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 veryUnsafeCoerceSqlExprValue (EAliasedValue i v) = EAliasedValue i (veryUnsafeCoerceSqlExprValue v) veryUnsafeCoerceSqlExprValue (EValueReference i i') = EValueReference i i' -- | (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 = throw (UnexpectedCaseErr EmptySqlExprValueList) ---------------------------------------------------------------------- -- | (Internal) Execute an @esqueleto@ @SELECT@ 'SqlQuery' inside -- @persistent@'s 'SqlPersistT' monad. rawSelectSource :: ( SqlSelect a r , MonadIO m1 , MonadIO m2 ) => Mode -> SqlQuery a -> SqlReadT m1 (Acquire (C.ConduitT () r m2 ())) rawSelectSource mode query = do conn <- projectBackend <$> R.ask let _ = conn :: SqlBackend res <- R.withReaderT (const conn) (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 , BackendCompatible SqlBackend backend , IsPersistBackend backend , PersistQueryRead backend , PersistStoreRead backend, PersistUniqueRead backend , MonadResource m ) => SqlQuery a -> C.ConduitT () r (R.ReaderT backend m) () selectSource query = do res <- lift $ rawSelectSource SELECT query (key, src) <- lift $ allocateAcquire res src lift $ release key -- | 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 -- 'subSelect'). -- -- 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 -> SqlReadT m [r] select query = do res <- rawSelectSource SELECT query conn <- R.ask liftIO $ with res $ flip R.runReaderT conn . runSource -- | (Internal) Run a 'C.Source' of rows. runSource :: Monad m => C.ConduitT () r (R.ReaderT backend m) () -> R.ReaderT backend m [r] runSource src = C.runConduit $ src C..| CL.consume ---------------------------------------------------------------------- -- | (Internal) Execute an @esqueleto@ statement inside -- @persistent@'s 'SqlPersistT' monad. rawEsqueleto :: ( MonadIO m, SqlSelect a r, BackendCompatible SqlBackend backend) => Mode -> SqlQuery a -> R.ReaderT backend 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 () -> SqlWriteT m () delete = void . deleteCount -- | Same as 'delete', but returns the number of rows affected. deleteCount :: ( MonadIO m ) => SqlQuery () -> SqlWriteT 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, PersistEntity val , BackendCompatible SqlBackend (PersistEntityBackend val) ) => (SqlExpr (Entity val) -> SqlQuery ()) -> SqlWriteT m () update = void . updateCount -- | Same as 'update', but returns the number of rows affected. updateCount :: ( MonadIO m, PersistEntity val , BackendCompatible SqlBackend (PersistEntityBackend val) ) => (SqlExpr (Entity val) -> SqlQuery ()) -> SqlWriteT 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), see the 'renderQueryToText' function (along with -- 'renderQuerySelect', 'renderQueryUpdate', etc). toRawSql :: (SqlSelect a r, BackendCompatible SqlBackend backend) => Mode -> (backend, IdentState) -> 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 = (projectBackend 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 ] -- | Renders a 'SqlQuery' into a 'Text' value along with the list of -- 'PersistValue's that would be supplied to the database for @?@ placeholders. -- -- You must ensure that the 'Mode' you pass to this function corresponds with -- the actual 'SqlQuery'. If you pass a query that uses incompatible features -- (like an @INSERT@ statement with a @SELECT@ mode) then you'll get a weird -- result. -- -- @since 3.1.1 renderQueryToText :: (SqlSelect a r, BackendCompatible SqlBackend backend, Monad m) => Mode -- ^ Whether to render as an 'SELECT', 'DELETE', etc. -> SqlQuery a -- ^ The SQL query you want to render. -> R.ReaderT backend m (T.Text, [PersistValue]) renderQueryToText mode query = do backend <- R.ask let (builder, pvals) = toRawSql mode (backend, initialIdentState) query pure (builderToText builder, pvals) -- | Renders a 'SqlQuery' into a 'Text' value along with the list of -- 'PersistValue's that would be supplied to the database for @?@ placeholders. -- -- You must ensure that the 'Mode' you pass to this function corresponds with -- the actual 'SqlQuery'. If you pass a query that uses incompatible features -- (like an @INSERT@ statement with a @SELECT@ mode) then you'll get a weird -- result. -- -- @since 3.1.1 renderQuerySelect :: (SqlSelect a r, BackendCompatible SqlBackend backend, Monad m) => SqlQuery a -- ^ The SQL query you want to render. -> R.ReaderT backend m (T.Text, [PersistValue]) renderQuerySelect = renderQueryToText SELECT -- | Renders a 'SqlQuery' into a 'Text' value along with the list of -- 'PersistValue's that would be supplied to the database for @?@ placeholders. -- -- You must ensure that the 'Mode' you pass to this function corresponds with -- the actual 'SqlQuery'. If you pass a query that uses incompatible features -- (like an @INSERT@ statement with a @SELECT@ mode) then you'll get a weird -- result. -- -- @since 3.1.1 renderQueryDelete :: (SqlSelect a r, BackendCompatible SqlBackend backend, Monad m) => SqlQuery a -- ^ The SQL query you want to render. -> R.ReaderT backend m (T.Text, [PersistValue]) renderQueryDelete = renderQueryToText DELETE -- | Renders a 'SqlQuery' into a 'Text' value along with the list of -- 'PersistValue's that would be supplied to the database for @?@ placeholders. -- -- You must ensure that the 'Mode' you pass to this function corresponds with -- the actual 'SqlQuery'. If you pass a query that uses incompatible features -- (like an @INSERT@ statement with a @SELECT@ mode) then you'll get a weird -- result. -- -- @since 3.1.1 renderQueryUpdate :: (SqlSelect a r, BackendCompatible SqlBackend backend, Monad m) => SqlQuery a -- ^ The SQL query you want to render. -> R.ReaderT backend m (T.Text, [PersistValue]) renderQueryUpdate = renderQueryToText UPDATE -- | Renders a 'SqlQuery' into a 'Text' value along with the list of -- 'PersistValue's that would be supplied to the database for @?@ placeholders. -- -- You must ensure that the 'Mode' you pass to this function corresponds with -- the actual 'SqlQuery'. If you pass a query that uses incompatible features -- (like an @INSERT@ statement with a @SELECT@ mode) then you'll get a weird -- result. -- -- @since 3.1.1 renderQueryInsertInto :: (SqlSelect a r, BackendCompatible SqlBackend backend, Monad m) => SqlQuery a -- ^ The SQL query you want to render. -> R.ReaderT backend m (T.Text, [PersistValue]) renderQueryInsertInto = renderQueryToText INSERT_INTO -- | (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 (fst info) 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 _) = throw (UnexpectedCaseErr MakeFromError) mk _ (FromQuery ident f) = let (queryText, queryVals) = f info in ((parens queryText) <> " AS " <> useIdent info ident, queryVals) 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 _) = throw (CompositeKeyErr MakeOnClauseError) makeOnClause (EAliasedValue _ _) = throw (AliasedValueErr MakeOnClauseError) makeOnClause (EValueReference _ _) = throw (AliasedValueErr MakeOnClauseError) mkExc :: SqlExpr (Value Bool) -> OnClauseWithoutMatchingJoinException mkExc (ERaw _ f) = OnClauseWithoutMatchingJoinException $ TL.unpack $ TLB.toLazyText $ fst (f info) mkExc (ECompositeKey _) = throw (CompositeKeyErr MakeExcError) mkExc (EAliasedValue _ _) = throw (AliasedValueErr MakeExcError) mkExc (EValueReference _ _) = throw (AliasedValueErr MakeExcError) makeSet :: IdentInfo -> [SetClause] -> (TLB.Builder, [PersistValue]) makeSet _ [] = mempty makeSet info os = first ("\nSET " <>) . uncommas' $ concatMap mk os where mk (SetClause (ERaw _ f)) = [f info] mk (SetClause (ECompositeKey _)) = throw (CompositeKeyErr MakeSetError) -- FIXME mk (SetClause (EAliasedValue i _)) = [aliasedValueIdentToRawSql i info] mk (SetClause (EValueReference i i')) = [valueReferenceToRawSql i i' info] makeWhere :: IdentInfo -> WhereClause -> (TLB.Builder, [PersistValue]) makeWhere _ NoWhere = mempty makeWhere info (Where v) = first ("\nWHERE " <>) $ x info where x = case v of ERaw _ f -> f EAliasedValue i _ -> aliasedValueIdentToRawSql i EValueReference i i' -> valueReferenceToRawSql i i' ECompositeKey _ -> throw (CompositeKeyErr MakeWhereError) makeGroupBy :: IdentInfo -> GroupByClause -> (TLB.Builder, [PersistValue]) makeGroupBy _ (GroupBy []) = (mempty, []) makeGroupBy info (GroupBy fields) = first ("\nGROUP BY " <>) build where build :: (TLB.Builder, [PersistValue]) build = uncommas' $ map match fields match :: SomeValue -> (TLB.Builder, [PersistValue]) match (SomeValue (ERaw _ f)) = f info match (SomeValue (ECompositeKey f)) = (mconcat $ f info, mempty) match (SomeValue (EAliasedValue i _)) = aliasedValueIdentToRawSql i info match (SomeValue (EValueReference i i')) = valueReferenceToRawSql i i' info makeHaving :: IdentInfo -> WhereClause -> (TLB.Builder, [PersistValue]) makeHaving _ NoWhere = mempty makeHaving info (Where v) = first ("\nHAVING " <>) $ x info where x = case v of ERaw _ f -> f EAliasedValue i _ -> aliasedValueIdentToRawSql i EValueReference i i' -> valueReferenceToRawSql i i' ECompositeKey _ -> throw (CompositeKeyErr MakeHavingError) -- makeHaving, makeWhere and makeOrderBy makeOrderByNoNewline :: IdentInfo -> [OrderByClause] -> (TLB.Builder, [PersistValue]) makeOrderByNoNewline _ [] = mempty makeOrderByNoNewline info os = first ("ORDER BY " <>) . uncommas' $ concatMap mk os where mk :: OrderByClause -> [(TLB.Builder, [PersistValue])] mk (EOrderBy t (ECompositeKey f)) = let fs = f info vals = repeat [] in zip (map (<> orderByType t) fs) vals mk (EOrderBy t v) = let x = case v of ERaw p f -> (first (parensM p)) . f EAliasedValue i _ -> aliasedValueIdentToRawSql i EValueReference i i' -> valueReferenceToRawSql i i' ECompositeKey _ -> undefined -- defined above in [ first (<> orderByType t) $ x info ] mk EOrderRandom = [first (<> "RANDOM()") mempty] orderByType ASC = " ASC" orderByType DESC = " DESC" makeOrderBy :: IdentInfo -> [OrderByClause] -> (TLB.Builder, [PersistValue]) makeOrderBy _ [] = mempty makeOrderBy info is = let (tlb, vals) = makeOrderByNoNewline info is in ("\n" <> tlb, vals) {-# DEPRECATED EOrderRandom "Since 2.6.0: `rand` ordering function is not uniform across all databases! To avoid accidental partiality it will be removed in the next major version." #-} makeLimit :: IdentInfo -> LimitClause -> [OrderByClause] -> (TLB.Builder, [PersistValue]) makeLimit (conn, _) (Limit ml mo) orderByClauses = let limitRaw = connLimitOffset conn (v ml, v mo) hasOrderClause "\n" hasOrderClause = not (null orderByClauses) v = maybe 0 fromIntegral in (TLB.fromText limitRaw, mempty) makeLocking :: LockingClause -> (TLB.Builder, [PersistValue]) makeLocking = flip (,) [] . maybe mempty toTLB . Monoid.getLast where toTLB ForUpdate = "\nFOR UPDATE" toTLB ForUpdateSkipLocked = "\nFOR UPDATE SKIP LOCKED" toTLB ForShare = "\nFOR SHARE" toTLB LockInShareMode = "\nLOCK IN SHARE MODE" parens :: TLB.Builder -> TLB.Builder parens b = "(" <> (b <> ")") aliasedValueIdentToRawSql :: Ident -> IdentInfo -> (TLB.Builder, [PersistValue]) aliasedValueIdentToRawSql i info = (useIdent info i, mempty) valueReferenceToRawSql :: Ident -> (IdentInfo -> Ident) -> IdentInfo -> (TLB.Builder, [PersistValue]) valueReferenceToRawSql sourceIdent columnIdentF info = (useIdent info sourceIdent <> "." <> useIdent info (columnIdentF info), mempty) aliasedEntityColumnIdent :: Ident -> FieldDef -> IdentInfo -> Ident aliasedEntityColumnIdent (I baseIdent) field info = I (baseIdent <> "_" <> (builderToText $ fromDBName info $ fieldDB field)) aliasedColumnName :: Ident -> IdentInfo -> T.Text -> TLB.Builder aliasedColumnName (I baseIdent) info columnName = useIdent info (I (baseIdent <> "_" <> columnName)) ---------------------------------------------------------------------- -- | (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 = throw (UnexpectedCaseErr UnsupportedSqlInsertIntoType) -- | @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 (throw (UnexpectedCaseErr InsertionFinalError))) -- | 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) sqlSelectCols info expr@(EAliasedEntity aliasIdent tableIdent) = ret where process ed = uncommas $ map ((name <>) . aliasName) $ entityColumnNames ed (fst info) aliasName columnName = (TLB.fromText columnName) <> " AS " <> aliasedColumnName aliasIdent info columnName name = useIdent info tableIdent <> "." ret = let ed = entityDef $ getEntityVal $ return expr in (process ed, mempty) sqlSelectCols info expr@(EAliasedEntityReference sourceIdent baseIdent) = ret where process ed = uncommas $ map ((name <>) . aliasedColumnName baseIdent info) $ entityColumnNames ed (fst info) name = useIdent info sourceIdent <> "." 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, []) materializeExpr info (EAliasedValue ident x) = let (b, vals) = materializeExpr info x in (b <> " AS " <> (useIdent info ident), vals) materializeExpr info (EValueReference sourceIdent columnIdent) = valueReferenceToRawSql sourceIdent columnIdent info -- | 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 from5 :: (a,b,c,d,e) -> ((a,b),(c,d),e) from5 (a,b,c,d,e) = ((a,b),(c,d),e) 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 from6 :: (a,b,c,d,e,f) -> ((a,b),(c,d),(e,f)) from6 (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) 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 from7 :: (a,b,c,d,e,f,g) -> ((a,b),(c,d),(e,f),g) from7 (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) 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 from8 :: (a,b,c,d,e,f,g,h) -> ((a,b),(c,d),(e,f),(g,h)) from8 (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) 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 from9 :: (a,b,c,d,e,f,g,h,i) -> ((a,b),(c,d),(e,f),(g,h),i) from9 (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) 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 from10 :: (a,b,c,d,e,f,g,h,i,j) -> ((a,b),(c,d),(e,f),(g,h),(i,j)) from10 (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) 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. -- -- /Since: 2.4.2/ insertSelect :: (MonadIO m, PersistEntity a) => SqlQuery (SqlExpr (Insertion a)) -> SqlWriteT m () insertSelect = void . insertSelectCount -- | Insert a 'PersistField' for every selected value, return the count afterward insertSelectCount :: (MonadIO m, PersistEntity a) => SqlQuery (SqlExpr (Insertion a)) -> SqlWriteT m Int64 insertSelectCount = rawEsqueleto INSERT_INTO . fmap EInsertFinal -- | Renders an expression into 'Text'. Only useful for creating a textual -- representation of the clauses passed to an "On" clause. -- -- @since 3.2.0 renderExpr :: SqlBackend -> SqlExpr (Value Bool) -> T.Text renderExpr sqlBackend e = case e of ERaw _ mkBuilderValues -> do let (builder, _) = mkBuilderValues (sqlBackend, initialIdentState) in (builderToText builder) ECompositeKey mkInfo -> throw . RenderExprUnexpectedECompositeKey . builderToText . mconcat . mkInfo $ (sqlBackend, initialIdentState) EAliasedValue i _ -> builderToText $ useIdent (sqlBackend, initialIdentState) i EValueReference i i' -> let (builder, _) = valueReferenceToRawSql i i' (sqlBackend, initialIdentState) in (builderToText builder) -- | An exception thrown by 'RenderExpr' - it's not designed to handle composite -- keys, and will blow up if you give it one. -- -- @since 3.2.0 data RenderExprException = RenderExprUnexpectedECompositeKey T.Text deriving Show -- | -- -- @since 3.2.0 instance Exception RenderExprException esqueleto-3.3.3.2/src/Database/Esqueleto/Internal/ExprParser.hs0000644000000000000000000000547513555674431022550 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -- | This is an internal module. This module may have breaking changes without -- a corresponding major version bump. If you use this module, please open an -- issue with your use-case so we can safely support it. module Database.Esqueleto.Internal.ExprParser where import Prelude hiding (takeWhile) import Control.Applicative ((<|>)) import Control.Monad (void) import Data.Attoparsec.Text import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as Text import Database.Persist.Sql -- | A type representing the access of a table value. In Esqueleto, we get -- a guarantee that the access will look something like: -- -- @ -- escape-char [character] escape-char . escape-char [character] escape-char -- ^^^^^^^^^^^ ^^^^^^^^^^^ -- table name column name -- @ data TableAccess = TableAccess { tableAccessTable :: Text , tableAccessColumn :: Text } deriving (Eq, Ord, Show) -- | Parse a @SqlExpr (Value Bool)@'s textual representation into a list of -- 'TableAccess' parseOnExpr :: SqlBackend -> Text -> Either String (Set TableAccess) parseOnExpr sqlBackend text = do c <- mkEscapeChar sqlBackend parseOnly (onExpr c) text -- | This function uses the 'connEscapeName' function in the 'SqlBackend' with an -- empty identifier to pull out an escape character. This implementation works -- with postgresql, mysql, and sqlite backends. mkEscapeChar :: SqlBackend -> Either String Char mkEscapeChar sqlBackend = case Text.uncons (connEscapeName sqlBackend (DBName "")) of Nothing -> Left "Failed to get an escape character from the SQL backend." Just (c, _) -> Right c type ExprParser a = Char -> Parser a onExpr :: ExprParser (Set TableAccess) onExpr e = Set.fromList <$> many' tableAccesses where tableAccesses = do skipToEscape e "Skipping to an escape char" parseTableAccess e "Parsing a table access" skipToEscape :: ExprParser () skipToEscape escapeChar = void (takeWhile (/= escapeChar)) parseEscapedIdentifier :: ExprParser [Char] parseEscapedIdentifier escapeChar = do char escapeChar str <- parseEscapedChars escapeChar char escapeChar pure str parseTableAccess :: ExprParser TableAccess parseTableAccess ec = do tableAccessTable <- Text.pack <$> parseEscapedIdentifier ec _ <- char '.' tableAccessColumn <- Text.pack <$> parseEscapedIdentifier ec pure TableAccess {..} parseEscapedChars :: ExprParser [Char] parseEscapedChars escapeChar = go where twoEscapes = char escapeChar *> char escapeChar go = many' (notChar escapeChar <|> twoEscapes) esqueleto-3.3.3.2/src/Database/Esqueleto/MySQL.hs0000644000000000000000000000100513454457034017623 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | This module contain MySQL-specific functions. -- -- /Since: 2.2.8/ module Database.Esqueleto.MySQL ( random_ ) where import Database.Esqueleto.Internal.Language hiding (random_) import Database.Esqueleto.Internal.PersistentImport import Database.Esqueleto.Internal.Sql -- | (@random()@) Split out into database specific modules -- because MySQL uses `rand()`. -- -- /Since: 2.6.0/ random_ :: (PersistField a, Num a) => SqlExpr (Value a) random_ = unsafeSqlValue "RAND()" esqueleto-3.3.3.2/src/Database/Esqueleto/PostgreSQL.hs0000644000000000000000000002522313556116505020667 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings , GADTs, CPP, Rank2Types , ScopedTypeVariables #-} -- | This module contain PostgreSQL-specific functions. -- -- /Since: 2.2.8/ module Database.Esqueleto.PostgreSQL ( AggMode(..) , arrayAggDistinct , arrayAgg , arrayAggWith , arrayRemove , arrayRemoveNull , stringAgg , stringAggWith , maybeArray , chr , now_ , random_ , upsert , upsertBy , insertSelectWithConflict , insertSelectWithConflictCount -- * Internal , unsafeSqlAggregateFunction ) where #if __GLASGOW_HASKELL__ < 804 import Data.Semigroup #endif import qualified Data.Text.Internal.Builder as TLB import Data.Time.Clock (UTCTime) import Database.Esqueleto.Internal.Language hiding (random_) import Database.Esqueleto.Internal.PersistentImport hiding (upsert, upsertBy) import Database.Esqueleto.Internal.Sql import Database.Esqueleto.Internal.Internal (EsqueletoError(..), CompositeKeyError(..), UnexpectedCaseError(..), SetClause, Ident(..), uncommas, FinalResult(..), toUniqueDef, KnowResult, renderUpdates) import Database.Persist.Class (OnlyOneUniqueKey) import Data.List.NonEmpty ( NonEmpty( (:|) ) ) import Data.Int (Int64) import Data.Proxy (Proxy(..)) import Control.Arrow ((***), first) import Control.Exception (throw) import Control.Monad (void) import Control.Monad.IO.Class (MonadIO (..)) import qualified Control.Monad.Trans.Reader as R -- | (@random()@) Split out into database specific modules -- because MySQL uses `rand()`. -- -- /Since: 2.6.0/ random_ :: (PersistField a, Num a) => SqlExpr (Value a) random_ = unsafeSqlValue "RANDOM()" -- | Empty array literal. (@val []@) does unfortunately not work emptyArray :: SqlExpr (Value [a]) emptyArray = unsafeSqlValue "'{}'" -- | Coalesce an array with an empty default value maybeArray :: (PersistField a, PersistField [a]) => SqlExpr (Value (Maybe [a])) -> SqlExpr (Value [a]) maybeArray x = coalesceDefault [x] (emptyArray) -- | Aggregate mode data AggMode = AggModeAll -- ^ ALL | AggModeDistinct -- ^ DISTINCT deriving (Show) -- | (Internal) Create a custom aggregate functions with aggregate mode -- -- /Do/ /not/ use this function directly, instead define a new function and give -- it a type (see `unsafeSqlBinOp`) unsafeSqlAggregateFunction :: UnsafeSqlFunctionArgument a => TLB.Builder -> AggMode -> a -> [OrderByClause] -> SqlExpr (Value b) unsafeSqlAggregateFunction name mode args orderByClauses = ERaw Never $ \info -> let (orderTLB, orderVals) = makeOrderByNoNewline info orderByClauses -- Don't add a space if we don't have order by clauses orderTLBSpace = case orderByClauses of [] -> "" (_:_) -> " " (argsTLB, argsVals) = uncommas' $ map (\(ERaw _ f) -> f info) $ toArgList args aggMode = case mode of AggModeAll -> "" -- ALL is the default, so we don't need to -- specify it AggModeDistinct -> "DISTINCT " in ( name <> parens (aggMode <> argsTLB <> orderTLBSpace <> orderTLB) , argsVals <> orderVals ) --- | (@array_agg@) Concatenate input values, including @NULL@s, --- into an array. arrayAggWith :: AggMode -> SqlExpr (Value a) -> [OrderByClause] -> SqlExpr (Value (Maybe [a])) arrayAggWith = unsafeSqlAggregateFunction "array_agg" --- | (@array_agg@) Concatenate input values, including @NULL@s, --- into an array. arrayAgg :: (PersistField a) => SqlExpr (Value a) -> SqlExpr (Value (Maybe [a])) arrayAgg x = arrayAggWith AggModeAll x [] -- | (@array_agg@) Concatenate distinct input values, including @NULL@s, into -- an array. -- -- /Since: 2.5.3/ arrayAggDistinct :: (PersistField a, PersistField [a]) => SqlExpr (Value a) -> SqlExpr (Value (Maybe [a])) arrayAggDistinct x = arrayAggWith AggModeDistinct x [] -- | (@array_remove@) Remove all elements equal to the given value from the -- array. -- -- /Since: 2.5.3/ arrayRemove :: SqlExpr (Value [a]) -> SqlExpr (Value a) -> SqlExpr (Value [a]) arrayRemove arr elem' = unsafeSqlFunction "array_remove" (arr, elem') -- | Remove @NULL@ values from an array arrayRemoveNull :: SqlExpr (Value [Maybe a]) -> SqlExpr (Value [a]) -- This can't be a call to arrayRemove because it changes the value type arrayRemoveNull x = unsafeSqlFunction "array_remove" (x, unsafeSqlValue "NULL") -- | (@string_agg@) Concatenate input values separated by a -- delimiter. stringAggWith :: SqlString s => AggMode -- ^ Aggregate mode (ALL or DISTINCT) -> SqlExpr (Value s) -- ^ Input values. -> SqlExpr (Value s) -- ^ Delimiter. -> [OrderByClause] -- ^ ORDER BY clauses -> SqlExpr (Value (Maybe s)) -- ^ Concatenation. stringAggWith mode expr delim os = unsafeSqlAggregateFunction "string_agg" mode (expr, delim) os -- | (@string_agg@) Concatenate input values separated by a -- delimiter. -- -- /Since: 2.2.8/ stringAgg :: SqlString s => SqlExpr (Value s) -- ^ Input values. -> SqlExpr (Value s) -- ^ Delimiter. -> SqlExpr (Value (Maybe s)) -- ^ Concatenation. stringAgg expr delim = stringAggWith AggModeAll expr delim [] -- | (@chr@) Translate the given integer to a character. (Note the result will -- depend on the character set of your database.) -- -- /Since: 2.2.11/ chr :: SqlString s => SqlExpr (Value Int) -> SqlExpr (Value s) chr = unsafeSqlFunction "chr" now_ :: SqlExpr (Value UTCTime) now_ = unsafeSqlFunction "NOW" () upsert :: (MonadIO m, PersistEntity record, OnlyOneUniqueKey record, PersistRecordBackend record SqlBackend, IsPersistBackend (PersistEntityBackend record)) => record -- ^ new record to insert -> [SqlExpr (Update record)] -- ^ updates to perform if the record already exists -> R.ReaderT SqlBackend m (Entity record) -- ^ the record in the database after the operation upsert record updates = do uniqueKey <- onlyUnique record upsertBy uniqueKey record updates upsertBy :: (MonadIO m, PersistEntity record, IsPersistBackend (PersistEntityBackend record)) => Unique record -- ^ uniqueness constraint to find by -> record -- ^ new record to insert -> [SqlExpr (Update record)] -- ^ updates to perform if the record already exists -> R.ReaderT SqlBackend m (Entity record) -- ^ the record in the database after the operation upsertBy uniqueKey record updates = do sqlB <- R.ask maybe (throw (UnexpectedCaseErr OperationNotSupported)) -- Postgres backend should have connUpsertSql, if this error is thrown, check changes on persistent (handler sqlB) (connUpsertSql sqlB) where addVals l = map toPersistValue (toPersistFields record) ++ l ++ persistUniqueToValues uniqueKey entDef = entityDef (Just record) uDef = toUniqueDef uniqueKey updatesText conn = first builderToText $ renderUpdates conn updates handler conn f = fmap head $ uncurry rawSql $ (***) (f entDef (uDef :| [])) addVals $ updatesText conn -- | Inserts into a table the results of a query similar to 'insertSelect' but allows -- to update values that violate a constraint during insertions. -- -- Example of usage: -- -- @ -- share [ mkPersist sqlSettings -- , mkDeleteCascade sqlSettings -- , mkMigrate "migrate" -- ] [persistLowerCase| -- Bar -- num Int -- deriving Eq Show -- Foo -- num Int -- UniqueFoo num -- deriving Eq Show -- |] -- -- insertSelectWithConflict -- UniqueFoo -- (UniqueFoo undefined) or (UniqueFoo anyNumber) would also work -- (from $ \b -> -- return $ Foo <# (b ^. BarNum) -- ) -- (\current excluded -> -- [FooNum =. (current ^. FooNum) +. (excluded ^. FooNum)] -- ) -- @ -- -- Inserts to table Foo all Bar.num values and in case of conflict SomeFooUnique, -- the conflicting value is updated to the current plus the excluded. -- -- @since 3.1.3 insertSelectWithConflict :: forall a m val. ( FinalResult a, KnowResult a ~ (Unique val), MonadIO m, PersistEntity val) => a -- ^ Unique constructor or a unique, this is used just to get the name of the postgres constraint, the value(s) is(are) never used, so if you have a unique "MyUnique 0", "MyUnique undefined" would work as well. -> SqlQuery (SqlExpr (Insertion val)) -- ^ Insert query. -> (SqlExpr (Entity val) -> SqlExpr (Entity val) -> [SqlExpr (Update val)]) -- ^ A list of updates to be applied in case of the constraint being violated. The expression takes the current and excluded value to produce the updates. -> SqlWriteT m () insertSelectWithConflict unique query = void . insertSelectWithConflictCount unique query -- | Same as 'insertSelectWithConflict' but returns the number of rows affected. -- -- @since 3.1.3 insertSelectWithConflictCount :: forall a val m. ( FinalResult a, KnowResult a ~ (Unique val), MonadIO m, PersistEntity val) => a -> SqlQuery (SqlExpr (Insertion val)) -> (SqlExpr (Entity val) -> SqlExpr (Entity val) -> [SqlExpr (Update val)]) -> SqlWriteT m Int64 insertSelectWithConflictCount unique query conflictQuery = do conn <- R.ask uncurry rawExecuteCount $ combine (toRawSql INSERT_INTO (conn, initialIdentState) (fmap EInsertFinal query)) (conflict conn) where proxy :: Proxy val proxy = Proxy updates = conflictQuery entCurrent entExcluded combine (tlb1,vals1) (tlb2,vals2) = (builderToText (tlb1 `mappend` tlb2), vals1 ++ vals2) entExcluded = EEntity $ I "excluded" tableName = unDBName . entityDB . entityDef entCurrent = EEntity $ I (tableName proxy) uniqueDef = toUniqueDef unique constraint = TLB.fromText . unDBName . uniqueDBName $ uniqueDef renderedUpdates :: (BackendCompatible SqlBackend backend) => backend -> (TLB.Builder, [PersistValue]) renderedUpdates conn = renderUpdates conn updates conflict conn = (foldr1 mappend ([ TLB.fromText "ON CONFLICT ON CONSTRAINT \"", constraint, TLB.fromText "\" DO " ] ++ if null updates then [TLB.fromText "NOTHING"] else [ TLB.fromText "UPDATE SET ", updatesTLB ]),values) where (updatesTLB,values) = renderedUpdates conn esqueleto-3.3.3.2/src/Database/Esqueleto/PostgreSQL/JSON.hs0000644000000000000000000006142713523055213021436 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-| This module contains PostgreSQL-specific JSON functions. A couple of things to keep in mind about this module: * The @Type@ column in the PostgreSQL documentation tables are the types of the right operand, the left is always @jsonb@. * Since these operators can all take @NULL@ values as their input, and most can also output @NULL@ values (even when the inputs are guaranteed to not be NULL), all 'JSONB' values are wrapped in 'Maybe'. This also makes it easier to chain them. (cf. 'JSONBExpr') Just use the 'just' function to lift any non-'Maybe' JSONB values in case it doesn't type check. * As long as the previous operator's resulting value is a 'JSONBExpr', any other JSON operator can be used to transform the JSON further. (e.g. @[1,2,3] -> 1 \@> 2@) /The PostgreSQL version the functions work with are included/ /in their description./ @since 3.1.0 -} module Database.Esqueleto.PostgreSQL.JSON ( -- * JSONB Newtype -- -- | With 'JSONB', you can use your Haskell types in your -- database table models as long as your type has 'FromJSON' -- and 'ToJSON' instances. -- -- @ -- import Database.Persist.TH -- -- share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase| -- Example -- json (JSONB MyType) -- |] -- @ -- -- CAUTION: Remember that changing the 'FromJSON' instance -- of your type might result in old data becoming unparsable! -- You can use (@JSONB Data.Aeson.Value@) for unstructured/variable JSON. JSONB(..) , JSONBExpr , jsonbVal -- * JSONAccessor , JSONAccessor(..) -- * Arrow operators -- -- | /Better documentation included with individual functions/ -- -- The arrow operators are selection functions to select values -- from JSON arrays or objects. -- -- === PostgreSQL Documentation -- -- /Requires PostgreSQL version >= 9.3/ -- -- @ -- | Type | Description | Example | Example Result -- -----+--------+--------------------------------------------+--------------------------------------------------+---------------- -- -> | int | Get JSON array element (indexed from zero, | '[{"a":"foo"},{"b":"bar"},{"c":"baz"}]'::json->2 | {"c":"baz"} -- | | negative integers count from the end) | | -- -> | text | Get JSON object field by key | '{"a": {"b":"foo"}}'::json->'a' | {"b":"foo"} -- ->> | int | Get JSON array element as text | '[1,2,3]'::json->>2 | 3 -- ->> | text | Get JSON object field as text | '{"a":1,"b":2}'::json->>'b' | 2 -- \#> | text[] | Get JSON object at specified path | '{"a": {"b":{"c": "foo"}}}'::json#>'{a,b}' | {"c": "foo"} -- \#>> | text[] | Get JSON object at specified path as text | '{"a":[1,2,3],"b":[4,5,6]}'::json#>>'{a,2}' | 3 -- @ , (->.) , (->>.) , (#>.) , (#>>.) -- * Filter operators -- -- | /Better documentation included with individual functions/ -- -- These functions test certain properties of JSON values -- and return booleans, so are mainly used in WHERE clauses. -- -- === PostgreSQL Documentation -- -- /Requires PostgreSQL version >= 9.4/ -- -- @ -- | Type | Description | Example -- ----+--------+-----------------------------------------------------------------+--------------------------------------------------- -- \@> | jsonb | Does the left JSON value contain within it the right value? | '{"a":1, "b":2}'::jsonb \@> '{"b":2}'::jsonb -- <\@ | jsonb | Is the left JSON value contained within the right value? | '{"b":2}'::jsonb <\@ '{"a":1, "b":2}'::jsonb -- ? | text | Does the string exist as a top-level key within the JSON value? | '{"a":1, "b":2}'::jsonb ? 'b' -- ?| | text[] | Do any of these array strings exist as top-level keys? | '{"a":1, "b":2, "c":3}'::jsonb ?| array['b', 'c'] -- ?& | text[] | Do all of these array strings exist as top-level keys? | '["a", "b"]'::jsonb ?& array['a', 'b'] -- @ , (@>.) , (<@.) , (?.) , (?|.) , (?&.) -- * Deletion and concatenation operators -- -- | /Better documentation included with individual functions/ -- -- These operators change the shape of the JSON value and -- also have the highest risk of throwing an exception. -- Please read the descriptions carefully before using these functions. -- -- === PostgreSQL Documentation -- -- /Requires PostgreSQL version >= 9.5/ -- -- @ -- | Type | Description | Example -- ----+---------+------------------------------------------------------------------------+------------------------------------------------- -- || | jsonb | Concatenate two jsonb values into a new jsonb value | '["a", "b"]'::jsonb || '["c", "d"]'::jsonb -- - | text | Delete key/value pair or string element from left operand. | '{"a": "b"}'::jsonb - 'a' -- | | Key/value pairs are matched based on their key value. | -- - | integer | Delete the array element with specified index (Negative integers count | '["a", "b"]'::jsonb - 1 -- | | from the end). Throws an error if top level container is not an array. | -- \#- | text[] | Delete the field or element with specified path | '["a", {"b":1}]'::jsonb \#- '{1,b}' -- | | (for JSON arrays, negative integers count from the end) | -- @ -- -- /Requires PostgreSQL version >= 10/ -- -- @ -- | Type | Description | Example -- ----+---------+------------------------------------------------------------------------+------------------------------------------------- -- - | text[] | Delete multiple key/value pairs or string elements from left operand. | '{"a": "b", "c": "d"}'::jsonb - '{a,c}'::text[] -- | | Key/value pairs are matched based on their key value. | -- @ , (-.) , (--.) , (#-.) , (||.) ) where import Data.Text (Text) import Database.Esqueleto.Internal.Language hiding ((?.), (-.), (||.)) import Database.Esqueleto.Internal.PersistentImport import Database.Esqueleto.Internal.Sql import Database.Esqueleto.PostgreSQL.JSON.Instances infixl 6 ->., ->>., #>., #>>. infixl 6 @>., <@., ?., ?|., ?&. infixl 6 ||., -., --., #-. -- | /Requires PostgreSQL version >= 9.3/ -- -- This function extracts the jsonb value from a JSON array or object, -- depending on whether you use an @int@ or a @text@. (cf. 'JSONAccessor') -- -- As long as the left operand is @jsonb@, this function will not -- throw an exception, but will return @NULL@ when an @int@ is used on -- anything other than a JSON array, or a @text@ is used on anything -- other than a JSON object. -- -- === __PostgreSQL Documentation__ -- -- @ -- | Type | Description | Example | Example Result -- ----+------+--------------------------------------------+--------------------------------------------------+---------------- -- -> | int | Get JSON array element (indexed from zero) | '[{"a":"foo"},{"b":"bar"},{"c":"baz"}]'::json->2 | {"c":"baz"} -- -> | text | Get JSON object field by key | '{"a": {"b":"foo"}}'::json->'a' | {"b":"foo"} -- @ -- -- @since 3.1.0 (->.) :: JSONBExpr a -> JSONAccessor -> JSONBExpr b (->.) value (JSONKey txt) = unsafeSqlBinOp " -> " value $ val txt (->.) value (JSONIndex i) = unsafeSqlBinOp " -> " value $ val i -- | /Requires PostgreSQL version >= 9.3/ -- -- Identical to '->.', but the resulting DB type is a @text@, -- so it could be chained with anything that uses @text@. -- -- __CAUTION: if the "scalar" JSON value @null@ is the result__ -- __of this function, PostgreSQL will interpret it as a__ -- __PostgreSQL @NULL@ value, and will therefore be 'Nothing'__ -- __instead of (Just "null")__ -- -- === __PostgreSQL Documentation__ -- -- @ -- | Type | Description | Example | Example Result -- -----+------+--------------------------------+-----------------------------+---------------- -- ->> | int | Get JSON array element as text | '[1,2,3]'::json->>2 | 3 -- ->> | text | Get JSON object field as text | '{"a":1,"b":2}'::json->>'b' | 2 -- @ -- -- @since 3.1.0 (->>.) :: JSONBExpr a -> JSONAccessor -> SqlExpr (Value (Maybe Text)) (->>.) value (JSONKey txt) = unsafeSqlBinOp " ->> " value $ val txt (->>.) value (JSONIndex i) = unsafeSqlBinOp " ->> " value $ val i -- | /Requires PostgreSQL version >= 9.3/ -- -- This operator can be used to select a JSON value from deep inside another one. -- It only works on objects and arrays and will result in @NULL@ ('Nothing') when -- encountering any other JSON type. -- -- The 'Text's used in the right operand list will always select an object field, but -- can also select an index from a JSON array if that text is parsable as an integer. -- -- Consider the following: -- -- @ -- x ^. TestBody #>. ["0","1"] -- @ -- -- The following JSON values in the @test@ table's @body@ column will be affected: -- -- @ -- Values in column | Resulting value -- --------------------------------------+---------------------------- -- {"0":{"1":"Got it!"}} | "Got it!" -- {"0":[null,["Got it!","Even here!"]]} | ["Got it!", "Even here!"] -- [{"1":"Got it again!"}] | "Got it again!" -- [[null,{\"Wow\":"so deep!"}]] | {\"Wow\": "so deep!"} -- false | NULL -- "nope" | NULL -- 3.14 | NULL -- @ -- -- === __PostgreSQL Documentation__ -- -- @ -- | Type | Description | Example | Example Result -- -----+--------+-----------------------------------+--------------------------------------------+---------------- -- \#> | text[] | Get JSON object at specified path | '{"a": {"b":{"c": "foo"}}}'::json#>'{a,b}' | {"c": "foo"} -- @ -- -- @since 3.1.0 (#>.) :: JSONBExpr a -> [Text] -> JSONBExpr b (#>.) value = unsafeSqlBinOp " #> " value . mkTextArray -- | /Requires PostgreSQL version >= 9.3/ -- -- This function is to '#>.' as '->>.' is to '->.' -- -- __CAUTION: if the "scalar" JSON value @null@ is the result__ -- __of this function, PostgreSQL will interpret it as a__ -- __PostgreSQL @NULL@ value, and will therefore be 'Nothing'__ -- __instead of (Just "null")__ -- -- === __PostgreSQL Documentation__ -- -- @ -- | Type | Description | Example | Example Result -- -----+--------+-------------------------------------------+---------------------------------------------+---------------- -- \#>> | text[] | Get JSON object at specified path as text | '{"a":[1,2,3],"b":[4,5,6]}'::json#>>'{a,2}' | 3 -- @ -- -- @since 3.1.0 (#>>.) :: JSONBExpr a -> [Text] -> SqlExpr (Value (Maybe Text)) (#>>.) value = unsafeSqlBinOp " #>> " value . mkTextArray -- | /Requires PostgreSQL version >= 9.4/ -- -- This operator checks for the JSON value on the right to be a subset -- of the JSON value on the left. -- -- Examples of the usage of this operator can be found in -- the Database.Persist.Postgresql.JSON module. -- -- (here: ) -- -- === __PostgreSQL Documentation__ -- -- @ -- | Type | Description | Example -- ----+-------+-------------------------------------------------------------+--------------------------------------------- -- \@> | jsonb | Does the left JSON value contain within it the right value? | '{"a":1, "b":2}'::jsonb \@> '{"b":2}'::jsonb -- @ -- -- @since 3.1.0 (@>.) :: JSONBExpr a -> JSONBExpr b -> SqlExpr (Value Bool) (@>.) = unsafeSqlBinOp " @> " -- | /Requires PostgreSQL version >= 9.4/ -- -- This operator works the same as '@>.', just with the arguments flipped. -- So it checks for the JSON value on the left to be a subset of JSON value on the right. -- -- Examples of the usage of this operator can be found in -- the Database.Persist.Postgresql.JSON module. -- -- (here: ) -- -- === __PostgreSQL Documentation__ -- -- @ -- | Type | Description | Example -- ----+-------+----------------------------------------------------------+--------------------------------------------- -- <\@ | jsonb | Is the left JSON value contained within the right value? | '{"b":2}'::jsonb <\@ '{"a":1, "b":2}'::jsonb -- @ -- -- @since 3.1.0 (<@.) :: JSONBExpr a -> JSONBExpr b -> SqlExpr (Value Bool) (<@.) = unsafeSqlBinOp " <@ " -- | /Requires PostgreSQL version >= 9.4/ -- -- This operator checks if the given text is a top-level member of the -- JSON value on the left. This means a top-level field in an object, a -- top-level string in an array or just a string value. -- -- Examples of the usage of this operator can be found in -- the Database.Persist.Postgresql.JSON module. -- -- (here: ) -- -- === __PostgreSQL Documentation__ -- -- @ -- | Type | Description | Example -- ---+------+-----------------------------------------------------------------+------------------------------- -- ? | text | Does the string exist as a top-level key within the JSON value? | '{"a":1, "b":2}'::jsonb ? 'b' -- @ -- -- @since 3.1.0 (?.) :: JSONBExpr a -> Text -> SqlExpr (Value Bool) (?.) value = unsafeSqlBinOp " ?? " value . val -- | /Requires PostgreSQL version >= 9.4/ -- -- This operator checks if __ANY__ of the given texts is a top-level member -- of the JSON value on the left. This means any top-level field in an object, -- any top-level string in an array or just a string value. -- -- Examples of the usage of this operator can be found in -- the Database.Persist.Postgresql.JSON module. -- -- (here: ) -- -- === __PostgreSQL Documentation__ -- -- @ -- | Type | Description | Example -- ----+--------+--------------------------------------------------------+--------------------------------------------------- -- ?| | text[] | Do any of these array strings exist as top-level keys? | '{"a":1, "b":2, "c":3}'::jsonb ?| array['b', 'c'] -- @ -- -- @since 3.1.0 (?|.) :: JSONBExpr a -> [Text] -> SqlExpr (Value Bool) (?|.) value = unsafeSqlBinOp " ??| " value . mkTextArray -- | /Requires PostgreSQL version >= 9.4/ -- -- This operator checks if __ALL__ of the given texts are top-level members -- of the JSON value on the left. This means a top-level field in an object, -- a top-level string in an array or just a string value. -- -- Examples of the usage of this operator can be found in -- the Database.Persist.Postgresql.JSON module. -- -- (here: ) -- -- === __PostgreSQL Documentation__ -- -- @ -- | Type | Description | Example -- ----+--------+--------------------------------------------------------+---------------------------------------- -- ?& | text[] | Do all of these array strings exist as top-level keys? | '["a", "b"]'::jsonb ?& array['a', 'b'] -- @ -- -- @since 3.1.0 (?&.) :: JSONBExpr a -> [Text] -> SqlExpr (Value Bool) (?&.) value = unsafeSqlBinOp " ??& " value . mkTextArray -- | /Requires PostgreSQL version >= 9.5/ -- -- This operator concatenates two JSON values. The behaviour is -- self-evident when used on two arrays, but the behaviour on different -- combinations of JSON values might behave unexpectedly. -- -- __CAUTION: THIS FUNCTION THROWS AN EXCEPTION WHEN CONCATENATING__ -- __A JSON OBJECT WITH A JSON SCALAR VALUE!__ -- -- === __Arrays__ -- -- This operator is a standard concatenation function when used on arrays: -- -- @ -- [1,2] || [2,3] == [1,2,2,3] -- [] || [1,2,3] == [1,2,3] -- [1,2,3] || [] == [1,2,3] -- @ -- -- === __Objects__ -- When concatenating JSON objects with other JSON objects, the fields -- from the JSON object on the right are added to the JSON object on the -- left. When concatenating a JSON object with a JSON array, the object -- will be inserted into the array; either on the left or right, depending -- on the position relative to the operator. -- -- When concatening an object with a scalar value, an exception is thrown. -- -- @ -- {"a": 3.14} || {"b": true} == {"a": 3.14, "b": true} -- {"a": "b"} || {"a": null} == {"a": null} -- {"a": {"b": true, "c": false}} || {"a": {"b": false}} == {"a": {"b": false}} -- {"a": 3.14} || [1,null] == [{"a": 3.14},1,null] -- [1,null] || {"a": 3.14} == [1,null,{"a": 3.14}] -- 1 || {"a": 3.14} == ERROR: invalid concatenation of jsonb objects -- {"a": 3.14} || false == ERROR: invalid concatenation of jsonb objects -- @ -- -- === __Scalar values__ -- -- Scalar values can be thought of as being singleton arrays when -- used with this operator. This rule does not apply when concatenating -- with JSON objects. -- -- @ -- 1 || null == [1,null] -- true || "a" == [true,"a"] -- [1,2] || false == [1,2,false] -- null || [1,"a"] == [null,1,"a"] -- {"a":3.14} || true == ERROR: invalid concatenation of jsonb objects -- 3.14 || {"a":3.14} == ERROR: invalid concatenation of jsonb objects -- {"a":3.14} || [true] == [{"a":3.14},true] -- [false] || {"a":3.14} == [false,{"a":3.14}] -- @ -- -- === __PostgreSQL Documentation__ -- -- @ -- | Type | Description | Example -- ----+-------+-----------------------------------------------------+-------------------------------------------- -- || | jsonb | Concatenate two jsonb values into a new jsonb value | '["a", "b"]'::jsonb || '["c", "d"]'::jsonb -- @ -- -- /Note: The @||@ operator concatenates the elements at the top level of/ -- /each of its operands. It does not operate recursively./ -- -- /For example, if both operands are objects with a common key field name,/ -- /the value of the field in the result will just be the value from the right/ -- /hand operand./ -- -- @since 3.1.0 (||.) :: JSONBExpr a -> JSONBExpr b -> JSONBExpr c (||.) = unsafeSqlBinOp " || " -- | /Requires PostgreSQL version >= 9.5/ -- -- This operator can remove a key from an object or a string element from an array -- when using text, and remove certain elements by index from an array when using -- integers. -- -- Negative integers delete counting from the end of the array. -- (e.g. @-1@ being the last element, @-2@ being the second to last, etc.) -- -- __CAUTION: THIS FUNCTION THROWS AN EXCEPTION WHEN USED ON ANYTHING OTHER__ -- __THAN OBJECTS OR ARRAYS WHEN USING TEXT, AND ANYTHING OTHER THAN ARRAYS__ -- __WHEN USING INTEGERS!__ -- -- === __Objects and arrays__ -- -- @ -- {"a": 3.14} - "a" == {} -- {"a": "b"} - "b" == {"a": "b"} -- {"a": 3.14} - "a" == {} -- {"a": 3.14, "c": true} - "a" == {"c": true} -- ["a", 2, "c"] - "a" == [2, "c"] -- can remove strings from arrays -- [true, "b", 5] - 0 == ["b", 5] -- [true, "b", 5] - 3 == [true, "b", 5] -- [true, "b", 5] - -1 == [true, "b"] -- [true, "b", 5] - -4 == [true, "b", 5] -- [] - 1 == [] -- {"1": true} - 1 == ERROR: cannot delete from object using integer index -- 1 - \ == ERROR: cannot delete from scalar -- "a" - \ == ERROR: cannot delete from scalar -- true - \ == ERROR: cannot delete from scalar -- null - \ == ERROR: cannot delete from scalar -- @ -- -- === __PostgreSQL Documentation__ -- -- @ -- | Type | Description | Example -- ---+---------+------------------------------------------------------------------------+------------------------------------------------- -- - | text | Delete key/value pair or string element from left operand. | '{"a": "b"}'::jsonb - 'a' -- | | Key/value pairs are matched based on their key value. | -- - | integer | Delete the array element with specified index (Negative integers count | '["a", "b"]'::jsonb - 1 -- | | from the end). Throws an error if top level container is not an array. | -- @ -- -- @since 3.1.0 (-.) :: JSONBExpr a -> JSONAccessor -> JSONBExpr b (-.) value (JSONKey txt) = unsafeSqlBinOp " - " value $ val txt (-.) value (JSONIndex i) = unsafeSqlBinOp " - " value $ val i -- | /Requires PostgreSQL version >= 10/ -- -- Removes a set of keys from an object, or string elements from an array. -- -- This is the same operator internally as `-.`, but the option to use a @text -- array@, instead of @text@ or @integer@ was only added in version 10. -- That's why this function is seperate from `-.` -- -- NOTE: The following is equivalent: -- -- @{some JSON expression} -. "a" -. "b"@ -- -- is equivalent to -- -- @{some JSON expression} --. ["a","b"]@ -- -- === __PostgreSQL Documentation__ -- -- @ -- | Type | Description | Example -- ---+---------+------------------------------------------------------------------------+------------------------------------------------- -- - | text[] | Delete multiple key/value pairs or string elements from left operand. | '{"a": "b", "c": "d"}'::jsonb - '{a,c}'::text[] -- | | Key/value pairs are matched based on their key value. | -- @ -- -- @since 3.1.0 (--.) :: JSONBExpr a -> [Text] -> JSONBExpr b (--.) value = unsafeSqlBinOp " - " value . mkTextArray -- | /Requires PostgreSQL version >= 9.5/ -- -- This operator can remove elements nested in an object. -- -- If a 'Text' is not parsable as a number when selecting in an array -- (even when halfway through the selection) an exception will be thrown. -- -- Negative integers delete counting from the end of an array. -- (e.g. @-1@ being the last element, @-2@ being the second to last, etc.) -- -- __CAUTION: THIS FUNCTION THROWS AN EXCEPTION WHEN USED__ -- __ON ANYTHING OTHER THAN OBJECTS OR ARRAYS, AND WILL__ -- __ALSO THROW WHEN TRYING TO SELECT AN ARRAY ELEMENT WITH__ -- __A NON-INTEGER TEXT__ -- -- === __Objects__ -- -- @ -- {"a": 3.14, "b": null} #- [] == {"a": 3.14, "b": null} -- {"a": 3.14, "b": null} #- ["a"] == {"b": null} -- {"a": 3.14, "b": null} #- ["a","b"] == {"a": 3.14, "b": null} -- {"a": {"b":false}, "b": null} #- ["a","b"] == {"a": {}, "b": null} -- @ -- -- === __Arrays__ -- -- @ -- [true, {"b":null}, 5] #- [] == [true, {"b":null}, 5] -- [true, {"b":null}, 5] #- ["0"] == [{"b":null}, 5] -- [true, {"b":null}, 5] #- ["b"] == ERROR: path element at position 1 is not an integer: "b" -- [true, {"b":null}, 5] #- ["1","b"] == [true, {}, 5] -- [true, {"b":null}, 5] #- ["-2","b"] == [true, {}, 5] -- {"a": {"b":[false,4,null]}} #- ["a","b","2"] == {"a": {"b":[false,4]}} -- {"a": {"b":[false,4,null]}} #- ["a","b","c"] == ERROR: path element at position 3 is not an integer: "c" -- @ -- -- === __Other values__ -- -- @ -- 1 \#- {anything} == ERROR: cannot delete from scalar -- "a" \#- {anything} == ERROR: cannot delete from scalar -- true \#- {anything} == ERROR: cannot delete from scalar -- null \#- {anything} == ERROR: cannot delete from scalar -- @ -- -- === __PostgreSQL Documentation__ -- -- @ -- | Type | Description | Example -- ----+--------+---------------------------------------------------------+------------------------------------ -- \#- | text[] | Delete the field or element with specified path | '["a", {"b":1}]'::jsonb \#- '{1,b}' -- | | (for JSON arrays, negative integers count from the end) | -- @ -- -- @since 3.1.0 (#-.) :: JSONBExpr a -> [Text] -> JSONBExpr b (#-.) value = unsafeSqlBinOp " #- " value . mkTextArray mkTextArray :: [Text] -> SqlExpr (Value PersistValue) mkTextArray = val . PersistArray . fmap toPersistValue esqueleto-3.3.3.2/src/Database/Esqueleto/SQLite.hs0000644000000000000000000000101113454457034020014 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | This module contain SQLite-specific functions. -- -- /Since: 2.2.8/ module Database.Esqueleto.SQLite ( random_ ) where import Database.Esqueleto.Internal.Language hiding (random_) import Database.Esqueleto.Internal.PersistentImport import Database.Esqueleto.Internal.Sql -- | (@random()@) Split out into database specific modules -- because MySQL uses `rand()`. -- -- /Since: 2.6.0/ random_ :: (PersistField a, Num a) => SqlExpr (Value a) random_ = unsafeSqlValue "RANDOM()" esqueleto-3.3.3.2/src/Database/Esqueleto/Internal/PersistentImport.hs0000644000000000000000000000617613462122000023760 0ustar0000000000000000-- | Re-export "Database.Persist.Sql" without any clashes with -- @esqueleto@. module Database.Esqueleto.Internal.PersistentImport -- NOTE: switch back to a module export once https://gitlab.haskell.org/ghc/ghc/merge_requests/276 -- has been merged. See https://github.com/bitemyapp/esqueleto/issues/110 for more details ( toJsonText, entityIdFromJSON, entityIdToJSON, entityValues, fromPersistValueJSON, keyValueEntityFromJSON, keyValueEntityToJSON, toPersistValueJSON, selectKeys, belongsTo, belongsToJust, getEntity, getJust, getJustEntity, insertEntity, insertRecord, liftPersist, checkUnique, getByValue, insertBy, insertUniqueEntity, onlyUnique, replaceUnique, transactionSave, transactionUndo, defaultAttribute, mkColumns, getMigration, migrate, parseMigration, parseMigration', printMigration, runMigration, runMigrationSilent, runMigrationUnsafe, showMigration, decorateSQLWithLimitOffset, fieldDBName, fromSqlKey, getFieldName, getTableName, tableDBName, toSqlKey, withRawQuery, getStmtConn, rawExecute, rawExecuteCount, rawQuery, rawQueryRes, rawSql, askLogFunc, close', createSqlPool, liftSqlPersistMPool, runSqlConn, runSqlPersistM, runSqlPersistMPool, runSqlPool, withSqlConn, withSqlPool, readToUnknown, readToWrite, writeToUnknown, entityKeyFields, entityPrimary, fromPersistValueText, keyAndEntityFields, toEmbedEntityDef, PersistStore, PersistUnique, DeleteCascade(..), PersistConfig(..), BackendSpecificUpdate, Entity(..), PersistEntity(..), PersistField(..), SomePersistField(..), PersistQueryRead(..), PersistQueryWrite(..), BackendCompatible(..), BackendKey(..), HasPersistBackend(..), IsPersistBackend, PersistCore(..), PersistRecordBackend, PersistStoreRead(..), PersistStoreWrite(..), ToBackendKey(..), PersistUniqueRead(..), PersistUniqueWrite(..), PersistFieldSql(..), RawSql(..), CautiousMigration, Column(..), ConnectionPool, Migration, PersistentSqlException(..), Single(..), Sql, SqlPersistM, SqlPersistT, InsertSqlResult(..), IsSqlBackend, LogFunc, SqlBackend(..), SqlBackendCanRead, SqlBackendCanWrite, SqlReadBackend(..), SqlReadT, SqlWriteBackend(..), SqlWriteT, Statement(..), Attr, Checkmark(..), CompositeDef(..), DBName(..), EmbedEntityDef(..), EmbedFieldDef(..), EntityDef(..), ExtraLine, FieldDef(..), FieldType(..), ForeignDef(..), ForeignFieldDef, HaskellName(..), IsNullable(..), OnlyUniqueException(..), PersistException(..), PersistFilter(..), PersistUpdate(..), PersistValue(..), ReferenceDef(..), SqlType(..), UniqueDef(..), UpdateException(..), WhyNullable(..) ) where import Database.Persist.Sql hiding ( BackendSpecificFilter, Filter(..), PersistQuery, SelectOpt(..) , Update(..), delete, deleteWhereCount, updateWhereCount, selectList , selectKeysList, deleteCascadeWhere, (=.), (+=.), (-=.), (*=.), (/=.) , (==.), (!=.), (<.), (>.), (<=.), (>=.), (<-.), (/<-.), (||.) , listToJSON, mapToJSON, getPersistMap, limitOffsetOrder, selectSource , update , count ) esqueleto-3.3.3.2/src/Database/Esqueleto/PostgreSQL/JSON/Instances.hs0000644000000000000000000000725413523055213023363 0ustar0000000000000000{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} module Database.Esqueleto.PostgreSQL.JSON.Instances where import Data.Aeson (FromJSON(..), ToJSON(..), encode, eitherDecodeStrict) import Data.Bifunctor (first) import qualified Data.ByteString.Lazy as BSL (toStrict) import Data.String (IsString(..)) import Data.Text (Text) import qualified Data.Text as T (concat, pack) import qualified Data.Text.Encoding as TE (decodeUtf8, encodeUtf8) import Database.Esqueleto (Value, just, val) import Database.Esqueleto.Internal.PersistentImport import Database.Esqueleto.Internal.Sql (SqlExpr) import GHC.Generics (Generic) -- | Newtype wrapper around any type with a JSON representation. -- -- @since 3.1.0 newtype JSONB a = JSONB { unJSONB :: a } deriving ( Generic , FromJSON , ToJSON , Eq , Foldable , Functor , Ord , Read , Show , Traversable ) -- | 'SqlExpr' of a NULL-able 'JSONB' value. Hence the 'Maybe'. -- -- Note: NULL here is a PostgreSQL NULL, not a JSON 'null' type JSONBExpr a = SqlExpr (Value (Maybe (JSONB a))) -- | Convenience function to lift a regular value into -- a 'JSONB' expression. jsonbVal :: (FromJSON a, ToJSON a) => a -> JSONBExpr a jsonbVal = just . val . JSONB -- | Used with certain JSON operators. -- -- This data type has 'Num' and 'IsString' instances -- for ease of use by using integer and string literals. -- -- >>> 3 :: JSONAccessor -- JSONIndex 3 -- >>> -3 :: JSONAccessor -- JSONIndex -3 -- -- >>> "name" :: JSONAccessor -- JSONKey "name" -- -- NOTE: DO NOT USE ANY OF THE 'Num' METHODS ON THIS TYPE! data JSONAccessor = JSONIndex Int | JSONKey Text deriving (Generic, Eq, Show) -- | I repeat, DO NOT use any method other than 'fromInteger'! instance Num JSONAccessor where fromInteger = JSONIndex . fromInteger negate (JSONIndex i) = JSONIndex $ negate i negate (JSONKey _) = error "Can not negate a JSONKey" (+) = numErr (-) = numErr (*) = numErr abs = numErr signum = numErr numErr :: a numErr = error "Do not use 'Num' methods on JSONAccessors" instance IsString JSONAccessor where fromString = JSONKey . T.pack -- | @since 3.1.0 instance (FromJSON a, ToJSON a) => PersistField (JSONB a) where toPersistValue = PersistDbSpecific . BSL.toStrict . encode . unJSONB fromPersistValue pVal = fmap JSONB $ case pVal of PersistByteString bs -> first (badParse $ TE.decodeUtf8 bs) $ eitherDecodeStrict bs PersistText t -> first (badParse t) $ eitherDecodeStrict (TE.encodeUtf8 t) x -> Left $ fromPersistValueError "string or bytea" x -- | jsonb -- -- @since 3.1.0 instance (FromJSON a, ToJSON a) => PersistFieldSql (JSONB a) where sqlType _ = SqlOther "JSONB" badParse :: Text -> String -> Text badParse t = fromPersistValueParseError t . T.pack fromPersistValueError :: Text -- ^ Database type(s), should appear different from Haskell name, e.g. "integer" or "INT", not "Int". -> PersistValue -- ^ Incorrect value -> Text -- ^ Error message fromPersistValueError databaseType received = T.concat [ "Failed to parse Haskell newtype `JSONB a`; " , "expected ", databaseType , " from database, but received: ", T.pack (show received) , ". Potential solution: Check that your database schema matches your Persistent model definitions." ] fromPersistValueParseError :: Text -- ^ Received value -> Text -- ^ Additional error -> Text -- ^ Error message fromPersistValueParseError received err = T.concat [ "Failed to parse Haskell type `JSONB a`, " , "but received ", received , " | with error: ", err ] esqueleto-3.3.3.2/test/SQLite/Test.hs0000644000000000000000000001237713462122000015447 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables , FlexibleContexts , RankNTypes , TypeFamilies , OverloadedStrings #-} module Main (main) where import Control.Monad (void) import Control.Monad.IO.Class (MonadIO(liftIO)) import Control.Monad.Logger (runStderrLoggingT, runNoLoggingT) import Control.Monad.Trans.Reader (ReaderT) import Database.Persist.Sqlite (withSqliteConn) import Database.Sqlite (SqliteException) import Database.Esqueleto hiding (random_) import Database.Esqueleto.SQLite (random_) import qualified Control.Monad.Trans.Resource as R import Test.Hspec import Common.Test testSqliteRandom :: Spec testSqliteRandom = do it "works with random_" $ run $ do _ <- select $ return (random_ :: SqlExpr (Value Int)) return () testSqliteSum :: Spec testSqliteSum = do it "works with sum_" $ run $ do _ <- insert' p1 _ <- insert' p2 _ <- insert' p3 _ <- insert' p4 ret <- select $ from $ \p-> return $ joinV $ sum_ (p ^. PersonAge) liftIO $ ret `shouldBe` [ Value $ Just (36 + 17 + 17 :: Int) ] testSqliteTwoAscFields :: Spec testSqliteTwoAscFields = do it "works with two ASC fields (one call)" $ run $ do p1e <- insert' p1 p2e <- insert' p2 p3e <- insert' p3 p4e <- insert' p4 ret <- select $ from $ \p -> do orderBy [asc (p ^. PersonAge), asc (p ^. PersonName)] return p -- in SQLite and MySQL, its the reverse liftIO $ ret `shouldBe` [ p2e, p4e, p3e, p1e ] testSqliteOneAscOneDesc :: Spec testSqliteOneAscOneDesc = do it "works with one ASC and one DESC field (two calls)" $ run $ do p1e <- insert' p1 p2e <- insert' p2 p3e <- insert' p3 p4e <- insert' p4 ret <- select $ from $ \p -> do orderBy [desc (p ^. PersonAge)] orderBy [asc (p ^. PersonName)] return p liftIO $ ret `shouldBe` [ p1e, p4e, p3e, p2e ] testSqliteCoalesce :: Spec testSqliteCoalesce = do it "throws an exception on SQLite with <2 arguments" $ run (select $ from $ \p -> do return (coalesce [p ^. PersonAge]) :: SqlQuery (SqlExpr (Value (Maybe Int)))) `shouldThrow` (\(_ :: SqliteException) -> True) testSqliteUpdate :: Spec testSqliteUpdate = do it "works on a simple example" $ run $ do p1k <- insert p1 p2k <- insert p2 p3k <- insert p3 let anon = "Anonymous" () <- update $ \p -> do set p [ PersonName =. val anon , PersonAge *=. just (val 2) ] where_ (p ^. PersonName !=. val "Mike") n <- updateCount $ \p -> do set p [ PersonAge +=. just (val 1) ] where_ (p ^. PersonName !=. val "Mike") ret <- select $ from $ \p -> do orderBy [ asc (p ^. PersonName), asc (p ^. PersonAge) ] return p -- SQLite: nulls appear first, update returns matched rows. liftIO $ n `shouldBe` 2 liftIO $ ret `shouldBe` [ Entity p2k (Person anon Nothing (Just 37) 2) , Entity p1k (Person anon (Just 73) Nothing 1) , Entity p3k p3 ] nameContains :: (BaseBackend backend ~ SqlBackend, BackendCompatible SqlBackend backend, MonadIO m, SqlString s, IsPersistBackend backend, PersistQueryRead backend, PersistUniqueRead backend) => (SqlExpr (Value [Char]) -> SqlExpr (Value s) -> SqlExpr (Value Bool)) -> s -> [Entity Person] -> ReaderT backend m () nameContains f t expected = do ret <- select $ from $ \p -> do where_ (f (p ^. PersonName) ((%) ++. val t ++. (%))) orderBy [asc (p ^. PersonName)] return p liftIO $ ret `shouldBe` expected testSqliteTextFunctions :: Spec testSqliteTextFunctions = do describe "text functions" $ do it "like, (%) and (++.) work on a simple example" $ run $ do [p1e, p2e, p3e, p4e] <- mapM insert' [p1, p2, p3, p4] nameContains like "h" [p1e, p2e] nameContains like "i" [p4e, p3e] nameContains like "iv" [p4e] main :: IO () main = do hspec $ do tests run describe "Test SQLite locking" $ do testLocking withConn describe "SQLite specific tests" $ do testAscRandom random_ run testRandomMath run testSqliteRandom testSqliteSum testSqliteTwoAscFields testSqliteOneAscOneDesc testSqliteCoalesce testSqliteUpdate testSqliteTextFunctions run, runSilent, runVerbose :: Run runSilent act = runNoLoggingT $ run_worker act runVerbose act = runStderrLoggingT $ run_worker act run = if verbose then runVerbose else runSilent verbose :: Bool verbose = False run_worker :: RunDbMonad m => SqlPersistT (R.ResourceT m) a -> m a run_worker act = withConn $ runSqlConn (migrateIt >> act) migrateIt :: RunDbMonad m => SqlPersistT (R.ResourceT m) () migrateIt = do void $ runMigrationSilent migrateAll withConn :: RunDbMonad m => (SqlBackend -> R.ResourceT m a) -> m a withConn = R.runResourceT . withSqliteConn ":memory:" esqueleto-3.3.3.2/test/Common/Test.hs0000644000000000000000000026005613674150634015560 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-unused-binds #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} {-# LANGUAGE ConstraintKinds , CPP, DerivingStrategies, StandaloneDeriving , TypeApplications , PartialTypeSignatures , UndecidableInstances , EmptyDataDecls , FlexibleContexts , FlexibleInstances , DeriveGeneric , GADTs , GeneralizedNewtypeDeriving , MultiParamTypeClasses , OverloadedStrings , QuasiQuotes , Rank2Types , TemplateHaskell , TypeFamilies , ScopedTypeVariables , TypeSynonymInstances #-} module Common.Test ( tests , testLocking , testAscRandom , testRandomMath , migrateAll , migrateUnique , cleanDB , cleanUniques , RunDbMonad , Run , p1, p2, p3, p4, p5 , l1, l2, l3 , u1, u2, u3, u4 , insert' , EntityField (..) , Foo (..) , Bar (..) , Person (..) , BlogPost (..) , Lord (..) , Deed (..) , Follow (..) , CcList (..) , Frontcover (..) , Article (..) , Tag (..) , ArticleTag (..) , Article2 (..) , Point (..) , Circle (..) , Numbers (..) , OneUnique(..) , Unique(..) , DateTruncTest(..) , DateTruncTestId , Key(..) ) where import Data.Either import Data.Time import Control.Monad (forM_, replicateM, replicateM_, void) import Control.Monad.Reader (ask) import Control.Monad.Catch (MonadCatch) #if __GLASGOW_HASKELL__ >= 806 import Control.Monad.Fail (MonadFail) #endif import Control.Monad.IO.Class (MonadIO(liftIO)) import Control.Monad.Logger (MonadLogger (..), NoLoggingT, runNoLoggingT) import Control.Monad.Trans.Reader (ReaderT) import Data.Char (toLower, toUpper) import Data.Monoid ((<>)) import Database.Esqueleto import Database.Esqueleto.Experimental hiding (from, on) import qualified Database.Esqueleto.Experimental as Experimental import Database.Persist.TH import Test.Hspec import UnliftIO import qualified Data.Attoparsec.Text as AP import Data.Conduit (ConduitT, (.|), runConduit) import qualified Data.Conduit.List as CL import qualified Data.List as L import qualified Data.Set as S import qualified Data.Text as Text import qualified Data.Text.Lazy.Builder as TLB import qualified Data.Text.Internal.Lazy as TL import qualified Database.Esqueleto.Internal.Sql as EI import qualified UnliftIO.Resource as R import qualified Database.Esqueleto.Internal.ExprParser as P -- Test schema share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase| Foo name Int Primary name deriving Show Eq Ord Bar quux FooId deriving Show Eq Ord Baz blargh FooId deriving Show Eq Shoop baz BazId deriving Show Eq Asdf shoop ShoopId deriving Show Eq Another why BazId YetAnother argh ShoopId Person name String age Int Maybe weight Int Maybe favNum Int deriving Eq Show Ord BlogPost title String authorId PersonId deriving Eq Show Comment body String blog BlogPostId deriving Eq Show CommentReply body String comment CommentId Profile name String person PersonId deriving Eq Show Reply guy PersonId body String deriving Eq Show Lord county String maxlen=100 dogs Int Maybe Primary county deriving Eq Show Deed contract String maxlen=100 ownerId LordId maxlen=100 Primary contract deriving Eq Show Follow follower PersonId followed PersonId deriving Eq Show CcList names [String] Frontcover number Int title String Primary number deriving Eq Show Article title String frontcoverNumber Int Foreign Frontcover fkfrontcover frontcoverNumber deriving Eq Show ArticleMetadata articleId ArticleId Primary articleId deriving Eq Show Tag name String maxlen=100 Primary name deriving Eq Show ArticleTag articleId ArticleId tagId TagId maxlen=100 Primary articleId tagId deriving Eq Show Article2 title String frontcoverId FrontcoverId deriving Eq Show Point x Int y Int name String Primary x y deriving Eq Show Circle centerX Int centerY Int name String Foreign Point fkpoint centerX centerY deriving Eq Show Numbers int Int double Double deriving Eq Show JoinOne name String deriving Eq Show JoinTwo joinOne JoinOneId name String deriving Eq Show JoinThree joinTwo JoinTwoId name String deriving Eq Show JoinFour name String joinThree JoinThreeId deriving Eq Show JoinOther name String deriving Eq Show JoinMany name String joinOther JoinOtherId joinOne JoinOneId deriving Eq Show DateTruncTest created UTCTime deriving Eq Show |] -- Unique Test schema share [mkPersist sqlSettings, mkMigrate "migrateUnique"] [persistUpperCase| OneUnique name String value Int UniqueValue value deriving Eq Show |] instance ToBaseId ArticleMetadata where type BaseEnt ArticleMetadata = Article toBaseIdWitness articleId = ArticleMetadataKey articleId -- | this could be achieved with S.fromList, but not all lists -- have Ord instances sameElementsAs :: Eq a => [a] -> [a] -> Bool sameElementsAs l1' l2' = null (l1' L.\\ l2') -- | Helper for rounding to a specific digit -- Prelude> map (flip roundTo 12.3456) [0..5] -- [12.0, 12.3, 12.35, 12.346, 12.3456, 12.3456] roundTo :: (Fractional a, RealFrac a1, Integral b) => b -> a1 -> a roundTo n f = (fromInteger $ round $ f * (10^n)) / (10.0^^n) p1 :: Person p1 = Person "John" (Just 36) Nothing 1 p2 :: Person p2 = Person "Rachel" Nothing (Just 37) 2 p3 :: Person p3 = Person "Mike" (Just 17) Nothing 3 p4 :: Person p4 = Person "Livia" (Just 17) (Just 18) 4 p5 :: Person p5 = Person "Mitch" Nothing Nothing 5 l1 :: Lord l1 = Lord "Cornwall" (Just 36) l2 :: Lord l2 = Lord "Dorset" Nothing l3 :: Lord l3 = Lord "Chester" (Just 17) u1 :: OneUnique u1 = OneUnique "First" 0 u2 :: OneUnique u2 = OneUnique "Second" 1 u3 :: OneUnique u3 = OneUnique "Third" 0 u4 :: OneUnique u4 = OneUnique "First" 2 testSelect :: Run -> Spec testSelect run = do describe "select" $ do it "works for a single value" $ run $ do ret <- select $ return $ val (3 :: Int) liftIO $ ret `shouldBe` [ Value 3 ] it "works for a pair of a single value and ()" $ run $ do ret <- select $ return (val (3 :: Int), ()) liftIO $ ret `shouldBe` [ (Value 3, ()) ] it "works for a single ()" $ run $ do ret <- select $ return () liftIO $ ret `shouldBe` [ () ] it "works for a single NULL value" $ run $ do ret <- select $ return nothing liftIO $ ret `shouldBe` [ Value (Nothing :: Maybe Int) ] testSubSelect :: Run -> Spec testSubSelect run = do let setup :: MonadIO m => SqlPersistT m () setup = do _ <- insert $ Numbers 1 2 _ <- insert $ Numbers 2 4 _ <- insert $ Numbers 3 5 _ <- insert $ Numbers 6 7 pure () describe "subSelect" $ do it "is safe for queries that may return multiple results" $ do let query = from $ \n -> do orderBy [asc (n ^. NumbersInt)] pure (n ^. NumbersInt) res <- run $ do setup select $ pure $ subSelect query res `shouldBe` [Value (Just 1)] eres <- try $ run $ do setup select $ pure $ sub_select query case eres of Left (SomeException _) -> -- We should receive an exception, but the different database -- libraries throw different exceptions. Hooray. pure () Right v -> -- This shouldn't happen, but in sqlite land, many things are -- possible. v `shouldBe` [Value 1] it "is safe for queries that may not return anything" $ do let query = from $ \n -> do orderBy [asc (n ^. NumbersInt)] limit 1 pure (n ^. NumbersInt) res <- run $ select $ pure $ subSelect query res `shouldBe` [Value Nothing] eres <- try $ run $ do setup select $ pure $ sub_select query case eres of Left (_ :: PersistException) -> -- We expect to receive this exception. However, sqlite evidently has -- no problems with it, so we can't *require* that the exception is -- thrown. Sigh. pure () Right v -> -- This shouldn't happen, but in sqlite land, many things are -- possible. v `shouldBe` [Value 1] describe "subSelectList" $ do it "is safe on empty databases as well as good databases" $ do let query = from $ \n -> do where_ $ n ^. NumbersInt `in_` do subSelectList $ from $ \n' -> do where_ $ n' ^. NumbersInt >=. val 3 pure (n' ^. NumbersInt) pure n empty <- run $ do select query full <- run $ do setup select query empty `shouldBe` [] full `shouldSatisfy` (not . null) describe "subSelectMaybe" $ do it "is equivalent to joinV . subSelect" $ do let query :: ( SqlQuery (SqlExpr (Value (Maybe Int))) -> SqlExpr (Value (Maybe Int)) ) -> SqlQuery (SqlExpr (Value (Maybe Int))) query selector = from $ \n -> do pure $ selector $ from $ \n' -> do where_ $ n' ^. NumbersDouble >=. n ^. NumbersDouble pure (max_ (n' ^. NumbersInt)) a <- run $ do setup select (query subSelectMaybe) b <- run $ do setup select (query (joinV . subSelect)) a `shouldBe` b describe "subSelectCount" $ do it "is a safe way to do a countRows" $ do xs0 <- run $ do setup select $ from $ \n -> do pure $ (,) n $ subSelectCount @Int $ from $ \n' -> do where_ $ n' ^. NumbersInt >=. n ^. NumbersInt xs1 <- run $ do setup select $ from $ \n -> do pure $ (,) n $ subSelectUnsafe $ from $ \n' -> do where_ $ n' ^. NumbersInt >=. n ^. NumbersInt pure (countRows :: SqlExpr (Value Int)) let getter (Entity _ a, b) = (a, b) map getter xs0 `shouldBe` map getter xs1 describe "subSelectUnsafe" $ do it "throws exceptions on multiple results" $ do eres <- try $ run $ do setup bad <- select $ from $ \n -> do pure $ (,) (n ^. NumbersInt) $ subSelectUnsafe $ from $ \n' -> do pure (just (n' ^. NumbersDouble)) good <- select $ from $ \n -> do pure $ (,) (n ^. NumbersInt) $ subSelect $ from $ \n' -> do pure (n' ^. NumbersDouble) pure (bad, good) case eres of Left (SomeException _) -> -- Must use SomeException because the database libraries throw their -- own errors. pure () Right (bad, good) -> do -- SQLite just takes the first element of the sub-select. lol. -- bad `shouldBe` good it "throws exceptions on null results" $ do eres <- try $ run $ do setup select $ from $ \n -> do pure $ (,) (n ^. NumbersInt) $ subSelectUnsafe $ from $ \n' -> do where_ $ val False pure (n' ^. NumbersDouble) case eres of Left (_ :: PersistException) -> pure () Right xs -> xs `shouldBe` [] testSelectSource :: Run -> Spec testSelectSource run = do describe "selectSource" $ do it "works for a simple example" $ run $ do let query = selectSource $ from $ \person -> return person p1e <- insert' p1 ret <- runConduit $ query .| CL.consume liftIO $ ret `shouldBe` [ p1e ] it "can run a query many times" $ run $ do let query = selectSource $ from $ \person -> return person p1e <- insert' p1 ret0 <- runConduit $ query .| CL.consume ret1 <- runConduit $ query .| CL.consume liftIO $ ret0 `shouldBe` [ p1e ] liftIO $ ret1 `shouldBe` [ p1e ] it "works on repro" $ do let selectPerson :: R.MonadResource m => String -> ConduitT () (Key Person) (SqlPersistT m) () selectPerson name = do let source = selectSource $ from $ \person -> do where_ $ person ^. PersonName ==. val name return $ person ^. PersonId source .| CL.map unValue run $ do p1e <- insert' p1 p2e <- insert' p2 r1 <- runConduit $ selectPerson (personName p1) .| CL.consume r2 <- runConduit $ selectPerson (personName p2) .| CL.consume liftIO $ do r1 `shouldBe` [ entityKey p1e ] r2 `shouldBe` [ entityKey p2e ] testSelectFrom :: Run -> Spec testSelectFrom run = do describe "select/from" $ do it "works for a simple example" $ run $ do p1e <- insert' p1 ret <- select $ from $ \person -> return person liftIO $ ret `shouldBe` [ p1e ] it "works for a simple self-join (one entity)" $ run $ do p1e <- insert' p1 ret <- select $ from $ \(person1, person2) -> return (person1, person2) liftIO $ ret `shouldBe` [ (p1e, p1e) ] it "works for a simple self-join (two entities)" $ run $ do p1e <- insert' p1 p2e <- insert' p2 ret <- select $ from $ \(person1, person2) -> return (person1, person2) liftIO $ ret `shouldSatisfy` sameElementsAs [ (p1e, p1e) , (p1e, p2e) , (p2e, p1e) , (p2e, p2e) ] it "works for a self-join via sub_select" $ run $ do p1k <- insert p1 p2k <- insert p2 _f1k <- insert (Follow p1k p2k) _f2k <- insert (Follow p2k p1k) ret <- select $ from $ \followA -> do let subquery = from $ \followB -> do where_ $ followA ^. FollowFollower ==. followB ^. FollowFollowed return $ followB ^. FollowFollower where_ $ followA ^. FollowFollowed ==. sub_select subquery return followA liftIO $ length ret `shouldBe` 2 it "works for a self-join via exists" $ run $ do p1k <- insert p1 p2k <- insert p2 _f1k <- insert (Follow p1k p2k) _f2k <- insert (Follow p2k p1k) ret <- select $ from $ \followA -> do where_ $ exists $ from $ \followB -> where_ $ followA ^. FollowFollower ==. followB ^. FollowFollowed return followA liftIO $ length ret `shouldBe` 2 it "works for a simple projection" $ run $ do p1k <- insert p1 p2k <- insert p2 ret <- select $ from $ \p -> return (p ^. PersonId, p ^. PersonName) liftIO $ ret `shouldBe` [ (Value p1k, Value (personName p1)) , (Value p2k, Value (personName p2)) ] it "works for a simple projection with a simple implicit self-join" $ run $ do _ <- insert p1 _ <- insert p2 ret <- select $ from $ \(pa, pb) -> return (pa ^. PersonName, pb ^. PersonName) liftIO $ ret `shouldSatisfy` sameElementsAs [ (Value (personName p1), Value (personName p1)) , (Value (personName p1), Value (personName p2)) , (Value (personName p2), Value (personName p1)) , (Value (personName p2), Value (personName p2)) ] it "works with many kinds of LIMITs and OFFSETs" $ run $ do [p1e, p2e, p3e, p4e] <- mapM insert' [p1, p2, p3, p4] let people = from $ \p -> do orderBy [asc (p ^. PersonName)] return p ret1 <- select $ do p <- people limit 2 limit 1 return p liftIO $ ret1 `shouldBe` [ p1e ] ret2 <- select $ do p <- people limit 1 limit 2 return p liftIO $ ret2 `shouldBe` [ p1e, p4e ] ret3 <- select $ do p <- people offset 3 offset 2 return p liftIO $ ret3 `shouldBe` [ p3e, p2e ] ret4 <- select $ do p <- people offset 3 limit 5 offset 2 limit 3 offset 1 limit 2 return p liftIO $ ret4 `shouldBe` [ p4e, p3e ] ret5 <- select $ do p <- people offset 1000 limit 1 limit 1000 offset 0 return p liftIO $ ret5 `shouldBe` [ p1e, p4e, p3e, p2e ] it "works with non-id primary key" $ run $ do let fc = Frontcover number "" number = 101 Right thePk = keyFromValues [toPersistValue number] fcPk <- insert fc [Entity _ ret] <- select $ from return liftIO $ do ret `shouldBe` fc fcPk `shouldBe` thePk it "works when returning a custom non-composite primary key from a query" $ run $ do let name = "foo" t = Tag name Right thePk = keyFromValues [toPersistValue name] tagPk <- insert t [Value ret] <- select $ from $ \t' -> return (t'^.TagId) liftIO $ do ret `shouldBe` thePk thePk `shouldBe` tagPk it "works when returning a composite primary key from a query" $ run $ do let p = Point 10 20 "" thePk <- insert p [Value ppk] <- select $ from $ \p' -> return (p'^.PointId) liftIO $ ppk `shouldBe` thePk testSelectJoin :: Run -> Spec testSelectJoin run = do describe "select:JOIN" $ do it "works with a LEFT OUTER JOIN" $ run $ do p1e <- insert' p1 p2e <- insert' p2 p3e <- insert' p3 p4e <- insert' p4 b12e <- insert' $ BlogPost "b" (entityKey p1e) b11e <- insert' $ BlogPost "a" (entityKey p1e) b31e <- insert' $ BlogPost "c" (entityKey p3e) ret <- select $ from $ \(p `LeftOuterJoin` mb) -> do on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId) orderBy [ asc (p ^. PersonName), asc (mb ?. BlogPostTitle) ] return (p, mb) liftIO $ ret `shouldBe` [ (p1e, Just b11e) , (p1e, Just b12e) , (p4e, Nothing) , (p3e, Just b31e) , (p2e, Nothing) ] it "typechecks (A LEFT OUTER JOIN (B LEFT OUTER JOIN C))" $ let _ = run $ select $ from $ \(a `LeftOuterJoin` (b `LeftOuterJoin` c)) -> let _ = [a, b, c] :: [ SqlExpr (Entity Person) ] in return a in return () :: IO () it "typechecks ((A LEFT OUTER JOIN B) LEFT OUTER JOIN C)" $ let _ = run $ select $ from $ \((a `LeftOuterJoin` b) `LeftOuterJoin` c) -> let _ = [a, b, c] :: [ SqlExpr (Entity Person) ] in return a in return () :: IO () it "throws an error for using on without joins" $ run (select $ from $ \(p, mb) -> do on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId) orderBy [ asc (p ^. PersonName), asc (mb ?. BlogPostTitle) ] return (p, mb) ) `shouldThrow` (\(OnClauseWithoutMatchingJoinException _) -> True) it "throws an error for using too many ons" $ run (select $ from $ \(p `FullOuterJoin` mb) -> do on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId) on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId) orderBy [ asc (p ^. PersonName), asc (mb ?. BlogPostTitle) ] return (p, mb) ) `shouldThrow` (\(OnClauseWithoutMatchingJoinException _) -> True) it "works with ForeignKey to a non-id primary key returning one entity" $ run $ do let fc = Frontcover number "" article = Article "Esqueleto supports composite pks!" number number = 101 Right thePk = keyFromValues [toPersistValue number] fcPk <- insert fc insert_ article [Entity _ retFc] <- select $ from $ \(a `InnerJoin` f) -> do on (f^.FrontcoverNumber ==. a^.ArticleFrontcoverNumber) return f liftIO $ do retFc `shouldBe` fc fcPk `shouldBe` thePk it "allows using a primary key that is itself a key of another table" $ run $ do let number = 101 insert_ $ Frontcover number "" articleId <- insert $ Article "title" number articleMetaE <- insert' (ArticleMetadata articleId) result <- select . from $ \articleMetadata -> do where_ $ (articleMetadata ^. ArticleMetadataId) ==. (val ((ArticleMetadataKey articleId))) pure articleMetadata liftIO $ [articleMetaE] `shouldBe` result it "allows joining between a primary key that is itself a key of another table, using ToBaseId" $ do run $ do let number = 101 insert_ $ Frontcover number "" articleE@(Entity articleId _) <- insert' $ Article "title" number articleMetaE <- insert' (ArticleMetadata articleId) articlesAndMetadata <- select $ from $ \(article `InnerJoin` articleMetadata) -> do on (toBaseId (articleMetadata ^. ArticleMetadataId) ==. article ^. ArticleId) return (article, articleMetadata) liftIO $ [(articleE, articleMetaE)] `shouldBe` articlesAndMetadata it "works with a ForeignKey to a non-id primary key returning both entities" $ run $ do let fc = Frontcover number "" article = Article "Esqueleto supports composite pks!" number number = 101 Right thePk = keyFromValues [toPersistValue number] fcPk <- insert fc insert_ article [(Entity _ retFc, Entity _ retArt)] <- select $ from $ \(a `InnerJoin` f) -> do on (f^.FrontcoverNumber ==. a^.ArticleFrontcoverNumber) return (f, a) liftIO $ do retFc `shouldBe` fc retArt `shouldBe` article fcPk `shouldBe` thePk articleFkfrontcover retArt `shouldBe` thePk it "works with a non-id primary key returning one entity" $ run $ do let fc = Frontcover number "" article = Article2 "Esqueleto supports composite pks!" thePk number = 101 Right thePk = keyFromValues [toPersistValue number] fcPk <- insert fc insert_ article [Entity _ retFc] <- select $ from $ \(a `InnerJoin` f) -> do on (f^.FrontcoverId ==. a^.Article2FrontcoverId) return f liftIO $ do retFc `shouldBe` fc fcPk `shouldBe` thePk it "works with a composite primary key" $ pendingWith "Persistent does not create the CircleFkPoint constructor. See: https://github.com/yesodweb/persistent/issues/341" {- run $ do let p = Point x y "" c = Circle x y "" x = 10 y = 15 Right thePk = keyFromValues [toPersistValue x, toPersistValue y] pPk <- insert p insert_ c [Entity _ ret] <- select $ from $ \(c' `InnerJoin` p') -> do on (p'^.PointId ==. c'^.CircleFkpoint) return p' liftIO $ do ret `shouldBe` p pPk `shouldBe` thePk -} it "works when joining via a non-id primary key" $ run $ do let fc = Frontcover number "" article = Article "Esqueleto supports composite pks!" number tag = Tag "foo" otherTag = Tag "ignored" number = 101 insert_ fc insert_ otherTag artId <- insert article tagId <- insert tag insert_ $ ArticleTag artId tagId [(Entity _ retArt, Entity _ retTag)] <- select $ from $ \(a `InnerJoin` at `InnerJoin` t) -> do on (t^.TagId ==. at^.ArticleTagTagId) on (a^.ArticleId ==. at^.ArticleTagArticleId) return (a, t) liftIO $ do retArt `shouldBe` article retTag `shouldBe` tag it "respects the associativity of joins" $ run $ do void $ insert p1 ps <- select . from $ \((p :: SqlExpr (Entity Person)) `LeftOuterJoin` ((_q :: SqlExpr (Entity Person)) `InnerJoin` (_r :: SqlExpr (Entity Person)))) -> do on (val False) -- Inner join is empty on (val True) return p liftIO $ (entityVal <$> ps) `shouldBe` [p1] testSelectSubQuery :: Run -> Spec testSelectSubQuery run = do describe "select subquery" $ do it "works" $ do run $ do _ <- insert' p1 let q = do p <- Experimental.from $ Table @Person return ( p ^. PersonName, p ^. PersonAge) ret <- select $ Experimental.from $ SelectQuery q liftIO $ ret `shouldBe` [ (Value $ personName p1, Value $ personAge p1) ] it "lets you order by alias" $ do run $ do _ <- insert' p1 _ <- insert' p3 let q = do (name, age) <- Experimental.from $ SubQuery $ do p <- Experimental.from $ Table @Person return ( p ^. PersonName, p ^. PersonAge) orderBy [ asc age ] pure name ret <- select q liftIO $ ret `shouldBe` [ Value $ personName p3, Value $ personName p1 ] it "supports groupBy" $ do run $ do l1k <- insert l1 l3k <- insert l3 mapM_ (\k -> insert $ Deed k l1k) (map show [1..3 :: Int]) mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int]) let q = do (lord :& deed) <- Experimental.from $ Table @Lord `InnerJoin` Table @Deed `Experimental.on` (\(lord :& deed) -> lord ^. LordId ==. deed ^. DeedOwnerId) return (lord ^. LordId, deed ^. DeedId) q' = do (lordId, deedId) <- Experimental.from $ SubQuery q groupBy (lordId) return (lordId, count deedId) (ret :: [(Value (Key Lord), Value Int)]) <- select q' liftIO $ ret `shouldMatchList` [ (Value l3k, Value 7) , (Value l1k, Value 3) ] it "Can count results of aggregate query" $ do run $ do l1k <- insert l1 l3k <- insert l3 mapM_ (\k -> insert $ Deed k l1k) (map show [1..3 :: Int]) mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int]) let q = do (lord :& deed) <- Experimental.from $ Table @Lord `InnerJoin` Table @Deed `Experimental.on` (\(lord :& deed) -> lord ^. LordId ==. deed ^. DeedOwnerId) groupBy (lord ^. LordId) return (lord ^. LordId, count (deed ^. DeedId)) (ret :: [(Value Int)]) <- select $ do (lordId, deedCount) <- Experimental.from $ SubQuery q where_ $ deedCount >. val (3 :: Int) return (count lordId) liftIO $ ret `shouldMatchList` [ (Value 1) ] it "joins on subqueries" $ do run $ do l1k <- insert l1 l3k <- insert l3 mapM_ (\k -> insert $ Deed k l1k) (map show [1..3 :: Int]) mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int]) let q = do (lord :& deed) <- Experimental.from $ Table @Lord `InnerJoin` (SelectQuery $ Experimental.from $ Table @Deed) `Experimental.on` (\(lord :& deed) -> lord ^. LordId ==. deed ^. DeedOwnerId) groupBy (lord ^. LordId) return (lord ^. LordId, count (deed ^. DeedId)) (ret :: [(Value (Key Lord), Value Int)]) <- select q liftIO $ ret `shouldMatchList` [ (Value l3k, Value 7) , (Value l1k, Value 3) ] it "flattens maybe values" $ do run $ do l1k <- insert l1 l3k <- insert l3 let q = do (lord :& (_, dogCounts)) <- Experimental.from $ Table @Lord `LeftOuterJoin` (SelectQuery $ do lord <- Experimental.from $ Table @Lord pure (lord ^. LordId, lord ^. LordDogs) ) `Experimental.on` (\(lord :& (lordId, _)) -> just (lord ^. LordId) ==. lordId) groupBy (lord ^. LordId, dogCounts) return (lord ^. LordId, dogCounts) (ret :: [(Value (Key Lord), Value (Maybe Int))]) <- select q liftIO $ ret `shouldMatchList` [ (Value l3k, Value (lordDogs l3)) , (Value l1k, Value (lordDogs l1)) ] it "unions" $ do run $ do _ <- insert p1 _ <- insert p2 let q = Experimental.from $ (SelectQuery $ do p <- Experimental.from $ Table @Person where_ $ not_ $ isNothing $ p ^. PersonAge return (p ^. PersonName)) `Union` (SelectQuery $ do p <- Experimental.from $ Table @Person where_ $ isNothing $ p ^. PersonAge return (p ^. PersonName)) `Union` (SelectQuery $ do p <- Experimental.from $ Table @Person where_ $ isNothing $ p ^. PersonAge return (p ^. PersonName)) names <- select q liftIO $ names `shouldMatchList` [ (Value $ personName p1) , (Value $ personName p2) ] testSelectWhere :: Run -> Spec testSelectWhere run = do describe "select where_" $ do it "works for a simple example with (==.)" $ run $ do p1e <- insert' p1 _ <- insert' p2 _ <- insert' p3 ret <- select $ from $ \p -> do where_ (p ^. PersonName ==. val "John") return p liftIO $ ret `shouldBe` [ p1e ] it "works for a simple example with (==.) and (||.)" $ run $ do p1e <- insert' p1 p2e <- insert' p2 _ <- insert' p3 ret <- select $ from $ \p -> do where_ (p ^. PersonName ==. val "John" ||. p ^. PersonName ==. val "Rachel") return p liftIO $ ret `shouldBe` [ p1e, p2e ] it "works for a simple example with (>.) [uses val . Just]" $ run $ do p1e <- insert' p1 _ <- insert' p2 _ <- insert' p3 ret <- select $ from $ \p -> do where_ (p ^. PersonAge >. val (Just 17)) return p liftIO $ ret `shouldBe` [ p1e ] it "works for a simple example with (>.) and not_ [uses just . val]" $ run $ do _ <- insert' p1 _ <- insert' p2 p3e <- insert' p3 ret <- select $ from $ \p -> do where_ (not_ $ p ^. PersonAge >. just (val 17)) return p liftIO $ ret `shouldBe` [ p3e ] describe "when using between" $ do it "works for a simple example with [uses just . val]" $ run $ do p1e <- insert' p1 _ <- insert' p2 _ <- insert' p3 ret <- select $ from $ \p -> do where_ ((p ^. PersonAge) `between` (just $ val 20, just $ val 40)) return p liftIO $ ret `shouldBe` [ p1e ] it "works for a proyected fields value" $ run $ do _ <- insert' p1 >> insert' p2 >> insert' p3 ret <- select $ from $ \p -> do where_ $ just (p ^. PersonFavNum) `between` (p ^. PersonAge, p ^. PersonWeight) liftIO $ ret `shouldBe` [] describe "when projecting composite keys" $ do it "works when using composite keys with val" $ run $ do insert_ $ Point 1 2 "" ret <- select $ from $ \p -> do where_ $ p ^. PointId `between` ( val $ PointKey 1 2 , val $ PointKey 5 6 ) liftIO $ ret `shouldBe` [()] it "works when using ECompositeKey constructor" $ run $ do insert_ $ Point 1 2 "" ret <- select $ from $ \p -> do where_ $ p ^. PointId `between` ( EI.ECompositeKey $ const ["3", "4"] , EI.ECompositeKey $ const ["5", "6"] ) liftIO $ ret `shouldBe` [] it "works with avg_" $ run $ do _ <- insert' p1 _ <- insert' p2 _ <- insert' p3 _ <- insert' p4 ret <- select $ from $ \p-> return $ joinV $ avg_ (p ^. PersonAge) let testV :: Double testV = roundTo (4 :: Integer) $ (36 + 17 + 17) / (3 :: Double) retV :: [Value (Maybe Double)] retV = map (Value . fmap (roundTo (4 :: Integer)) . unValue) (ret :: [Value (Maybe Double)]) liftIO $ retV `shouldBe` [ Value $ Just testV ] it "works with min_" $ run $ do _ <- insert' p1 _ <- insert' p2 _ <- insert' p3 _ <- insert' p4 ret <- select $ from $ \p-> return $ joinV $ min_ (p ^. PersonAge) liftIO $ ret `shouldBe` [ Value $ Just (17 :: Int) ] it "works with max_" $ run $ do _ <- insert' p1 _ <- insert' p2 _ <- insert' p3 _ <- insert' p4 ret <- select $ from $ \p-> return $ joinV $ max_ (p ^. PersonAge) liftIO $ ret `shouldBe` [ Value $ Just (36 :: Int) ] it "works with lower_" $ run $ do p1e <- insert' p1 p2e@(Entity _ bob) <- insert' $ Person "bob" (Just 36) Nothing 1 -- lower(name) == 'john' ret1 <- select $ from $ \p-> do where_ (lower_ (p ^. PersonName) ==. val (map toLower $ personName p1)) return p liftIO $ ret1 `shouldBe` [ p1e ] -- name == lower('BOB') ret2 <- select $ from $ \p-> do where_ (p ^. PersonName ==. lower_ (val $ map toUpper $ personName bob)) return p liftIO $ ret2 `shouldBe` [ p2e ] it "works with round_" $ run $ do ret <- select $ return $ round_ (val (16.2 :: Double)) liftIO $ ret `shouldBe` [ Value (16 :: Double) ] it "works with isNothing" $ run $ do _ <- insert' p1 p2e <- insert' p2 _ <- insert' p3 ret <- select $ from $ \p -> do where_ $ isNothing (p ^. PersonAge) return p liftIO $ ret `shouldBe` [ p2e ] it "works with not_ . isNothing" $ run $ do p1e <- insert' p1 _ <- insert' p2 ret <- select $ from $ \p -> do where_ $ not_ (isNothing (p ^. PersonAge)) return p liftIO $ ret `shouldBe` [ p1e ] it "works for a many-to-many implicit join" $ run $ do p1e@(Entity p1k _) <- insert' p1 p2e@(Entity p2k _) <- insert' p2 _ <- insert' p3 p4e@(Entity p4k _) <- insert' p4 f12 <- insert' (Follow p1k p2k) f21 <- insert' (Follow p2k p1k) f42 <- insert' (Follow p4k p2k) f11 <- insert' (Follow p1k p1k) ret <- select $ from $ \(follower, follows, followed) -> do where_ $ follower ^. PersonId ==. follows ^. FollowFollower &&. followed ^. PersonId ==. follows ^. FollowFollowed orderBy [ asc (follower ^. PersonName) , asc (followed ^. PersonName) ] return (follower, follows, followed) liftIO $ ret `shouldBe` [ (p1e, f11, p1e) , (p1e, f12, p2e) , (p4e, f42, p2e) , (p2e, f21, p1e) ] it "works for a many-to-many explicit join" $ run $ do p1e@(Entity p1k _) <- insert' p1 p2e@(Entity p2k _) <- insert' p2 _ <- insert' p3 p4e@(Entity p4k _) <- insert' p4 f12 <- insert' (Follow p1k p2k) f21 <- insert' (Follow p2k p1k) f42 <- insert' (Follow p4k p2k) f11 <- insert' (Follow p1k p1k) ret <- select $ from $ \(follower `InnerJoin` follows `InnerJoin` followed) -> do on $ followed ^. PersonId ==. follows ^. FollowFollowed on $ follower ^. PersonId ==. follows ^. FollowFollower orderBy [ asc (follower ^. PersonName) , asc (followed ^. PersonName) ] return (follower, follows, followed) liftIO $ ret `shouldBe` [ (p1e, f11, p1e) , (p1e, f12, p2e) , (p4e, f42, p2e) , (p2e, f21, p1e) ] it "works for a many-to-many explicit join and on order doesn't matter" $ do run $ void $ selectRethrowingQuery $ from $ \(person `InnerJoin` blog `InnerJoin` comment) -> do on $ person ^. PersonId ==. blog ^. BlogPostAuthorId on $ blog ^. BlogPostId ==. comment ^. CommentBlog pure (person, comment) -- we only care that we don't have a SQL error True `shouldBe` True it "works for a many-to-many explicit join with LEFT OUTER JOINs" $ run $ do p1e@(Entity p1k _) <- insert' p1 p2e@(Entity p2k _) <- insert' p2 p3e <- insert' p3 p4e@(Entity p4k _) <- insert' p4 f12 <- insert' (Follow p1k p2k) f21 <- insert' (Follow p2k p1k) f42 <- insert' (Follow p4k p2k) f11 <- insert' (Follow p1k p1k) ret <- select $ from $ \(follower `LeftOuterJoin` mfollows `LeftOuterJoin` mfollowed) -> do on $ mfollowed ?. PersonId ==. mfollows ?. FollowFollowed on $ just (follower ^. PersonId) ==. mfollows ?. FollowFollower orderBy [ asc ( follower ^. PersonName) , asc (mfollowed ?. PersonName) ] return (follower, mfollows, mfollowed) liftIO $ ret `shouldBe` [ (p1e, Just f11, Just p1e) , (p1e, Just f12, Just p2e) , (p4e, Just f42, Just p2e) , (p3e, Nothing, Nothing) , (p2e, Just f21, Just p1e) ] it "works with a composite primary key" $ run $ do let p = Point x y "" x = 10 y = 15 Right thePk = keyFromValues [toPersistValue x, toPersistValue y] pPk <- insert p [Entity _ ret] <- select $ from $ \p' -> do where_ (p'^.PointId ==. val pPk) return p' liftIO $ do ret `shouldBe` p pPk `shouldBe` thePk testSelectOrderBy :: Run -> Spec testSelectOrderBy run = do describe "select/orderBy" $ do it "works with a single ASC field" $ run $ do p1e <- insert' p1 p2e <- insert' p2 p3e <- insert' p3 ret <- select $ from $ \p -> do orderBy [asc $ p ^. PersonName] return p liftIO $ ret `shouldBe` [ p1e, p3e, p2e ] it "works with a sub_select" $ run $ do [p1k, p2k, p3k, p4k] <- mapM insert [p1, p2, p3, p4] [b1k, b2k, b3k, b4k] <- mapM (insert . BlogPost "") [p1k, p2k, p3k, p4k] ret <- select $ from $ \b -> do orderBy [desc $ sub_select $ from $ \p -> do where_ (p ^. PersonId ==. b ^. BlogPostAuthorId) return (p ^. PersonName) ] return (b ^. BlogPostId) liftIO $ ret `shouldBe` (Value <$> [b2k, b3k, b4k, b1k]) it "works on a composite primary key" $ run $ do let ps = [Point 2 1 "", Point 1 2 ""] mapM_ insert ps eps <- select $ from $ \p' -> do orderBy [asc (p'^.PointId)] return p' liftIO $ map entityVal eps `shouldBe` reverse ps testAscRandom :: SqlExpr (Value Double) -> Run -> Spec testAscRandom rand' run = describe "random_" $ it "asc random_ works" $ run $ do _p1e <- insert' p1 _p2e <- insert' p2 _p3e <- insert' p3 _p4e <- insert' p4 rets <- fmap S.fromList $ replicateM 11 $ select $ from $ \p -> do orderBy [asc (rand' :: SqlExpr (Value Double))] return (p ^. PersonId :: SqlExpr (Value PersonId)) -- There are 2^4 = 16 possible orderings. The chance -- of 11 random samplings returning the same ordering -- is 1/2^40, so this test should pass almost everytime. liftIO $ S.size rets `shouldSatisfy` (>2) testSelectDistinct :: Run -> Spec testSelectDistinct run = do describe "SELECT DISTINCT" $ do let selDistTest :: ( forall m. RunDbMonad m => SqlQuery (SqlExpr (Value String)) -> SqlPersistT (R.ResourceT m) [Value String]) -> IO () selDistTest q = run $ do p1k <- insert p1 let (t1, t2, t3) = ("a", "b", "c") mapM_ (insert . flip BlogPost p1k) [t1, t3, t2, t2, t1] ret <- q $ from $ \b -> do let title = b ^. BlogPostTitle orderBy [asc title] return title liftIO $ ret `shouldBe` [ Value t1, Value t2, Value t3 ] it "works on a simple example (select . distinct)" $ selDistTest (select . distinct) it "works on a simple example (distinct (return ()))" $ selDistTest (\act -> select $ distinct (return ()) >> act) testCoasleceDefault :: Run -> Spec testCoasleceDefault run = do describe "coalesce/coalesceDefault" $ do it "works on a simple example" $ run $ do mapM_ insert' [p1, p2, p3, p4, p5] ret1 <- select $ from $ \p -> do orderBy [asc (p ^. PersonId)] return (coalesce [p ^. PersonAge, p ^. PersonWeight]) liftIO $ ret1 `shouldBe` [ Value (Just (36 :: Int)) , Value (Just 37) , Value (Just 17) , Value (Just 17) , Value Nothing ] ret2 <- select $ from $ \p -> do orderBy [asc (p ^. PersonId)] return (coalesceDefault [p ^. PersonAge, p ^. PersonWeight] (p ^. PersonFavNum)) liftIO $ ret2 `shouldBe` [ Value (36 :: Int) , Value 37 , Value 17 , Value 17 , Value 5 ] it "works with sub-queries" $ run $ do p1id <- insert p1 p2id <- insert p2 p3id <- insert p3 _ <- insert p4 _ <- insert p5 _ <- insert $ BlogPost "a" p1id _ <- insert $ BlogPost "b" p2id _ <- insert $ BlogPost "c" p3id ret <- select $ from $ \b -> do let sub = from $ \p -> do where_ (p ^. PersonId ==. b ^. BlogPostAuthorId) return $ p ^. PersonAge return $ coalesceDefault [sub_select sub] (val (42 :: Int)) liftIO $ ret `shouldBe` [ Value (36 :: Int) , Value 42 , Value 17 ] testDelete :: Run -> Spec testDelete run = do describe "delete" $ it "works on a simple example" $ run $ do p1e <- insert' p1 p2e <- insert' p2 p3e <- insert' p3 let getAll = select $ from $ \p -> do orderBy [asc (p ^. PersonName)] return p ret1 <- getAll liftIO $ ret1 `shouldBe` [ p1e, p3e, p2e ] () <- delete $ from $ \p -> where_ (p ^. PersonName ==. val (personName p1)) ret2 <- getAll liftIO $ ret2 `shouldBe` [ p3e, p2e ] n <- deleteCount $ from $ \p -> return ((p :: SqlExpr (Entity Person)) `seq` ()) ret3 <- getAll liftIO $ (n, ret3) `shouldBe` (2, []) testUpdate :: Run -> Spec testUpdate run = do describe "update" $ do it "works with a subexpression having COUNT(*)" $ run $ do p1k <- insert p1 p2k <- insert p2 p3k <- insert p3 replicateM_ 3 (insert $ BlogPost "" p1k) replicateM_ 7 (insert $ BlogPost "" p3k) let blogPostsBy p = from $ \b -> do where_ (b ^. BlogPostAuthorId ==. p ^. PersonId) return countRows () <- update $ \p -> do set p [ PersonAge =. just (sub_select (blogPostsBy p)) ] ret <- select $ from $ \p -> do orderBy [ asc (p ^. PersonName) ] return p liftIO $ ret `shouldBe` [ Entity p1k p1 { personAge = Just 3 } , Entity p3k p3 { personAge = Just 7 } , Entity p2k p2 { personAge = Just 0 } ] it "works with a composite primary key" $ pendingWith "Need refactor to support composite pks on ESet" {- run $ do let p = Point x y "" x = 10 y = 15 newX = 20 newY = 25 Right newPk = keyFromValues [toPersistValue newX, toPersistValue newY] insert_ p () <- update $ \p' -> do set p' [PointId =. val newPk] [Entity _ ret] <- select $ from $ return liftIO $ do ret `shouldBe` Point newX newY [] -} it "GROUP BY works with COUNT" $ run $ do p1k <- insert p1 p2k <- insert p2 p3k <- insert p3 replicateM_ 3 (insert $ BlogPost "" p1k) replicateM_ 7 (insert $ BlogPost "" p3k) ret <- select $ from $ \(p `LeftOuterJoin` b) -> do on (p ^. PersonId ==. b ^. BlogPostAuthorId) groupBy (p ^. PersonId) let cnt = count (b ^. BlogPostId) orderBy [ asc cnt ] return (p, cnt) liftIO $ ret `shouldBe` [ (Entity p2k p2, Value (0 :: Int)) , (Entity p1k p1, Value 3) , (Entity p3k p3, Value 7) ] it "GROUP BY works with COUNT and InnerJoin" $ run $ do l1k <- insert l1 l3k <- insert l3 mapM_ (\k -> insert $ Deed k l1k) (map show [1..3 :: Int]) mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int]) (ret :: [(Value (Key Lord), Value Int)]) <- select $ from $ \ ( lord `InnerJoin` deed ) -> do on $ lord ^. LordId ==. deed ^. DeedOwnerId groupBy (lord ^. LordId) return (lord ^. LordId, count $ deed ^. DeedId) liftIO $ ret `shouldMatchList` [ (Value l3k, Value 7) , (Value l1k, Value 3) ] it "GROUP BY works with nested tuples" $ do run $ do l1k <- insert l1 l3k <- insert l3 mapM_ (\k -> insert $ Deed k l1k) (map show [1..3 :: Int]) mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int]) (ret :: [(Value (Key Lord), Value Int)]) <- select $ from $ \ ( lord `InnerJoin` deed ) -> do on $ lord ^. LordId ==. deed ^. DeedOwnerId groupBy ((lord ^. LordId, lord ^. LordDogs), deed ^. DeedContract) return (lord ^. LordId, count $ deed ^. DeedId) liftIO $ length ret `shouldBe` 10 it "GROUP BY works with HAVING" $ run $ do p1k <- insert p1 _p2k <- insert p2 p3k <- insert p3 replicateM_ 3 (insert $ BlogPost "" p1k) replicateM_ 7 (insert $ BlogPost "" p3k) ret <- select $ from $ \(p `LeftOuterJoin` b) -> do on (p ^. PersonId ==. b ^. BlogPostAuthorId) let cnt = count (b ^. BlogPostId) groupBy (p ^. PersonId) having (cnt >. (val 0)) orderBy [ asc cnt ] return (p, cnt) liftIO $ ret `shouldBe` [ (Entity p1k p1, Value (3 :: Int)) , (Entity p3k p3, Value 7) ] -- we only care that this compiles. check that SqlWriteT doesn't fail on -- updates. testSqlWriteT :: MonadIO m => SqlWriteT m () testSqlWriteT = update $ \p -> do set p [ PersonAge =. just (val 6) ] -- we only care that this compiles. checks that the SqlWriteT monad can run -- select queries. testSqlWriteTRead :: MonadIO m => SqlWriteT m [(Value (Key Lord), Value Int)] testSqlWriteTRead = select $ from $ \ ( lord `InnerJoin` deed ) -> do on $ lord ^. LordId ==. deed ^. DeedOwnerId groupBy (lord ^. LordId) return (lord ^. LordId, count $ deed ^. DeedId) -- we only care that this compiles checks that SqlReadT allows testSqlReadT :: MonadIO m => SqlReadT m [(Value (Key Lord), Value Int)] testSqlReadT = select $ from $ \ ( lord `InnerJoin` deed ) -> do on $ lord ^. LordId ==. deed ^. DeedOwnerId groupBy (lord ^. LordId) return (lord ^. LordId, count $ deed ^. DeedId) testListOfValues :: Run -> Spec testListOfValues run = do describe "lists of values" $ do it "IN works for valList" $ run $ do p1k <- insert p1 p2k <- insert p2 _p3k <- insert p3 ret <- select $ from $ \p -> do where_ (p ^. PersonName `in_` valList (personName <$> [p1, p2])) return p liftIO $ ret `shouldBe` [ Entity p1k p1 , Entity p2k p2 ] it "IN works for valList (null list)" $ run $ do _p1k <- insert p1 _p2k <- insert p2 _p3k <- insert p3 ret <- select $ from $ \p -> do where_ (p ^. PersonName `in_` valList []) return p liftIO $ ret `shouldBe` [] it "IN works for subList_select" $ run $ do p1k <- insert p1 _p2k <- insert p2 p3k <- insert p3 _ <- insert (BlogPost "" p1k) _ <- insert (BlogPost "" p3k) ret <- select $ from $ \p -> do let subquery = from $ \bp -> do orderBy [ asc (bp ^. BlogPostAuthorId) ] return (bp ^. BlogPostAuthorId) where_ (p ^. PersonId `in_` subList_select subquery) return p liftIO $ L.sort ret `shouldBe` L.sort [Entity p1k p1, Entity p3k p3] it "NOT IN works for subList_select" $ run $ do p1k <- insert p1 p2k <- insert p2 p3k <- insert p3 _ <- insert (BlogPost "" p1k) _ <- insert (BlogPost "" p3k) ret <- select $ from $ \p -> do let subquery = from $ \bp -> return (bp ^. BlogPostAuthorId) where_ (p ^. PersonId `notIn` subList_select subquery) return p liftIO $ ret `shouldBe` [ Entity p2k p2 ] it "EXISTS works for subList_select" $ run $ do p1k <- insert p1 _p2k <- insert p2 p3k <- insert p3 _ <- insert (BlogPost "" p1k) _ <- insert (BlogPost "" p3k) ret <- select $ from $ \p -> do where_ $ exists $ from $ \bp -> do where_ (bp ^. BlogPostAuthorId ==. p ^. PersonId) orderBy [asc (p ^. PersonName)] return p liftIO $ ret `shouldBe` [ Entity p1k p1 , Entity p3k p3 ] it "EXISTS works for subList_select" $ run $ do p1k <- insert p1 p2k <- insert p2 p3k <- insert p3 _ <- insert (BlogPost "" p1k) _ <- insert (BlogPost "" p3k) ret <- select $ from $ \p -> do where_ $ notExists $ from $ \bp -> do where_ (bp ^. BlogPostAuthorId ==. p ^. PersonId) return p liftIO $ ret `shouldBe` [ Entity p2k p2 ] testListFields :: Run -> Spec testListFields run = do describe "list fields" $ do -- it "can update list fields" $ run $ do cclist <- insert $ CcList [] update $ \p -> do set p [ CcListNames =. val ["fred"]] where_ (p ^. CcListId ==. val cclist) testInsertsBySelect :: Run -> Spec testInsertsBySelect run = do describe "inserts by select" $ do it "IN works for insertSelect" $ run $ do _ <- insert p1 _ <- insert p2 _ <- insert p3 insertSelect $ from $ \p -> do return $ BlogPost <# val "FakePost" <&> (p ^. PersonId) ret <- select $ from (\(_::(SqlExpr (Entity BlogPost))) -> return countRows) liftIO $ ret `shouldBe` [Value (3::Int)] testInsertsBySelectReturnsCount :: Run -> Spec testInsertsBySelectReturnsCount run = do describe "inserts by select, returns count" $ do it "IN works for insertSelectCount" $ run $ do _ <- insert p1 _ <- insert p2 _ <- insert p3 cnt <- insertSelectCount $ from $ \p -> do return $ BlogPost <# val "FakePost" <&> (p ^. PersonId) ret <- select $ from (\(_::(SqlExpr (Entity BlogPost))) -> return countRows) liftIO $ ret `shouldBe` [Value (3::Int)] liftIO $ cnt `shouldBe` 3 testRandomMath :: Run -> Spec testRandomMath run = describe "random_ math" $ it "rand returns result in random order" $ run $ do replicateM_ 20 $ do _ <- insert p1 _ <- insert p2 _ <- insert p3 _ <- insert p4 _ <- insert $ Person "Jane" Nothing Nothing 0 _ <- insert $ Person "Mark" Nothing Nothing 0 _ <- insert $ Person "Sarah" Nothing Nothing 0 insert $ Person "Paul" Nothing Nothing 0 ret1 <- fmap (map unValue) $ select $ from $ \p -> do orderBy [rand] return (p ^. PersonId) ret2 <- fmap (map unValue) $ select $ from $ \p -> do orderBy [rand] return (p ^. PersonId) liftIO $ (ret1 == ret2) `shouldBe` False testMathFunctions :: Run -> Spec testMathFunctions run = do describe "Math-related functions" $ do it "castNum works for multiplying Int and Double" $ run $ do mapM_ insert [Numbers 2 3.4, Numbers 7 1.1] ret <- select $ from $ \n -> do let r = castNum (n ^. NumbersInt) *. n ^. NumbersDouble orderBy [asc r] return r liftIO $ length ret `shouldBe` 2 let [Value a, Value b] = ret liftIO $ max (abs (a - 6.8)) (abs (b - 7.7)) `shouldSatisfy` (< 0.01) testCase :: Run -> Spec testCase run = do describe "case" $ do it "Works for a simple value based when - False" $ run $ do ret <- select $ return $ case_ [ when_ (val False) then_ (val (1 :: Int)) ] (else_ (val 2)) liftIO $ ret `shouldBe` [ Value 2 ] it "Works for a simple value based when - True" $ run $ do ret <- select $ return $ case_ [ when_ (val True) then_ (val (1 :: Int)) ] (else_ (val 2)) liftIO $ ret `shouldBe` [ Value 1 ] it "works for a semi-complicated query" $ run $ do _ <- insert p1 _ <- insert p2 _ <- insert p3 _ <- insert p4 _ <- insert p5 ret <- select $ return $ case_ [ when_ (exists $ from $ \p -> do where_ (p ^. PersonName ==. val "Mike")) then_ (sub_select $ from $ \v -> do let sub = from $ \c -> do where_ (c ^. PersonName ==. val "Mike") return (c ^. PersonFavNum) where_ (v ^. PersonFavNum >. sub_select sub) return $ count (v ^. PersonName) +. val (1 :: Int)) ] (else_ $ val (-1)) liftIO $ ret `shouldBe` [ Value (3) ] testLocking :: WithConn (NoLoggingT IO) [TL.Text] -> Spec testLocking withConn = do describe "locking" $ do -- The locking clause is the last one, so try to use many -- others to test if it's at the right position. We don't -- care about the text of the rest, nor with the RDBMS' -- reaction to the clause. let sanityCheck kind syntax = do let complexQuery = from $ \(p1' `InnerJoin` p2') -> do on (p1' ^. PersonName ==. p2' ^. PersonName) where_ (p1' ^. PersonFavNum >. val 2) orderBy [desc (p2' ^. PersonAge)] limit 3 offset 9 groupBy (p1' ^. PersonId) having (countRows <. val (0 :: Int)) return (p1', p2') queryWithClause1 = do r <- complexQuery locking kind return r queryWithClause2 = do locking ForUpdate r <- complexQuery locking ForShare locking kind return r queryWithClause3 = do locking kind complexQuery toText conn q = let (tlb, _) = EI.toRawSql EI.SELECT (conn, EI.initialIdentState) q in TLB.toLazyText tlb [complex, with1, with2, with3] <- runNoLoggingT $ withConn $ \conn -> return $ map (toText conn) [complexQuery, queryWithClause1, queryWithClause2, queryWithClause3] let expected = complex <> "\n" <> syntax (with1, with2, with3) `shouldBe` (expected, expected, expected) it "looks sane for ForUpdate" $ sanityCheck ForUpdate "FOR UPDATE" it "looks sane for ForUpdateSkipLocked" $ sanityCheck ForUpdateSkipLocked "FOR UPDATE SKIP LOCKED" it "looks sane for ForShare" $ sanityCheck ForShare "FOR SHARE" it "looks sane for LockInShareMode" $ sanityCheck LockInShareMode "LOCK IN SHARE MODE" testCountingRows :: Run -> Spec testCountingRows run = do describe "counting rows" $ do forM_ [ ("count (test A)", count . (^. PersonAge), 4) , ("count (test B)", count . (^. PersonWeight), 5) , ("countRows", const countRows, 5) , ("countDistinct", countDistinct . (^. PersonAge), 2) ] $ \(title, countKind, expected) -> it (title ++ " works as expected") $ run $ do mapM_ insert [ Person "" (Just 1) (Just 1) 1 , Person "" (Just 2) (Just 1) 1 , Person "" (Just 2) (Just 1) 1 , Person "" (Just 2) (Just 2) 1 , Person "" Nothing (Just 3) 1] [Value n] <- select $ from $ return . countKind liftIO $ (n :: Int) `shouldBe` expected testRenderSql :: Run -> Spec testRenderSql run = do describe "testRenderSql" $ do it "works" $ do (queryText, queryVals) <- run $ renderQuerySelect $ from $ \p -> do where_ $ p ^. PersonName ==. val "Johhny Depp" pure (p ^. PersonName, p ^. PersonAge) -- the different backends use different quote marks, so I filter them out -- here instead of making a duplicate test Text.filter (\c -> c `notElem` ['`', '"']) queryText `shouldBe` Text.unlines [ "SELECT Person.name, Person.age" , "FROM Person" , "WHERE Person.name = ?" ] queryVals `shouldBe` [toPersistValue ("Johhny Depp" :: TL.Text)] describe "renderExpr" $ do it "renders a value" $ do (c, expr) <- run $ do conn <- ask let Right c = P.mkEscapeChar conn pure $ (,) c $ EI.renderExpr conn $ EI.EEntity (EI.I "user") ^. PersonId ==. EI.EEntity (EI.I "blog_post") ^. BlogPostAuthorId expr `shouldBe` Text.intercalate (Text.singleton c) ["", "user", ".", "id", ""] <> " = " <> Text.intercalate (Text.singleton c) ["", "blog_post", ".", "authorId", ""] it "renders ? for a val" $ do expr <- run $ ask >>= \c -> pure $ EI.renderExpr c (val (PersonKey 0) ==. val (PersonKey 1)) expr `shouldBe` "? = ?" describe "EEntity Ident behavior" $ do let render :: SqlExpr (Entity val) -> Text.Text render (EI.EEntity (EI.I ident)) = ident it "renders sensibly" $ do results <- run $ do _ <- insert $ Foo 2 _ <- insert $ Foo 3 _ <- insert $ Person "hello" Nothing Nothing 3 select $ from $ \(a `LeftOuterJoin` b) -> do on $ a ^. FooName ==. b ^. PersonFavNum pure (val (render a), val (render b)) head results `shouldBe` (Value "Foo", Value "Person") describe "ExprParser" $ do let parse parser = AP.parseOnly (parser '#') describe "parseEscapedChars" $ do let subject = parse P.parseEscapedChars it "parses words" $ do subject "hello world" `shouldBe` Right "hello world" it "only returns a single escape-char if present" $ do subject "i_am##identifier##" `shouldBe` Right "i_am#identifier#" describe "parseEscapedIdentifier" $ do let subject = parse P.parseEscapedIdentifier it "parses the quotes out" $ do subject "#it's a me, mario#" `shouldBe` Right "it's a me, mario" it "requires a beginning and end quote" $ do subject "#alas, i have no end" `shouldSatisfy` isLeft describe "parseTableAccess" $ do let subject = parse P.parseTableAccess it "parses a table access" $ do subject "#foo#.#bar#" `shouldBe` Right P.TableAccess { P.tableAccessTable = "foo" , P.tableAccessColumn = "bar" } describe "onExpr" $ do let subject = parse P.onExpr it "works" $ do subject "#foo#.#bar# = #bar#.#baz#" `shouldBe` do Right $ S.fromList [ P.TableAccess { P.tableAccessTable = "foo" , P.tableAccessColumn = "bar" } , P.TableAccess { P.tableAccessTable = "bar" , P.tableAccessColumn = "baz" } ] it "also works with other nonsense" $ do subject "#foo#.#bar# = 3" `shouldBe` do Right $ S.fromList [ P.TableAccess { P.tableAccessTable = "foo" , P.tableAccessColumn = "bar" } ] it "handles a conjunction" $ do subject "#foo#.#bar# = #bar#.#baz# AND #bar#.#baz# > 10" `shouldBe` do Right $ S.fromList [ P.TableAccess { P.tableAccessTable = "foo" , P.tableAccessColumn = "bar" } , P.TableAccess { P.tableAccessTable = "bar" , P.tableAccessColumn = "baz" } ] it "handles ? okay" $ do subject "#foo#.#bar# = ?" `shouldBe` do Right $ S.fromList [ P.TableAccess { P.tableAccessTable = "foo" , P.tableAccessColumn = "bar" } ] it "handles degenerate cases" $ do subject "false" `shouldBe` pure mempty subject "true" `shouldBe` pure mempty subject "1 = 1" `shouldBe` pure mempty it "works even if an identifier isn't first" $ do subject "true and #foo#.#bar# = 2" `shouldBe` do Right $ S.fromList [ P.TableAccess { P.tableAccessTable = "foo" , P.tableAccessColumn = "bar" } ] testOnClauseOrder :: Run -> Spec testOnClauseOrder run = describe "On Clause Ordering" $ do let setup :: MonadIO m => SqlPersistT m () setup = do ja1 <- insert (JoinOne "j1 hello") ja2 <- insert (JoinOne "j1 world") jb1 <- insert (JoinTwo ja1 "j2 hello") jb2 <- insert (JoinTwo ja1 "j2 world") jb3 <- insert (JoinTwo ja2 "j2 foo") _ <- insert (JoinTwo ja2 "j2 bar") jc1 <- insert (JoinThree jb1 "j3 hello") jc2 <- insert (JoinThree jb1 "j3 world") _ <- insert (JoinThree jb2 "j3 foo") _ <- insert (JoinThree jb3 "j3 bar") _ <- insert (JoinThree jb3 "j3 baz") _ <- insert (JoinFour "j4 foo" jc1) _ <- insert (JoinFour "j4 bar" jc2) jd1 <- insert (JoinOther "foo") jd2 <- insert (JoinOther "bar") _ <- insert (JoinMany "jm foo hello" jd1 ja1) _ <- insert (JoinMany "jm foo world" jd1 ja2) _ <- insert (JoinMany "jm bar hello" jd2 ja1) _ <- insert (JoinMany "jm bar world" jd2 ja2) pure () describe "identical results for" $ do it "three tables" $ do abcs <- run $ do setup select $ from $ \(a `InnerJoin` b `InnerJoin` c) -> do on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) pure (a, b, c) acbs <- run $ do setup select $ from $ \(a `InnerJoin` b `InnerJoin` c) -> do on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) pure (a, b, c) listsEqualOn abcs acbs $ \(Entity _ j1, Entity _ j2, Entity _ j3) -> (joinOneName j1, joinTwoName j2, joinThreeName j3) it "four tables" $ do xs0 <- run $ do setup select $ from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) pure (a, b, c, d) xs1 <- run $ do setup select $ from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) pure (a, b, c, d) xs2 <- run $ do setup select $ from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) pure (a, b, c, d) xs3 <- run $ do setup select $ from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) pure (a, b, c, d) xs4 <- run $ do setup select $ from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) pure (a, b, c, d) let getNames (j1, j2, j3, j4) = ( joinOneName (entityVal j1) , joinTwoName (entityVal j2) , joinThreeName (entityVal j3) , joinFourName (entityVal j4) ) listsEqualOn xs0 xs1 getNames listsEqualOn xs0 xs2 getNames listsEqualOn xs0 xs3 getNames listsEqualOn xs0 xs4 getNames it "associativity of innerjoin" $ do xs0 <- run $ do setup select $ from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) pure (a, b, c, d) xs1 <- run $ do setup select $ from $ \(a `InnerJoin` b `InnerJoin` (c `InnerJoin` d)) -> do on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) pure (a, b, c, d) xs2 <- run $ do setup select $ from $ \(a `InnerJoin` (b `InnerJoin` c) `InnerJoin` d) -> do on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) pure (a, b, c, d) xs3 <- run $ do setup select $ from $ \(a `InnerJoin` (b `InnerJoin` c `InnerJoin` d)) -> do on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) pure (a, b, c, d) let getNames (j1, j2, j3, j4) = ( joinOneName (entityVal j1) , joinTwoName (entityVal j2) , joinThreeName (entityVal j3) , joinFourName (entityVal j4) ) listsEqualOn xs0 xs1 getNames listsEqualOn xs0 xs2 getNames listsEqualOn xs0 xs3 getNames it "inner join on two entities" $ do (xs0, xs1) <- run $ do pid <- insert $ Person "hello" Nothing Nothing 3 _ <- insert $ BlogPost "good poast" pid _ <- insert $ Profile "cool" pid xs0 <- selectRethrowingQuery $ from $ \(p `InnerJoin` b `InnerJoin` pr) -> do on $ p ^. PersonId ==. b ^. BlogPostAuthorId on $ p ^. PersonId ==. pr ^. ProfilePerson pure (p, b, pr) xs1 <- selectRethrowingQuery $ from $ \(p `InnerJoin` b `InnerJoin` pr) -> do on $ p ^. PersonId ==. pr ^. ProfilePerson on $ p ^. PersonId ==. b ^. BlogPostAuthorId pure (p, b, pr) pure (xs0, xs1) listsEqualOn xs0 xs1 $ \(Entity _ p, Entity _ b, Entity _ pr) -> (personName p, blogPostTitle b, profileName pr) it "inner join on three entities" $ do res <- run $ do pid <- insert $ Person "hello" Nothing Nothing 3 _ <- insert $ BlogPost "good poast" pid _ <- insert $ BlogPost "good poast #2" pid _ <- insert $ Profile "cool" pid _ <- insert $ Reply pid "u wot m8" _ <- insert $ Reply pid "how dare you" bprr <- selectRethrowingQuery $ from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do on $ p ^. PersonId ==. b ^. BlogPostAuthorId on $ p ^. PersonId ==. pr ^. ProfilePerson on $ p ^. PersonId ==. r ^. ReplyGuy pure (p, b, pr, r) brpr <- selectRethrowingQuery $ from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do on $ p ^. PersonId ==. b ^. BlogPostAuthorId on $ p ^. PersonId ==. r ^. ReplyGuy on $ p ^. PersonId ==. pr ^. ProfilePerson pure (p, b, pr, r) prbr <- selectRethrowingQuery $ from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do on $ p ^. PersonId ==. pr ^. ProfilePerson on $ p ^. PersonId ==. b ^. BlogPostAuthorId on $ p ^. PersonId ==. r ^. ReplyGuy pure (p, b, pr, r) prrb <- selectRethrowingQuery $ from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do on $ p ^. PersonId ==. pr ^. ProfilePerson on $ p ^. PersonId ==. r ^. ReplyGuy on $ p ^. PersonId ==. b ^. BlogPostAuthorId pure (p, b, pr, r) rprb <- selectRethrowingQuery $ from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do on $ p ^. PersonId ==. r ^. ReplyGuy on $ p ^. PersonId ==. pr ^. ProfilePerson on $ p ^. PersonId ==. b ^. BlogPostAuthorId pure (p, b, pr, r) rbpr <- selectRethrowingQuery $ from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do on $ p ^. PersonId ==. r ^. ReplyGuy on $ p ^. PersonId ==. b ^. BlogPostAuthorId on $ p ^. PersonId ==. pr ^. ProfilePerson pure (p, b, pr, r) pure [bprr, brpr, prbr, prrb, rprb, rbpr] forM_ (zip res (drop 1 (cycle res))) $ \(a, b) -> a `shouldBe` b it "many-to-many" $ do ac <- run $ do setup select $ from $ \(a `InnerJoin` b `InnerJoin` c) -> do on (a ^. JoinOneId ==. b ^. JoinManyJoinOne) on (c ^. JoinOtherId ==. b ^. JoinManyJoinOther) pure (a, c) ca <- run $ do setup select $ from $ \(a `InnerJoin` b `InnerJoin` c) -> do on (c ^. JoinOtherId ==. b ^. JoinManyJoinOther) on (a ^. JoinOneId ==. b ^. JoinManyJoinOne) pure (a, c) listsEqualOn ac ca $ \(Entity _ a, Entity _ b) -> (joinOneName a, joinOtherName b) it "left joins on order" $ do ca <- run $ do setup select $ from $ \(a `LeftOuterJoin` b `InnerJoin` c) -> do on (c ?. JoinOtherId ==. b ?. JoinManyJoinOther) on (just (a ^. JoinOneId) ==. b ?. JoinManyJoinOne) orderBy [asc $ a ^. JoinOneId, asc $ c ?. JoinOtherId] pure (a, c) ac <- run $ do setup select $ from $ \(a `LeftOuterJoin` b `InnerJoin` c) -> do on (just (a ^. JoinOneId) ==. b ?. JoinManyJoinOne) on (c ?. JoinOtherId ==. b ?. JoinManyJoinOther) orderBy [asc $ a ^. JoinOneId, asc $ c ?. JoinOtherId] pure (a, c) listsEqualOn ac ca $ \(Entity _ a, b) -> (joinOneName a, maybe "NULL" (joinOtherName . entityVal) b) it "doesn't require an on for a crossjoin" $ do void $ run $ select $ from $ \(a `CrossJoin` b) -> do pure (a :: SqlExpr (Entity JoinOne), b :: SqlExpr (Entity JoinTwo)) it "errors with an on for a crossjoin" $ do (void $ run $ select $ from $ \(a `CrossJoin` b) -> do on $ a ^. JoinOneId ==. b ^. JoinTwoJoinOne pure (a, b)) `shouldThrow` \(OnClauseWithoutMatchingJoinException _) -> True it "left joins associativity" $ do ca <- run $ do setup select $ from $ \(a `LeftOuterJoin` (b `InnerJoin` c)) -> do on (c ?. JoinOtherId ==. b ?. JoinManyJoinOther) on (just (a ^. JoinOneId) ==. b ?. JoinManyJoinOne) orderBy [asc $ a ^. JoinOneId, asc $ c ?. JoinOtherId] pure (a, c) ca' <- run $ do setup select $ from $ \(a `LeftOuterJoin` b `InnerJoin` c) -> do on (c ?. JoinOtherId ==. b ?. JoinManyJoinOther) on (just (a ^. JoinOneId) ==. b ?. JoinManyJoinOne) orderBy [asc $ a ^. JoinOneId, asc $ c ?. JoinOtherId] pure (a, c) listsEqualOn ca ca' $ \(Entity _ a, b) -> (joinOneName a, maybe "NULL" (joinOtherName . entityVal) b) it "composes queries still" $ do let query1 = from $ \(foo `InnerJoin` bar) -> do on (foo ^. FooId ==. bar ^. BarQuux) pure (foo, bar) query2 = from $ \(p `LeftOuterJoin` bp) -> do on (p ^. PersonId ==. bp ^. BlogPostAuthorId) pure (p, bp) (a, b) <- run $ do fid <- insert $ Foo 5 _ <- insert $ Bar fid pid <- insert $ Person "hey" Nothing Nothing 30 _ <- insert $ BlogPost "WHY" pid a <- select ((,) <$> query1 <*> query2) b <- select (flip (,) <$> query1 <*> query2) pure (a, b) listsEqualOn a (map (\(x, y) -> (y, x)) b) id it "works with joins in subselect" $ do run $ void $ select $ from $ \(p `InnerJoin` r) -> do on $ p ^. PersonId ==. r ^. ReplyGuy pure . (,) (p ^. PersonName) $ subSelect $ from $ \(c `InnerJoin` bp) -> do on $ bp ^. BlogPostId ==. c ^. CommentBlog pure (c ^. CommentBody) describe "works with nested joins" $ do it "unnested" $ do run $ void $ selectRethrowingQuery $ from $ \(f `InnerJoin` b `LeftOuterJoin` baz `InnerJoin` shoop) -> do on $ f ^. FooId ==. b ^. BarQuux on $ f ^. FooId ==. baz ^. BazBlargh on $ baz ^. BazId ==. shoop ^. ShoopBaz pure ( f ^. FooName) it "leftmost nesting" $ do run $ void $ selectRethrowingQuery $ from $ \((f `InnerJoin` b) `LeftOuterJoin` baz `InnerJoin` shoop) -> do on $ f ^. FooId ==. b ^. BarQuux on $ f ^. FooId ==. baz ^. BazBlargh on $ baz ^. BazId ==. shoop ^. ShoopBaz pure ( f ^. FooName) describe "middle nesting" $ do it "direct association" $ do run $ void $ selectRethrowingQuery $ from $ \(p `InnerJoin` (bp `LeftOuterJoin` c) `LeftOuterJoin` cr) -> do on $ p ^. PersonId ==. bp ^. BlogPostAuthorId on $ just (bp ^. BlogPostId) ==. c ?. CommentBlog on $ c ?. CommentId ==. cr ?. CommentReplyComment pure (p,bp,c,cr) it "indirect association" $ do run $ void $ selectRethrowingQuery $ from $ \(f `InnerJoin` b `LeftOuterJoin` (baz `InnerJoin` shoop) `InnerJoin` asdf) -> do on $ f ^. FooId ==. b ^. BarQuux on $ f ^. FooId ==. baz ^. BazBlargh on $ baz ^. BazId ==. shoop ^. ShoopBaz on $ asdf ^. AsdfShoop ==. shoop ^. ShoopId pure (f ^. FooName) it "indirect association across" $ do run $ void $ selectRethrowingQuery $ from $ \(f `InnerJoin` b `LeftOuterJoin` (baz `InnerJoin` shoop) `InnerJoin` asdf `InnerJoin` another `InnerJoin` yetAnother) -> do on $ f ^. FooId ==. b ^. BarQuux on $ f ^. FooId ==. baz ^. BazBlargh on $ baz ^. BazId ==. shoop ^. ShoopBaz on $ asdf ^. AsdfShoop ==. shoop ^. ShoopId on $ another ^. AnotherWhy ==. baz ^. BazId on $ yetAnother ^. YetAnotherArgh ==. shoop ^. ShoopId pure (f ^. FooName) describe "rightmost nesting" $ do it "direct associations" $ do run $ void $ selectRethrowingQuery $ from $ \(p `InnerJoin` bp `LeftOuterJoin` (c `LeftOuterJoin` cr)) -> do on $ p ^. PersonId ==. bp ^. BlogPostAuthorId on $ just (bp ^. BlogPostId) ==. c ?. CommentBlog on $ c ?. CommentId ==. cr ?. CommentReplyComment pure (p,bp,c,cr) it "indirect association" $ do run $ void $ selectRethrowingQuery $ from $ \(f `InnerJoin` b `LeftOuterJoin` (baz `InnerJoin` shoop)) -> do on $ f ^. FooId ==. b ^. BarQuux on $ f ^. FooId ==. baz ^. BazBlargh on $ baz ^. BazId ==. shoop ^. ShoopBaz pure (f ^. FooName) testExperimentalFrom :: Run -> Spec testExperimentalFrom run = do describe "Experimental From" $ do it "supports basic table queries" $ do run $ do p1e <- insert' p1 _ <- insert' p2 p3e <- insert' p3 peopleWithAges <- select $ do people <- Experimental.from $ Table @Person where_ $ not_ $ isNothing $ people ^. PersonAge return people liftIO $ peopleWithAges `shouldMatchList` [p1e, p3e] it "supports inner joins" $ do run $ do l1e <- insert' l1 _ <- insert l2 d1e <- insert' $ Deed "1" (entityKey l1e) d2e <- insert' $ Deed "2" (entityKey l1e) lordDeeds <- select $ do (lords :& deeds) <- Experimental.from $ Table @Lord `InnerJoin` Table @Deed `Experimental.on` (\(l :& d) -> l ^. LordId ==. d ^. DeedOwnerId) pure (lords, deeds) liftIO $ lordDeeds `shouldMatchList` [ (l1e, d1e) , (l1e, d2e) ] it "supports outer joins" $ do run $ do l1e <- insert' l1 l2e <- insert' l2 d1e <- insert' $ Deed "1" (entityKey l1e) d2e <- insert' $ Deed "2" (entityKey l1e) lordDeeds <- select $ do (lords :& deeds) <- Experimental.from $ Table @Lord `LeftOuterJoin` Table @Deed `Experimental.on` (\(l :& d) -> just (l ^. LordId) ==. d ?. DeedOwnerId) pure (lords, deeds) liftIO $ lordDeeds `shouldMatchList` [ (l1e, Just d1e) , (l1e, Just d2e) , (l2e, Nothing) ] it "supports delete" $ do run $ do insert_ l1 insert_ l2 insert_ l3 delete $ void $ Experimental.from $ Table @Lord lords <- select $ Experimental.from $ Table @Lord liftIO $ lords `shouldMatchList` [] it "supports implicit cross joins" $ do run $ do l1e <- insert' l1 l2e <- insert' l2 ret <- select $ do lords1 <- Experimental.from $ Table @Lord lords2 <- Experimental.from $ Table @Lord pure (lords1, lords2) ret2 <- select $ do (lords1 :& lords2) <- Experimental.from $ Table @Lord `CrossJoin` Table @Lord pure (lords1,lords2) liftIO $ ret `shouldMatchList` ret2 liftIO $ ret `shouldMatchList` [ (l1e, l1e) , (l1e, l2e) , (l2e, l1e) , (l2e, l2e) ] it "compiles" $ do run $ void $ do let q = do (persons :& profiles :& posts) <- Experimental.from $ Table @Person `InnerJoin` Table @Profile `Experimental.on` (\(people :& profiles) -> people ^. PersonId ==. profiles ^. ProfilePerson) `LeftOuterJoin` Table @BlogPost `Experimental.on` (\(people :& _ :& posts) -> just (people ^. PersonId) ==. posts ?. BlogPostAuthorId) pure (persons, posts, profiles) --error . show =<< renderQuerySelect q pure () it "can call functions on aliased values" $ do run $ do insert_ p1 insert_ p3 -- Pretend this isnt all posts upperNames <- select $ do author <- Experimental.from $ SelectQuery $ Experimental.from $ Table @Person pure $ upper_ $ author ^. PersonName liftIO $ upperNames `shouldMatchList` [ Value "JOHN" , Value "MIKE" ] listsEqualOn :: (Show a1, Eq a1) => [a2] -> [a2] -> (a2 -> a1) -> Expectation listsEqualOn a b f = map f a `shouldBe` map f b tests :: Run -> Spec tests run = do describe "Tests that are common to all backends" $ do testSelect run testSubSelect run testSelectSource run testSelectFrom run testSelectJoin run testSelectSubQuery run testSelectWhere run testSelectOrderBy run testSelectDistinct run testCoasleceDefault run testDelete run testUpdate run testListOfValues run testListFields run testInsertsBySelect run testMathFunctions run testCase run testCountingRows run testRenderSql run testOnClauseOrder run testExperimentalFrom run insert' :: ( Functor m , BaseBackend backend ~ PersistEntityBackend val , PersistStore backend , MonadIO m , PersistEntity val ) => val -> ReaderT backend m (Entity val) insert' v = flip Entity v <$> insert v type RunDbMonad m = ( MonadUnliftIO m , MonadIO m , MonadLogger m , MonadCatch m ) #if __GLASGOW_HASKELL__ >= 806 type Run = forall a. (forall m. (RunDbMonad m, MonadFail m) => SqlPersistT (R.ResourceT m) a) -> IO a #else type Run = forall a. (forall m. (RunDbMonad m) => SqlPersistT (R.ResourceT m) a) -> IO a #endif type WithConn m a = RunDbMonad m => (SqlBackend -> R.ResourceT m a) -> m a -- With SQLite and in-memory databases, a separate connection implies a -- separate database. With 'actual databases', the data is persistent and -- thus must be cleaned after each test. -- TODO: there is certainly a better way... cleanDB :: (forall m. RunDbMonad m => SqlPersistT (R.ResourceT m) ()) cleanDB = do delete $ from $ \(_ :: SqlExpr (Entity Bar)) -> return () delete $ from $ \(_ :: SqlExpr (Entity Foo)) -> return () delete $ from $ \(_ :: SqlExpr (Entity Reply)) -> return () delete $ from $ \(_ :: SqlExpr (Entity Comment)) -> return () delete $ from $ \(_ :: SqlExpr (Entity Profile)) -> return () delete $ from $ \(_ :: SqlExpr (Entity BlogPost)) -> return () delete $ from $ \(_ :: SqlExpr (Entity Follow)) -> return () delete $ from $ \(_ :: SqlExpr (Entity Person)) -> return () delete $ from $ \(_ :: SqlExpr (Entity Deed)) -> return () delete $ from $ \(_ :: SqlExpr (Entity Lord)) -> return () delete $ from $ \(_ :: SqlExpr (Entity CcList)) -> return () delete $ from $ \(_ :: SqlExpr (Entity ArticleTag)) -> return () delete $ from $ \(_ :: SqlExpr (Entity ArticleMetadata)) -> return () delete $ from $ \(_ :: SqlExpr (Entity Article)) -> return () delete $ from $ \(_ :: SqlExpr (Entity Article2)) -> return () delete $ from $ \(_ :: SqlExpr (Entity Tag)) -> return () delete $ from $ \(_ :: SqlExpr (Entity Frontcover)) -> return () delete $ from $ \(_ :: SqlExpr (Entity Circle)) -> return () delete $ from $ \(_ :: SqlExpr (Entity Point)) -> return () delete $ from $ \(_ :: SqlExpr (Entity Numbers)) -> return () delete $ from $ \(_ :: SqlExpr (Entity JoinMany)) -> return () delete $ from $ \(_ :: SqlExpr (Entity JoinFour)) -> return () delete $ from $ \(_ :: SqlExpr (Entity JoinThree)) -> return () delete $ from $ \(_ :: SqlExpr (Entity JoinTwo)) -> return () delete $ from $ \(_ :: SqlExpr (Entity JoinOne)) -> return () delete $ from $ \(_ :: SqlExpr (Entity JoinOther)) -> return () delete $ from $ \(_ :: SqlExpr (Entity DateTruncTest)) -> pure () cleanUniques :: (forall m. RunDbMonad m => SqlPersistT (R.ResourceT m) ()) cleanUniques = delete $ from $ \(_ :: SqlExpr (Entity OneUnique)) -> return () selectRethrowingQuery :: (MonadIO m, EI.SqlSelect a r, MonadUnliftIO m) => SqlQuery a -> SqlPersistT m [r] selectRethrowingQuery query = select query `catch` \(SomeException e) -> do (text, _) <- renderQuerySelect query liftIO . throwIO . userError $ Text.unpack text <> "\n\n" <> show e esqueleto-3.3.3.2/test/PostgreSQL/Test.hs0000644000000000000000000012666013640445040016324 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-unused-binds #-} {-# LANGUAGE FlexibleContexts , LambdaCase , NamedFieldPuns , OverloadedStrings , RankNTypes , ScopedTypeVariables , TypeApplications , TypeFamilies , PartialTypeSignatures #-} module Main (main) where import Data.Coerce import Data.Foldable import qualified Data.Map.Strict as Map import Data.Map (Map) import Data.Time import Control.Arrow ((&&&)) import Control.Monad (void, when) import Control.Monad.Catch (MonadCatch, catch) import Control.Monad.IO.Class (MonadIO(liftIO)) import Control.Monad.Logger (runStderrLoggingT, runNoLoggingT) import Control.Monad.Trans.Reader (ReaderT, ask) import qualified Control.Monad.Trans.Resource as R import Data.Aeson hiding (Value) import qualified Data.Aeson as A (Value) import Data.ByteString (ByteString) import qualified Data.Char as Char import qualified Data.List as L import Data.Ord (comparing) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import Data.Time.Clock (getCurrentTime, diffUTCTime, UTCTime) import Database.Esqueleto hiding (random_) import qualified Database.Esqueleto.Internal.Sql as ES import Database.Esqueleto.PostgreSQL (random_) import qualified Database.Esqueleto.PostgreSQL as EP import Database.Esqueleto.PostgreSQL.JSON hiding ((?.), (-.), (||.)) import qualified Database.Esqueleto.PostgreSQL.JSON as JSON import Database.Persist.Postgresql (withPostgresqlConn) import Database.PostgreSQL.Simple (SqlError(..), ExecStatus(..)) import System.Environment import Test.Hspec import Test.Hspec.QuickCheck import Common.Test import PostgreSQL.MigrateJSON testPostgresqlCoalesce :: Spec testPostgresqlCoalesce = do it "works on PostgreSQL and MySQL with <2 arguments" $ run $ do _ :: [Value (Maybe Int)] <- select $ from $ \p -> do return (coalesce [p ^. PersonAge]) return () nameContains :: (BaseBackend backend ~ SqlBackend, BackendCompatible SqlBackend backend, MonadIO m, SqlString s, IsPersistBackend backend, PersistQueryRead backend, PersistUniqueRead backend) => (SqlExpr (Value [Char]) -> SqlExpr (Value s) -> SqlExpr (Value Bool)) -> s -> [Entity Person] -> ReaderT backend m () nameContains f t expected = do ret <- select $ from $ \p -> do where_ (f (p ^. PersonName) ((%) ++. val t ++. (%))) orderBy [asc (p ^. PersonName)] return p liftIO $ ret `shouldBe` expected testPostgresqlTextFunctions :: Spec testPostgresqlTextFunctions = do describe "text functions" $ do it "like, (%) and (++.) work on a simple example" $ run $ do [p1e, p2e, p3e, p4e] <- mapM insert' [p1, p2, p3, p4] nameContains like "h" [p1e, p2e] nameContains like "i" [p4e, p3e] nameContains like "iv" [p4e] it "ilike, (%) and (++.) work on a simple example on PostgreSQL" $ run $ do [p1e, _, p3e, _, p5e] <- mapM insert' [p1, p2, p3, p4, p5] let nameContains' t expected = do ret <- select $ from $ \p -> do where_ (p ^. PersonName `ilike` (%) ++. val t ++. (%)) orderBy [asc (p ^. PersonName)] return p liftIO $ ret `shouldBe` expected nameContains' "mi" [p3e, p5e] nameContains' "JOHN" [p1e] testPostgresqlUpdate :: Spec testPostgresqlUpdate = do it "works on a simple example" $ run $ do p1k <- insert p1 p2k <- insert p2 p3k <- insert p3 let anon = "Anonymous" () <- update $ \p -> do set p [ PersonName =. val anon , PersonAge *=. just (val 2) ] where_ (p ^. PersonName !=. val "Mike") n <- updateCount $ \p -> do set p [ PersonAge +=. just (val 1) ] where_ (p ^. PersonName !=. val "Mike") ret <- select $ from $ \p -> do orderBy [ asc (p ^. PersonName), asc (p ^. PersonAge) ] return p -- PostgreSQL: nulls are bigger than data, and update returns -- matched rows, not actually changed rows. liftIO $ n `shouldBe` 2 liftIO $ ret `shouldBe` [ Entity p1k (Person anon (Just 73) Nothing 1) , Entity p2k (Person anon Nothing (Just 37) 2) , Entity p3k p3 ] testPostgresqlRandom :: Spec testPostgresqlRandom = do it "works with random_" $ run $ do _ <- select $ return (random_ :: SqlExpr (Value Double)) return () testPostgresqlSum :: Spec testPostgresqlSum = do it "works with sum_" $ run $ do _ <- insert' p1 _ <- insert' p2 _ <- insert' p3 _ <- insert' p4 ret <- select $ from $ \p-> return $ joinV $ sum_ (p ^. PersonAge) liftIO $ ret `shouldBe` [ Value $ Just (36 + 17 + 17 :: Rational ) ] testPostgresqlTwoAscFields :: Spec testPostgresqlTwoAscFields = do it "works with two ASC fields (one call)" $ run $ do p1e <- insert' p1 p2e <- insert' p2 p3e <- insert' p3 p4e <- insert' p4 ret <- select $ from $ \p -> do orderBy [asc (p ^. PersonAge), asc (p ^. PersonName)] return p -- in PostgreSQL nulls are bigger than everything liftIO $ ret `shouldBe` [ p4e, p3e, p1e , p2e ] testPostgresqlOneAscOneDesc :: Spec testPostgresqlOneAscOneDesc = do it "works with one ASC and one DESC field (two calls)" $ run $ do p1e <- insert' p1 p2e <- insert' p2 p3e <- insert' p3 p4e <- insert' p4 ret <- select $ from $ \p -> do orderBy [desc (p ^. PersonAge)] orderBy [asc (p ^. PersonName)] return p liftIO $ ret `shouldBe` [ p2e, p1e, p4e, p3e ] testSelectDistinctOn :: Spec testSelectDistinctOn = do describe "SELECT DISTINCT ON" $ do it "works on a simple example" $ do run $ do [p1k, p2k, _] <- mapM insert [p1, p2, p3] [_, bpB, bpC] <- mapM insert' [ BlogPost "A" p1k , BlogPost "B" p1k , BlogPost "C" p2k ] ret <- select $ from $ \bp -> distinctOn [don (bp ^. BlogPostAuthorId)] $ do orderBy [asc (bp ^. BlogPostAuthorId), desc (bp ^. BlogPostTitle)] return bp liftIO $ ret `shouldBe` L.sortBy (comparing (blogPostAuthorId . entityVal)) [bpB, bpC] let slightlyLessSimpleTest q = run $ do [p1k, p2k, _] <- mapM insert [p1, p2, p3] [bpA, bpB, bpC] <- mapM insert' [ BlogPost "A" p1k , BlogPost "B" p1k , BlogPost "C" p2k ] ret <- select $ from $ \bp -> q bp $ return bp let cmp = (blogPostAuthorId &&& blogPostTitle) . entityVal liftIO $ ret `shouldBe` L.sortBy (comparing cmp) [bpA, bpB, bpC] it "works on a slightly less simple example (two distinctOn calls, orderBy)" $ slightlyLessSimpleTest $ \bp act -> distinctOn [don (bp ^. BlogPostAuthorId)] $ distinctOn [don (bp ^. BlogPostTitle)] $ do orderBy [asc (bp ^. BlogPostAuthorId), asc (bp ^. BlogPostTitle)] act it "works on a slightly less simple example (one distinctOn call, orderBy)" $ do slightlyLessSimpleTest $ \bp act -> distinctOn [don (bp ^. BlogPostAuthorId), don (bp ^. BlogPostTitle)] $ do orderBy [asc (bp ^. BlogPostAuthorId), asc (bp ^. BlogPostTitle)] act it "works on a slightly less simple example (distinctOnOrderBy)" $ do slightlyLessSimpleTest $ \bp -> distinctOnOrderBy [asc (bp ^. BlogPostAuthorId), asc (bp ^. BlogPostTitle)] testArrayAggWith :: Spec testArrayAggWith = do describe "ALL, no ORDER BY" $ do it "creates sane SQL" $ run $ do (query, args) <- showQuery ES.SELECT $ from $ \p -> return (EP.arrayAggWith EP.AggModeAll (p ^. PersonAge) []) liftIO $ query `shouldBe` "SELECT array_agg(\"Person\".\"age\")\n\ \FROM \"Person\"\n" liftIO $ args `shouldBe` [] it "works on an example" $ run $ do let people = [p1, p2, p3, p4, p5] mapM_ insert people [Value (Just ret)] <- select . from $ \p -> return (EP.arrayAggWith EP.AggModeAll (p ^. PersonName) []) liftIO $ L.sort ret `shouldBe` L.sort (map personName people) describe "DISTINCT, no ORDER BY" $ do it "creates sane SQL" $ run $ do (query, args) <- showQuery ES.SELECT $ from $ \p -> return (EP.arrayAggWith EP.AggModeDistinct (p ^. PersonAge) []) liftIO $ query `shouldBe` "SELECT array_agg(DISTINCT \"Person\".\"age\")\n\ \FROM \"Person\"\n" liftIO $ args `shouldBe` [] it "works on an example" $ run $ do let people = [p1, p2, p3, p4, p5] mapM_ insert people [Value (Just ret)] <- select . from $ \p -> return (EP.arrayAggWith EP.AggModeDistinct (p ^. PersonAge) []) liftIO $ L.sort ret `shouldBe` [Nothing, Just 17, Just 36] describe "ALL, ORDER BY" $ do it "creates sane SQL" $ run $ do (query, args) <- showQuery ES.SELECT $ from $ \p -> return (EP.arrayAggWith EP.AggModeAll (p ^. PersonAge) [ asc $ p ^. PersonName , desc $ p ^. PersonFavNum ]) liftIO $ query `shouldBe` "SELECT array_agg(\"Person\".\"age\" \ \ORDER BY \"Person\".\"name\" ASC, \"Person\".\"favNum\" DESC)\n\ \FROM \"Person\"\n" liftIO $ args `shouldBe` [] it "works on an example" $ run $ do let people = [p1, p2, p3, p4, p5] mapM_ insert people [Value (Just ret)] <- select . from $ \p -> return (EP.arrayAggWith EP.AggModeAll (p ^. PersonName) []) liftIO $ L.sort ret `shouldBe` L.sort (map personName people) describe "DISTINCT, ORDER BY" $ do it "creates sane SQL" $ run $ do (query, args) <- showQuery ES.SELECT $ from $ \p -> return (EP.arrayAggWith EP.AggModeDistinct (p ^. PersonAge) [asc $ p ^. PersonAge]) liftIO $ query `shouldBe` "SELECT array_agg(DISTINCT \"Person\".\"age\" \ \ORDER BY \"Person\".\"age\" ASC)\n\ \FROM \"Person\"\n" liftIO $ args `shouldBe` [] it "works on an example" $ run $ do let people = [p1, p2, p3, p4, p5] mapM_ insert people [Value (Just ret)] <- select . from $ \p -> return (EP.arrayAggWith EP.AggModeDistinct (p ^. PersonAge) [asc $ p ^. PersonAge]) liftIO $ ret `shouldBe` [Just 17, Just 36, Nothing] testStringAggWith :: Spec testStringAggWith = do describe "ALL, no ORDER BY" $ do it "creates sane SQL" $ run $ do (query, args) <- showQuery ES.SELECT $ from $ \p -> return (EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ") []) liftIO $ query `shouldBe` "SELECT string_agg(\"Person\".\"name\", ?)\n\ \FROM \"Person\"\n" liftIO $ args `shouldBe` [PersistText " "] it "works on an example" $ run $ do let people = [p1, p2, p3, p4, p5] mapM_ insert people [Value (Just ret)] <- select . from $ \p -> return (EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ")[]) liftIO $ (L.sort $ words ret) `shouldBe` L.sort (map personName people) it "works with zero rows" $ run $ do [Value ret] <- select . from $ \p -> return (EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ")[]) liftIO $ ret `shouldBe` Nothing describe "DISTINCT, no ORDER BY" $ do it "creates sane SQL" $ run $ do (query, args) <- showQuery ES.SELECT $ from $ \p -> return $ EP.stringAggWith EP.AggModeDistinct (p ^. PersonName) (val " ") [] liftIO $ query `shouldBe` "SELECT string_agg(DISTINCT \"Person\".\"name\", ?)\n\ \FROM \"Person\"\n" liftIO $ args `shouldBe` [PersistText " "] it "works on an example" $ run $ do let people = [p1, p2, p3 {personName = "John"}, p4, p5] mapM_ insert people [Value (Just ret)] <- select . from $ \p -> return $ EP.stringAggWith EP.AggModeDistinct (p ^. PersonName) (val " ") [] liftIO $ (L.sort $ words ret) `shouldBe` (L.sort . L.nub $ map personName people) describe "ALL, ORDER BY" $ do it "creates sane SQL" $ run $ do (query, args) <- showQuery ES.SELECT $ from $ \p -> return (EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ") [ asc $ p ^. PersonName , desc $ p ^. PersonFavNum ]) liftIO $ query `shouldBe` "SELECT string_agg(\"Person\".\"name\", ? \ \ORDER BY \"Person\".\"name\" ASC, \"Person\".\"favNum\" DESC)\n\ \FROM \"Person\"\n" liftIO $ args `shouldBe` [PersistText " "] it "works on an example" $ run $ do let people = [p1, p2, p3, p4, p5] mapM_ insert people [Value (Just ret)] <- select . from $ \p -> return $ EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ") [desc $ p ^. PersonName] liftIO $ (words ret) `shouldBe` (L.reverse . L.sort $ map personName people) describe "DISTINCT, ORDER BY" $ do it "creates sane SQL" $ run $ do (query, args) <- showQuery ES.SELECT $ from $ \p -> return $ EP.stringAggWith EP.AggModeDistinct (p ^. PersonName) (val " ") [desc $ p ^. PersonName] liftIO $ query `shouldBe` "SELECT string_agg(DISTINCT \"Person\".\"name\", ? \ \ORDER BY \"Person\".\"name\" DESC)\n\ \FROM \"Person\"\n" liftIO $ args `shouldBe` [PersistText " "] it "works on an example" $ run $ do let people = [p1, p2, p3 {personName = "John"}, p4, p5] mapM_ insert people [Value (Just ret)] <- select . from $ \p -> return $ EP.stringAggWith EP.AggModeDistinct (p ^. PersonName) (val " ") [desc $ p ^. PersonName] liftIO $ (words ret) `shouldBe` (L.reverse . L.sort . L.nub $ map personName people) testAggregateFunctions :: Spec testAggregateFunctions = do describe "arrayAgg" $ do it "looks sane" $ run $ do let people = [p1, p2, p3, p4, p5] mapM_ insert people [Value (Just ret)] <- select . from $ \p -> return (EP.arrayAgg (p ^. PersonName)) liftIO $ L.sort ret `shouldBe` L.sort (map personName people) it "works on zero rows" $ run $ do [Value ret] <- select . from $ \p -> return (EP.arrayAgg (p ^. PersonName)) liftIO $ ret `shouldBe` Nothing describe "arrayAggWith" testArrayAggWith describe "stringAgg" $ do it "looks sane" $ run $ do let people = [p1, p2, p3, p4, p5] mapM_ insert people [Value (Just ret)] <- select $ from $ \p -> do return (EP.stringAgg (p ^. PersonName) (val " ")) liftIO $ L.sort (words ret) `shouldBe` L.sort (map personName people) it "works on zero rows" $ run $ do [Value ret] <- select . from $ \p -> return (EP.stringAgg (p ^. PersonName) (val " ")) liftIO $ ret `shouldBe` Nothing describe "stringAggWith" testStringAggWith describe "array_remove (NULL)" $ do it "removes NULL from arrays from nullable fields" $ run $ do mapM_ insert [ Person "1" Nothing Nothing 1 , Person "2" (Just 7) Nothing 1 , Person "3" (Nothing) Nothing 1 , Person "4" (Just 8) Nothing 2 , Person "5" (Just 9) Nothing 2 ] ret <- select . from $ \(person :: SqlExpr (Entity Person)) -> do groupBy (person ^. PersonFavNum) return . EP.arrayRemoveNull . EP.maybeArray . EP.arrayAgg $ person ^. PersonAge liftIO $ (L.sort $ map (L.sort . unValue) ret) `shouldBe` [[7], [8,9]] describe "maybeArray" $ do it "Coalesces NULL into an empty array" $ run $ do [Value ret] <- select . from $ \p -> return (EP.maybeArray $ EP.arrayAgg (p ^. PersonName)) liftIO $ ret `shouldBe` [] testPostgresModule :: Spec testPostgresModule = do describe "date_trunc" $ modifyMaxSuccess (`div` 10) $ do prop "works" $ \listOfDateParts -> run $ do let utcTimes = map (\(y, m, d, s) -> fromInteger s `addUTCTime` UTCTime (fromGregorian (2000 + y) m d) 0 ) listOfDateParts truncateDate :: SqlExpr (Value String) -- ^ .e.g (val "day") -> SqlExpr (Value UTCTime) -- ^ input field -> SqlExpr (Value UTCTime) -- ^ truncated date truncateDate datePart expr = ES.unsafeSqlFunction "date_trunc" (datePart, expr) vals = zip (map (DateTruncTestKey . fromInteger) [1..]) utcTimes for_ vals $ \(idx, utcTime) -> do insertKey idx (DateTruncTest utcTime) -- Necessary to get the test to pass; see the discussion in -- https://github.com/bitemyapp/esqueleto/pull/180 rawExecute "SET TIME ZONE 'UTC'" [] ret <- fmap (Map.fromList . coerce :: _ -> Map DateTruncTestId (UTCTime, UTCTime)) $ select $ from $ \dt -> do pure ( dt ^. DateTruncTestId , ( dt ^. DateTruncTestCreated , truncateDate (val "day") (dt ^. DateTruncTestCreated) ) ) liftIO $ for_ vals $ \(idx, utcTime) -> do case Map.lookup idx ret of Nothing -> expectationFailure "index not found" Just (original, truncated) -> do utcTime `shouldBe` original if utctDay utcTime == utctDay truncated then utctDay utcTime `shouldBe` utctDay truncated else -- use this if/else to get a better error message utcTime `shouldBe` truncated describe "PostgreSQL module" $ do describe "Aggregate functions" testAggregateFunctions it "chr looks sane" $ run $ do [Value (ret :: String)] <- select $ return (EP.chr (val 65)) liftIO $ ret `shouldBe` "A" it "allows unit for functions" $ do vals <- run $ do let fn :: SqlExpr (Value UTCTime) fn = ES.unsafeSqlFunction "now" () select $ pure fn vals `shouldSatisfy` ((1 ==) . length) it "works with now" $ run $ do nowDb <- select $ return EP.now_ nowUtc <- liftIO getCurrentTime let halfSecond = realToFrac (0.5 :: Double) -- | Check the result is not null liftIO $ nowDb `shouldSatisfy` (not . null) -- | Unpack the now value let (Value now: _) = nowDb -- | Get the time diff and check it's less than half a second liftIO $ diffUTCTime nowUtc now `shouldSatisfy` (< halfSecond) --------------- JSON --------------- JSON --------------- JSON --------------- --------------- JSON --------------- JSON --------------- JSON --------------- --------------- JSON --------------- JSON --------------- JSON --------------- testJSONInsertions :: Spec testJSONInsertions = describe "JSON Insertions" $ do it "adds scalar values" $ do run $ do insertIt Null insertIt $ Bool True insertIt $ Number 1 insertIt $ String "test" it "adds arrays" $ do run $ do insertIt $ toJSON ([] :: [A.Value]) insertIt $ toJSON [Number 1, Bool True, Null] insertIt $ toJSON [String "test",object ["a" .= Number 3.14], Null, Bool True] it "adds objects" $ do run $ do insertIt $ object ["a" .= (1 :: Int), "b" .= False] insertIt $ object ["a" .= object ["b" .= object ["c" .= String "message"]]] where insertIt :: MonadIO m => A.Value -> SqlPersistT m () insertIt = insert_ . Json . JSONB testJSONOperators :: Spec testJSONOperators = describe "JSON Operators" $ do testArrowOperators testFilterOperators testConcatDeleteOperators testArrowOperators :: Spec testArrowOperators = describe "Arrow Operators" $ do testArrowJSONB testArrowText testHashArrowJSONB testHashArrowText testArrowJSONB :: Spec testArrowJSONB = describe "Single Arrow (JSONB)" $ do it "creates sane SQL" $ createSaneSQL @JSONValue (jsonbVal (object ["a" .= True]) ->. "a") "SELECT (? -> ?)\nFROM \"Json\"\n" [ PersistDbSpecific "{\"a\":true}" , PersistText "a" ] it "creates sane SQL (chained)" $ do let obj = object ["a" .= [1 :: Int,2,3]] createSaneSQL @JSONValue (jsonbVal obj ->. "a" ->. 1) "SELECT ((? -> ?) -> ?)\nFROM \"Json\"\n" [ PersistDbSpecific "{\"a\":[1,2,3]}" , PersistText "a" , PersistInt64 1 ] it "works as expected" $ run $ do x <- selectJSONwhere $ \v -> v ->. "b" ==. jsonbVal (Bool False) y <- selectJSONwhere $ \v -> v ->. 1 ==. jsonbVal (Bool True) z <- selectJSONwhere $ \v -> v ->. "a" ->. "b" ->. "c" ==. jsonbVal (String "message") liftIO $ length x `shouldBe` 1 liftIO $ length y `shouldBe` 1 liftIO $ length z `shouldBe` 1 testArrowText :: Spec testArrowText = describe "Single Arrow (Text)" $ do it "creates sane SQL" $ createSaneSQL (jsonbVal (object ["a" .= True]) ->>. "a") "SELECT (? ->> ?)\nFROM \"Json\"\n" [ PersistDbSpecific "{\"a\":true}" , PersistText "a" ] it "creates sane SQL (chained)" $ do let obj = object ["a" .= [1 :: Int,2,3]] createSaneSQL (jsonbVal obj ->. "a" ->>. 1) "SELECT ((? -> ?) ->> ?)\nFROM \"Json\"\n" [ PersistDbSpecific "{\"a\":[1,2,3]}" , PersistText "a" , PersistInt64 1 ] it "works as expected" $ run $ do x <- selectJSONwhere $ \v -> v ->>. "b" ==. just (val "false") y <- selectJSONwhere $ \v -> v ->>. 1 ==. just (val "true") z <- selectJSONwhere $ \v -> v ->. "a" ->. "b" ->>. "c" ==. just (val "message") liftIO $ length x `shouldBe` 1 liftIO $ length y `shouldBe` 1 liftIO $ length z `shouldBe` 1 testHashArrowJSONB :: Spec testHashArrowJSONB = describe "Double Arrow (JSONB)" $ do it "creates sane SQL" $ do let list = ["a","b","c"] createSaneSQL @JSONValue (jsonbVal (object ["a" .= True]) #>. list) "SELECT (? #> ?)\nFROM \"Json\"\n" [ PersistDbSpecific "{\"a\":true}" , persistTextArray list ] it "creates sane SQL (chained)" $ do let obj = object ["a" .= [object ["b" .= True]]] createSaneSQL @JSONValue (jsonbVal obj #>. ["a","1"] #>. ["b"]) "SELECT ((? #> ?) #> ?)\nFROM \"Json\"\n" [ PersistDbSpecific "{\"a\":[{\"b\":true}]}" , persistTextArray ["a","1"] , persistTextArray ["b"] ] it "works as expected" $ run $ do x <- selectJSONwhere $ \v -> v #>. ["a","b","c"] ==. jsonbVal (String "message") y <- selectJSONwhere $ \v -> v #>. ["1","a"] ==. jsonbVal (Number 3.14) z <- selectJSONwhere $ \v -> v #>. ["1"] #>. ["a"] ==. jsonbVal (Number 3.14) liftIO $ length x `shouldBe` 1 liftIO $ length y `shouldBe` 1 liftIO $ length z `shouldBe` 1 testHashArrowText :: Spec testHashArrowText = describe "Double Arrow (Text)" $ do it "creates sane SQL" $ do let list = ["a","b","c"] createSaneSQL (jsonbVal (object ["a" .= True]) #>>. list) "SELECT (? #>> ?)\nFROM \"Json\"\n" [ PersistDbSpecific "{\"a\":true}" , persistTextArray list ] it "creates sane SQL (chained)" $ do let obj = object ["a" .= [object ["b" .= True]]] createSaneSQL (jsonbVal obj #>. ["a","1"] #>>. ["b"]) "SELECT ((? #> ?) #>> ?)\nFROM \"Json\"\n" [ PersistDbSpecific "{\"a\":[{\"b\":true}]}" , persistTextArray ["a","1"] , persistTextArray ["b"] ] it "works as expected" $ run $ do x <- selectJSONwhere $ \v -> v #>>. ["a","b","c"] ==. just (val "message") y <- selectJSONwhere $ \v -> v #>>. ["1","a"] ==. just (val "3.14") z <- selectJSONwhere $ \v -> v #>. ["1"] #>>. ["a"] ==. just (val "3.14") liftIO $ length x `shouldBe` 1 liftIO $ length y `shouldBe` 1 liftIO $ length z `shouldBe` 1 testFilterOperators :: Spec testFilterOperators = describe "Filter Operators" $ do testInclusion testQMark testQMarkAny testQMarkAll testInclusion :: Spec testInclusion = do describe "@>" $ do it "creates sane SQL" $ createSaneSQL (jsonbVal (object ["a" .= False, "b" .= True]) @>. jsonbVal (object ["a" .= False])) "SELECT (? @> ?)\nFROM \"Json\"\n" [ PersistDbSpecific "{\"a\":false,\"b\":true}" , PersistDbSpecific "{\"a\":false}" ] it "creates sane SQL (chained)" $ do let obj = object ["a" .= [object ["b" .= True]]] createSaneSQL (jsonbVal obj ->. "a" @>. jsonbVal (object ["b" .= True])) "SELECT ((? -> ?) @> ?)\nFROM \"Json\"\n" [ PersistDbSpecific "{\"a\":[{\"b\":true}]}" , PersistText "a" , PersistDbSpecific "{\"b\":true}" ] it "works as expected" $ run $ do x <- selectJSONwhere $ \v -> v @>. jsonbVal (Number 1) y <- selectJSONwhere $ \v -> v @>. jsonbVal (toJSON [object ["a" .= Number 3.14]]) z <- selectJSONwhere $ \v -> v ->. 1 @>. jsonbVal (object ["a" .= Number 3.14]) liftIO $ length x `shouldBe` 2 liftIO $ length y `shouldBe` 1 liftIO $ length z `shouldBe` 1 describe "<@" $ do it "creates sane SQL" $ createSaneSQL (jsonbVal (object ["a" .= False]) <@. jsonbVal (object ["a" .= False, "b" .= True])) "SELECT (? <@ ?)\nFROM \"Json\"\n" [ PersistDbSpecific "{\"a\":false}" , PersistDbSpecific "{\"a\":false,\"b\":true}" ] it "creates sane SQL (chained)" $ do let obj = object ["a" .= [object ["b" .= True]]] createSaneSQL (jsonbVal obj ->. "a" <@. jsonbVal (object ["b" .= True, "c" .= Null])) "SELECT ((? -> ?) <@ ?)\nFROM \"Json\"\n" [ PersistDbSpecific "{\"a\":[{\"b\":true}]}" , PersistText "a" , PersistDbSpecific "{\"b\":true,\"c\":null}" ] it "works as expected" $ run $ do x <- selectJSONwhere $ \v -> v <@. jsonbVal (toJSON [Number 1]) y <- selectJSONwhere $ \v -> v <@. jsonbVal (object ["a" .= (1 :: Int), "b" .= False, "c" .= Null]) z <- selectJSONwhere $ \v -> v #>. ["a","b"] <@. jsonbVal (object ["b" .= False, "c" .= String "message"]) liftIO $ length x `shouldBe` 2 liftIO $ length y `shouldBe` 1 liftIO $ length z `shouldBe` 1 testQMark :: Spec testQMark = describe "Question Mark" $ do it "creates sane SQL" $ createSaneSQL (jsonbVal (object ["a" .= False, "b" .= True]) JSON.?. "a") "SELECT (? ?? ?)\nFROM \"Json\"\n" [ PersistDbSpecific "{\"a\":false,\"b\":true}" , PersistText "a" ] it "creates sane SQL (chained)" $ do let obj = object ["a" .= [object ["b" .= True]]] createSaneSQL (jsonbVal obj #>. ["a","0"] JSON.?. "b") "SELECT ((? #> ?) ?? ?)\nFROM \"Json\"\n" [ PersistDbSpecific "{\"a\":[{\"b\":true}]}" , persistTextArray ["a","0"] , PersistText "b" ] it "works as expected" $ run $ do x <- selectJSONwhere (JSON.?. "a") y <- selectJSONwhere (JSON.?. "test") z <- selectJSONwhere $ \v -> v ->. "a" JSON.?. "b" liftIO $ length x `shouldBe` 2 liftIO $ length y `shouldBe` 2 liftIO $ length z `shouldBe` 1 testQMarkAny :: Spec testQMarkAny = describe "Question Mark (Any)" $ do it "creates sane SQL" $ createSaneSQL (jsonbVal (object ["a" .= False, "b" .= True]) ?|. ["a","c"]) "SELECT (? ??| ?)\nFROM \"Json\"\n" [ PersistDbSpecific "{\"a\":false,\"b\":true}" , persistTextArray ["a","c"] ] it "creates sane SQL (chained)" $ do let obj = object ["a" .= [object ["b" .= True]]] createSaneSQL (jsonbVal obj #>. ["a","0"] ?|. ["b","c"]) "SELECT ((? #> ?) ??| ?)\nFROM \"Json\"\n" [ PersistDbSpecific "{\"a\":[{\"b\":true}]}" , persistTextArray ["a","0"] , persistTextArray ["b","c"] ] it "works as expected" $ run $ do x <- selectJSONwhere (?|. ["b","test"]) y <- selectJSONwhere (?|. ["a"]) z <- selectJSONwhere $ \v -> v ->. (-3) ?|. ["a"] w <- selectJSONwhere (?|. []) liftIO $ length x `shouldBe` 3 liftIO $ length y `shouldBe` 2 liftIO $ length z `shouldBe` 1 liftIO $ length w `shouldBe` 0 testQMarkAll :: Spec testQMarkAll = describe "Question Mark (All)" $ do it "creates sane SQL" $ createSaneSQL (jsonbVal (object ["a" .= False, "b" .= True]) ?&. ["a","c"]) "SELECT (? ??& ?)\nFROM \"Json\"\n" [ PersistDbSpecific "{\"a\":false,\"b\":true}" , persistTextArray ["a","c"] ] it "creates sane SQL (chained)" $ do let obj = object ["a" .= [object ["b" .= True]]] createSaneSQL (jsonbVal obj #>. ["a","0"] ?&. ["b","c"]) "SELECT ((? #> ?) ??& ?)\nFROM \"Json\"\n" [ PersistDbSpecific "{\"a\":[{\"b\":true}]}" , persistTextArray ["a","0"] , persistTextArray ["b","c"] ] it "works as expected" $ run $ do x <- selectJSONwhere (?&. ["test"]) y <- selectJSONwhere (?&. ["a","b"]) z <- selectJSONwhere $ \v -> v ->. "a" ?&. ["b"] w <- selectJSONwhere (?&. []) liftIO $ length x `shouldBe` 2 liftIO $ length y `shouldBe` 1 liftIO $ length z `shouldBe` 1 liftIO $ length w `shouldBe` 9 testConcatDeleteOperators :: Spec testConcatDeleteOperators = do describe "Concatenation Operator" testConcatenationOperator describe "Deletion Operators" $ do testMinusOperator testMinusOperatorV10 testHashMinusOperator testConcatenationOperator :: Spec testConcatenationOperator = describe "Concatenation" $ do it "creates sane SQL" $ createSaneSQL @JSONValue (jsonbVal (object ["a" .= False, "b" .= True]) JSON.||. jsonbVal (object ["c" .= Null])) "SELECT (? || ?)\nFROM \"Json\"\n" [ PersistDbSpecific "{\"a\":false,\"b\":true}" , PersistDbSpecific "{\"c\":null}" ] it "creates sane SQL (chained)" $ do let obj = object ["a" .= [object ["b" .= True]]] createSaneSQL @JSONValue (jsonbVal obj ->. "a" JSON.||. jsonbVal (toJSON [Null])) "SELECT ((? -> ?) || ?)\nFROM \"Json\"\n" [ PersistDbSpecific "{\"a\":[{\"b\":true}]}" , PersistText "a" , PersistDbSpecific "[null]" ] it "works as expected" $ run $ do x <- selectJSON $ \v -> do where_ $ v @>. jsonbVal (object []) where_ $ v JSON.||. jsonbVal (object ["x" .= True]) @>. jsonbVal (object ["x" .= True]) y <- selectJSONwhere $ \v -> v JSON.||. jsonbVal (toJSON [String "a", String "b"]) ->>. 4 ==. just (val "b") z <- selectJSONwhere $ \v -> v JSON.||. jsonbVal (toJSON [Bool False]) ->. 0 JSON.@>. jsonbVal (Number 1) w <- selectJSON $ \v -> do where_ . not_ $ v @>. jsonbVal (object []) where_ $ jsonbVal (String "test1") JSON.||. v ->>. 0 ==. just (val "test1") liftIO $ length x `shouldBe` 2 liftIO $ length y `shouldBe` 1 liftIO $ length z `shouldBe` 2 liftIO $ length w `shouldBe` 7 sqlFailWith "22023" $ selectJSONwhere $ \v -> v JSON.||. jsonbVal (toJSON $ String "test") @>. jsonbVal (String "test") testMinusOperator :: Spec testMinusOperator = describe "Minus Operator" $ do it "creates sane SQL" $ createSaneSQL @JSONValue (jsonbVal (object ["a" .= False, "b" .= True]) JSON.-. "a") "SELECT (? - ?)\nFROM \"Json\"\n" [ PersistDbSpecific "{\"a\":false,\"b\":true}" , PersistText "a" ] it "creates sane SQL (chained)" $ do let obj = object ["a" .= [object ["b" .= True]]] createSaneSQL @JSONValue (jsonbVal obj ->. "a" JSON.-. 0) "SELECT ((? -> ?) - ?)\nFROM \"Json\"\n" [ PersistDbSpecific "{\"a\":[{\"b\":true}]}" , PersistText "a" , PersistInt64 0 ] it "works as expected" $ run $ do x <- selectJSON $ \v -> do where_ $ v @>. jsonbVal (toJSON ([] :: [Int])) where_ $ v JSON.-. 0 @>. jsonbVal (toJSON [Bool True]) y <- selectJSON $ \v -> do where_ $ v @>. jsonbVal (toJSON ([] :: [Int])) where_ $ v JSON.-. (-1) @>. jsonbVal (toJSON [Null]) z <- selectJSON_ $ \v -> v JSON.-. "b" ?&. ["a", "b"] w <- selectJSON_ $ \v -> do v JSON.-. "test" @>. jsonbVal (toJSON [String "test"]) liftIO $ length x `shouldBe` 2 liftIO $ length y `shouldBe` 1 liftIO $ length z `shouldBe` 0 liftIO $ length w `shouldBe` 0 sqlFailWith "22023" $ selectJSONwhere $ \v -> v JSON.-. 0 @>. jsonbVal (toJSON ([] :: [Int])) where selectJSON_ f = selectJSON $ \v -> do where_ $ v @>. jsonbVal (object []) ||. v @>. jsonbVal (toJSON ([] :: [Int])) where_ $ f v testMinusOperatorV10 :: Spec testMinusOperatorV10 = describe "Minus Operator (PSQL >= v10)" $ do it "creates sane SQL" $ createSaneSQL @JSONValue (jsonbVal (object ["a" .= False, "b" .= True]) --. ["a","b"]) "SELECT (? - ?)\nFROM \"Json\"\n" [ PersistDbSpecific "{\"a\":false,\"b\":true}" , persistTextArray ["a","b"] ] it "creates sane SQL (chained)" $ do let obj = object ["a" .= [object ["b" .= True]]] createSaneSQL @JSONValue (jsonbVal obj #>. ["a","0"] --. ["b"]) "SELECT ((? #> ?) - ?)\nFROM \"Json\"\n" [ PersistDbSpecific "{\"a\":[{\"b\":true}]}" , persistTextArray ["a","0"] , persistTextArray ["b"] ] it "works as expected" $ run $ do x <- selectJSON $ \v -> do where_ $ v @>. jsonbVal (toJSON ([] :: [Int])) where_ $ v --. ["test","a"] @>. jsonbVal (toJSON [String "test"]) y <- selectJSON $ \v -> do where_ $ v @>. jsonbVal (object []) where_ $ v --. ["a","b"] <@. jsonbVal (object []) z <- selectJSON_ $ \v -> v --. ["b"] <@. jsonbVal (object ["a" .= (1 :: Int)]) w <- selectJSON_ $ \v -> do v --. ["test"] @>. jsonbVal (toJSON [String "test"]) liftIO $ length x `shouldBe` 0 liftIO $ length y `shouldBe` 2 liftIO $ length z `shouldBe` 1 liftIO $ length w `shouldBe` 0 sqlFailWith "22023" $ selectJSONwhere $ \v -> v --. ["a"] @>. jsonbVal (toJSON ([] :: [Int])) where selectJSON_ f = selectJSON $ \v -> do where_ $ v @>. jsonbVal (object []) ||. v @>. jsonbVal (toJSON ([] :: [Int])) where_ $ f v testHashMinusOperator :: Spec testHashMinusOperator = describe "Hash-Minus Operator" $ do it "creates sane SQL" $ createSaneSQL @JSONValue (jsonbVal (object ["a" .= False, "b" .= True]) #-. ["a"]) "SELECT (? #- ?)\nFROM \"Json\"\n" [ PersistDbSpecific "{\"a\":false,\"b\":true}" , persistTextArray ["a"] ] it "creates sane SQL (chained)" $ do let obj = object ["a" .= [object ["b" .= True]]] createSaneSQL @JSONValue (jsonbVal obj ->. "a" #-. ["0","b"]) "SELECT ((? -> ?) #- ?)\nFROM \"Json\"\n" [ PersistDbSpecific "{\"a\":[{\"b\":true}]}" , PersistText "a" , persistTextArray ["0","b"] ] it "works as expected" $ run $ do x <- selectJSON $ \v -> do where_ $ v @>. jsonbVal (toJSON ([] :: [Int])) where_ $ v #-. ["1","a"] @>. jsonbVal (toJSON [object []]) y <- selectJSON $ \v -> do where_ $ v @>. jsonbVal (toJSON ([] :: [Int])) where_ $ v #-. ["-3","a"] @>. jsonbVal (toJSON [object []]) z <- selectJSON_ $ \v -> v #-. ["a","b","c"] @>. jsonbVal (object ["a" .= object ["b" .= object ["c" .= String "message"]]]) w <- selectJSON_ $ \v -> v #-. ["a","b"] JSON.?. "b" liftIO $ length x `shouldBe` 1 liftIO $ length y `shouldBe` 1 liftIO $ length z `shouldBe` 0 liftIO $ length w `shouldBe` 1 sqlFailWith "22023" $ selectJSONwhere $ \v -> v #-. ["0"] @>. jsonbVal (toJSON ([] :: [Int])) where selectJSON_ f = selectJSON $ \v -> do where_ $ v @>. jsonbVal (object []) where_ $ f v testInsertUniqueViolation :: Spec testInsertUniqueViolation = describe "Unique Violation on Insert" $ it "Unique throws exception" $ run (do _ <- insert u1 _ <- insert u2 insert u3) `shouldThrow` (==) exception where exception = SqlError { sqlState = "23505", sqlExecStatus = FatalError, sqlErrorMsg = "duplicate key value violates unique constraint \"UniqueValue\"", sqlErrorDetail = "Key (value)=(0) already exists.", sqlErrorHint = ""} testUpsert :: Spec testUpsert = describe "Upsert test" $ do it "Upsert can insert like normal" $ run $ do u1e <- EP.upsert u1 [OneUniqueName =. val "fifth"] liftIO $ entityVal u1e `shouldBe` u1 it "Upsert performs update on collision" $ run $ do u1e <- EP.upsert u1 [OneUniqueName =. val "fifth"] liftIO $ entityVal u1e `shouldBe` u1 u2e <- EP.upsert u2 [OneUniqueName =. val "fifth"] liftIO $ entityVal u2e `shouldBe` u2 u3e <- EP.upsert u3 [OneUniqueName =. val "fifth"] liftIO $ entityVal u3e `shouldBe` u1{oneUniqueName="fifth"} testInsertSelectWithConflict :: Spec testInsertSelectWithConflict = describe "insertSelectWithConflict test" $ do it "Should do Nothing when no updates set" $ run $ do _ <- insert p1 _ <- insert p2 _ <- insert p3 n1 <- EP.insertSelectWithConflictCount UniqueValue ( from $ \p -> return $ OneUnique <# val "test" <&> (p ^. PersonFavNum) ) (\current excluded -> []) uniques1 <- select $ from $ \u -> return u n2 <- EP.insertSelectWithConflictCount UniqueValue ( from $ \p -> return $ OneUnique <# val "test" <&> (p ^. PersonFavNum) ) (\current excluded -> []) uniques2 <- select $ from $ \u -> return u liftIO $ n1 `shouldBe` 3 liftIO $ n2 `shouldBe` 0 let test = map (OneUnique "test" . personFavNum) [p1,p2,p3] liftIO $ map entityVal uniques1 `shouldBe` test liftIO $ map entityVal uniques2 `shouldBe` test it "Should update a value if given an update on conflict" $ run $ do _ <- insert p1 _ <- insert p2 _ <- insert p3 -- Note, have to sum 4 so that the update does not conflicts again with another row. n1 <- EP.insertSelectWithConflictCount UniqueValue ( from $ \p -> return $ OneUnique <# val "test" <&> (p ^. PersonFavNum) ) (\current excluded -> [OneUniqueValue =. val 4 +. (current ^. OneUniqueValue) +. (excluded ^. OneUniqueValue)]) uniques1 <- select $ from $ \u -> return u n2 <- EP.insertSelectWithConflictCount UniqueValue ( from $ \p -> return $ OneUnique <# val "test" <&> (p ^. PersonFavNum) ) (\current excluded -> [OneUniqueValue =. val 4 +. (current ^. OneUniqueValue) +. (excluded ^. OneUniqueValue)]) uniques2 <- select $ from $ \u -> return u liftIO $ n1 `shouldBe` 3 liftIO $ n2 `shouldBe` 3 let test = map (OneUnique "test" . personFavNum) [p1,p2,p3] test2 = map (OneUnique "test" . (+4) . (*2) . personFavNum) [p1,p2,p3] liftIO $ map entityVal uniques1 `shouldBe` test liftIO $ map entityVal uniques2 `shouldBe` test2 type JSONValue = Maybe (JSONB A.Value) createSaneSQL :: (PersistField a) => SqlExpr (Value a) -> T.Text -> [PersistValue] -> IO () createSaneSQL act q vals = run $ do (query, args) <- showQuery ES.SELECT $ fromValue act liftIO $ query `shouldBe` q liftIO $ args `shouldBe` vals fromValue :: (PersistField a) => SqlExpr (Value a) -> SqlQuery (SqlExpr (Value a)) fromValue act = from $ \x -> do let _ = x :: SqlExpr (Entity Json) return act persistTextArray :: [T.Text] -> PersistValue persistTextArray = PersistArray . fmap PersistText sqlFailWith :: (MonadCatch m, MonadIO m) => ByteString -> SqlPersistT (R.ResourceT m) a -> SqlPersistT (R.ResourceT m) () sqlFailWith errState f = do p <- (f >> return True) `catch` success when p failed where success SqlError{sqlState} | sqlState == errState = return False | otherwise = do liftIO $ expectationFailure $ T.unpack $ T.concat [ "should fail with: ", errStateT , ", but received: ", TE.decodeUtf8 sqlState ] return False failed = liftIO $ expectationFailure $ "should fail with: " `mappend` T.unpack errStateT errStateT = TE.decodeUtf8 errState selectJSONwhere :: MonadIO m => (JSONBExpr A.Value -> SqlExpr (Value Bool)) -> SqlPersistT m [Entity Json] selectJSONwhere f = selectJSON $ where_ . f selectJSON :: MonadIO m => (JSONBExpr A.Value -> SqlQuery ()) -> SqlPersistT m [Entity Json] selectJSON f = select $ from $ \v -> do f $ just (v ^. JsonValue) return v --------------- JSON --------------- JSON --------------- JSON --------------- --------------- JSON --------------- JSON --------------- JSON --------------- --------------- JSON --------------- JSON --------------- JSON --------------- main :: IO () main = do hspec $ do tests run describe "Test PostgreSQL locking" $ do testLocking withConn describe "PostgreSQL specific tests" $ do testAscRandom random_ run testRandomMath run testSelectDistinctOn testPostgresModule testPostgresqlOneAscOneDesc testPostgresqlTwoAscFields testPostgresqlSum testPostgresqlRandom testPostgresqlUpdate testPostgresqlCoalesce testPostgresqlTextFunctions testInsertUniqueViolation testUpsert testInsertSelectWithConflict describe "PostgreSQL JSON tests" $ do -- NOTE: We only clean the table once, so we -- can use its contents across all JSON tests it "MIGRATE AND CLEAN JSON TABLE" $ run $ do void $ runMigrationSilent migrateJSON cleanJSON testJSONInsertions testJSONOperators run, runSilent, runVerbose :: Run runSilent act = runNoLoggingT $ run_worker act runVerbose act = runStderrLoggingT $ run_worker act run f = do verbose' <- lookupEnv "VERBOSE" >>= \case Nothing -> return verbose Just x | map Char.toLower x == "true" -> return True | null x -> return True | otherwise -> return False if verbose' then runVerbose f else runSilent f verbose :: Bool verbose = False run_worker :: RunDbMonad m => SqlPersistT (R.ResourceT m) a -> m a run_worker act = withConn $ runSqlConn (migrateIt >> act) migrateIt :: RunDbMonad m => SqlPersistT (R.ResourceT m) () migrateIt = do void $ runMigrationSilent migrateAll void $ runMigrationSilent migrateUnique cleanDB cleanUniques withConn :: RunDbMonad m => (SqlBackend -> R.ResourceT m a) -> m a withConn = R.runResourceT . withPostgresqlConn "host=localhost port=5432 user=esqutest password=esqutest dbname=esqutest" -- | Show the SQL generated by a query showQuery :: (Monad m, ES.SqlSelect a r, BackendCompatible SqlBackend backend) => ES.Mode -> SqlQuery a -> ReaderT backend m (T.Text, [PersistValue]) showQuery mode query = do backend <- ask let (builder, values) = ES.toRawSql mode (backend, ES.initialIdentState) query return (ES.builderToText builder, values) esqueleto-3.3.3.2/test/PostgreSQL/MigrateJSON.hs0000644000000000000000000000177513612651103017464 0ustar0000000000000000{-# LANGUAGE FlexibleContexts , GADTs , GeneralizedNewtypeDeriving , DerivingStrategies , StandaloneDeriving , MultiParamTypeClasses , OverloadedStrings , QuasiQuotes , RankNTypes , ScopedTypeVariables , TemplateHaskell , TypeFamilies , UndecidableInstances #-} module PostgreSQL.MigrateJSON where import Control.Monad.Trans.Resource (ResourceT) import Data.Aeson (Value) import Database.Esqueleto (SqlExpr, delete, from) import Database.Esqueleto.PostgreSQL.JSON (JSONB) import Database.Persist (Entity) import Database.Persist.Sql (SqlPersistT) import Database.Persist.TH import Common.Test (RunDbMonad) -- JSON Table for PostgreSQL share [mkPersist sqlSettings, mkMigrate "migrateJSON"] [persistUpperCase| Json value (JSONB Value) |] cleanJSON :: (forall m. RunDbMonad m => SqlPersistT (ResourceT m) ()) cleanJSON = delete $ from $ \(_ :: SqlExpr (Entity Json)) -> return () esqueleto-3.3.3.2/test/MySQL/Test.hs0000644000000000000000000001304313554623526015267 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables , FlexibleContexts , RankNTypes , TypeFamilies #-} module Main (main) where import Control.Monad (void) import Control.Monad.IO.Class (MonadIO(liftIO)) import Control.Monad.Logger (runStderrLoggingT, runNoLoggingT) import Control.Monad.Trans.Reader (ReaderT) import Database.Persist.MySQL ( withMySQLConn , connectHost , connectDatabase , connectUser , connectPassword , defaultConnectInfo) import Database.Esqueleto import qualified Control.Monad.Trans.Resource as R import Test.Hspec import Common.Test -- testMysqlRandom :: Spec -- testMysqlRandom = do -- -- This is known not to work until -- -- we can differentiate behavior by database -- it "works with random_" $ -- run $ do -- _ <- select $ return (random_ :: SqlExpr (Value Double)) -- return () testMysqlSum :: Spec testMysqlSum = do it "works with sum_" $ run $ do _ <- insert' p1 _ <- insert' p2 _ <- insert' p3 _ <- insert' p4 ret <- select $ from $ \p-> return $ joinV $ sum_ (p ^. PersonAge) liftIO $ ret `shouldBe` [ Value $ Just (36 + 17 + 17 :: Double ) ] testMysqlTwoAscFields :: Spec testMysqlTwoAscFields = do it "works with two ASC fields (one call)" $ run $ do p1e <- insert' p1 p2e <- insert' p2 p3e <- insert' p3 p4e <- insert' p4 ret <- select $ from $ \p -> do orderBy [asc (p ^. PersonAge), asc (p ^. PersonName)] return p liftIO $ ret `shouldBe` [ p2e, p4e, p3e, p1e ] testMysqlOneAscOneDesc :: Spec testMysqlOneAscOneDesc = do it "works with one ASC and one DESC field (two calls)" $ run $ do p1e <- insert' p1 p2e <- insert' p2 p3e <- insert' p3 p4e <- insert' p4 ret <- select $ from $ \p -> do orderBy [desc (p ^. PersonAge)] orderBy [asc (p ^. PersonName)] return p liftIO $ ret `shouldBe` [ p1e, p4e, p3e, p2e ] testMysqlCoalesce :: Spec testMysqlCoalesce = do it "works on PostgreSQL and MySQL with <2 arguments" $ run $ do _ :: [Value (Maybe Int)] <- select $ from $ \p -> do return (coalesce [p ^. PersonAge]) return () testMysqlUpdate :: Spec testMysqlUpdate = do it "works on a simple example" $ run $ do p1k <- insert p1 p2k <- insert p2 p3k <- insert p3 let anon = "Anonymous" () <- update $ \p -> do set p [ PersonName =. val anon , PersonAge *=. just (val 2) ] where_ (p ^. PersonName !=. val "Mike") n <- updateCount $ \p -> do set p [ PersonAge +=. just (val 1) ] where_ (p ^. PersonName !=. val "Mike") ret <- select $ from $ \p -> do orderBy [ asc (p ^. PersonName), asc (p ^. PersonAge) ] return p -- MySQL: nulls appear first, and update returns actual number -- of changed rows liftIO $ n `shouldBe` 1 liftIO $ ret `shouldBe` [ Entity p2k (Person anon Nothing (Just 37) 2) , Entity p1k (Person anon (Just 73) Nothing 1) , Entity p3k p3 ] nameContains :: (BaseBackend backend ~ SqlBackend, BackendCompatible SqlBackend backend, MonadIO m, SqlString s, IsPersistBackend backend, PersistQueryRead backend, PersistUniqueRead backend) => (SqlExpr (Value [Char]) -> SqlExpr (Value s) -> SqlExpr (Value Bool)) -> s -> [Entity Person] -> ReaderT backend m () nameContains f t expected = do ret <- select $ from $ \p -> do where_ (f (p ^. PersonName) (concat_ [(%), val t, (%)])) orderBy [asc (p ^. PersonName)] return p liftIO $ ret `shouldBe` expected testMysqlTextFunctions :: Spec testMysqlTextFunctions = do describe "text functions" $ do it "like, (%) and (++.) work on a simple example" $ run $ do [p1e, p2e, p3e, p4e] <- mapM insert' [p1, p2, p3, p4] nameContains like "h" [p1e, p2e] nameContains like "i" [p4e, p3e] nameContains like "iv" [p4e] main :: IO () main = do hspec $ do tests run describe "Test MySQL locking" $ do testLocking withConn describe "MySQL specific tests" $ do -- definitely doesn't work at the moment -- testMysqlRandom testMysqlSum testMysqlTwoAscFields testMysqlOneAscOneDesc testMysqlCoalesce testMysqlUpdate testMysqlTextFunctions run, runSilent, runVerbose :: Run runSilent act = runNoLoggingT $ run_worker act runVerbose act = runStderrLoggingT $ run_worker act run = if verbose then runVerbose else runSilent verbose :: Bool verbose = False run_worker :: RunDbMonad m => SqlPersistT (R.ResourceT m) a -> m a run_worker act = withConn $ runSqlConn (migrateIt >> act) migrateIt :: RunDbMonad m => SqlPersistT (R.ResourceT m) () migrateIt = do void $ runMigrationSilent migrateAll cleanDB withConn :: RunDbMonad m => (SqlBackend -> R.ResourceT m a) -> m a withConn = R.runResourceT . withMySQLConn defaultConnectInfo { connectHost = "localhost" , connectUser = "travis" , connectPassword = "" , connectDatabase = "esqutest" } esqueleto-3.3.3.2/LICENSE0000644000000000000000000000276213454457034013101 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-3.3.3.2/Setup.hs0000644000000000000000000000005613454457034013522 0ustar0000000000000000import Distribution.Simple main = defaultMain esqueleto-3.3.3.2/esqueleto.cabal0000644000000000000000000001250013674150634015055 0ustar0000000000000000cabal-version: 1.12 name: esqueleto version: 3.3.3.2 synopsis: Type-safe EDSL for SQL queries on persistent backends. description: @esqueleto@ is a bare bones, type-safe EDSL for SQL queries that works with unmodified @persistent@ SQL backends. Its language closely resembles SQL, so you don't have to learn new concepts, just new syntax, and it's fairly easy to predict the generated SQL and optimize it for your backend. Most kinds of errors committed when writing SQL are caught as compile-time errors---although it is possible to write type-checked @esqueleto@ queries that fail at runtime. . @persistent@ is a library for type-safe data serialization. It has many kinds of backends, such as SQL backends (@persistent-mysql@, @persistent-postgresql@, @persistent-sqlite@) and NoSQL backends (@persistent-mongoDB@). While @persistent@ is a nice library for storing and retrieving records, including with filters, it does not try to support some of the features that are specific to SQL backends. In particular, @esqueleto@ is the recommended library for type-safe @JOIN@s on @persistent@ SQL backends. (The alternative is using raw SQL, but that's error prone and does not offer any composability.) . Currently, @SELECT@s, @UPDATE@s, @INSERT@s and @DELETE@s are supported. Not all SQL features are available, but most of them can be easily added (especially functions), so please open an issue or send a pull request if you need anything that is not covered by @esqueleto@ on . . The name of this library means \"skeleton\" in Portuguese and contains all three SQL letters in the correct order =). It was inspired by Scala's Squeryl but created from scratch. category: Database homepage: https://github.com/bitemyapp/esqueleto author: Felipe Lessa maintainer: cma@bitemyapp.com copyright: (c) 2012-2016 Felipe Almeida Lessa license: BSD3 license-file: LICENSE build-type: Simple extra-source-files: README.md changelog.md source-repository head type: git location: git://github.com/bitemyapp/esqueleto.git library exposed-modules: Database.Esqueleto Database.Esqueleto.Experimental Database.Esqueleto.Internal.Language Database.Esqueleto.Internal.Sql Database.Esqueleto.Internal.Internal Database.Esqueleto.Internal.ExprParser Database.Esqueleto.MySQL Database.Esqueleto.PostgreSQL Database.Esqueleto.PostgreSQL.JSON Database.Esqueleto.SQLite other-modules: Database.Esqueleto.Internal.PersistentImport Database.Esqueleto.PostgreSQL.JSON.Instances Paths_esqueleto hs-source-dirs: src/ build-depends: base >=4.8 && <5.0 , aeson >=1.0 , attoparsec >= 0.13 && < 0.14 , blaze-html , bytestring , conduit >=1.3 , containers , monad-logger , persistent >=2.10.0 && <2.11 , resourcet >=1.2 , tagged >=0.2 , text >=0.11 && <1.3 , time >=1.5.0.1 && <=1.10 , transformers >=0.2 , unliftio , unordered-containers >=0.2 if impl(ghc >=8.0) ghc-options: -Wall -Wno-redundant-constraints else ghc-options: -Wall default-language: Haskell2010 test-suite mysql type: exitcode-stdio-1.0 main-is: MySQL/Test.hs other-modules: Common.Test Paths_esqueleto hs-source-dirs: test ghc-options: -Wall build-depends: base >=4.8 && <5.0 , attoparsec , blaze-html , bytestring , conduit >=1.3 , containers , esqueleto , exceptions , hspec , monad-logger , mtl , mysql , mysql-simple , persistent >=2.8.0 && <2.11 , persistent-mysql , persistent-template , resourcet >=1.2 , tagged >=0.2 , text >=0.11 && <1.3 , time , transformers >=0.2 , unliftio , unordered-containers >=0.2 default-language: Haskell2010 test-suite postgresql type: exitcode-stdio-1.0 main-is: PostgreSQL/Test.hs other-modules: Common.Test PostgreSQL.MigrateJSON Paths_esqueleto hs-source-dirs: test ghc-options: -Wall build-depends: base >=4.8 && <5.0 , aeson , attoparsec , blaze-html , bytestring , conduit >=1.3 , containers , esqueleto , exceptions , hspec , monad-logger , mtl , persistent >=2.10.0 && <2.11 , persistent-postgresql >= 2.10.0 && <2.11 , persistent-template , postgresql-libpq , postgresql-simple , resourcet >=1.2 , tagged >=0.2 , text >=0.11 && <1.3 , time , transformers >=0.2 , unliftio , unordered-containers >=0.2 , vector default-language: Haskell2010 test-suite sqlite type: exitcode-stdio-1.0 main-is: SQLite/Test.hs other-modules: Common.Test Paths_esqueleto hs-source-dirs: test ghc-options: -Wall build-depends: base >=4.8 && <5.0 , attoparsec , blaze-html , bytestring , conduit >=1.3 , containers , esqueleto , exceptions , hspec , monad-logger , mtl , persistent >=2.8.0 && <2.11 , persistent-sqlite , persistent-template , resourcet >=1.2 , tagged >=0.2 , text >=0.11 && <1.3 , time , transformers >=0.2 , unliftio , unordered-containers >=0.2 default-language: Haskell2010 esqueleto-3.3.3.2/README.md0000644000000000000000000003367613673702025013357 0ustar0000000000000000Esqueleto [![TravisCI](https://travis-ci.org/bitemyapp/esqueleto.svg)](https://travis-ci.org/bitemyapp/esqueleto) ========== ![Skeleton](./esqueleto.png) Image courtesy [Chrissy Long](https://www.flickr.com/photos/chrissylong/313800029/) # Esqueleto, a SQL DSL for Haskell Esqueleto is a bare bones, type-safe EDSL for SQL queries that works with unmodified persistent SQL backends. 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. Its language closely resembles SQL. Currently, SELECTs, UPDATEs, INSERTs and DELETEs are supported. In particular, esqueleto is the recommended library for type-safe JOINs on persistent SQL backends. (The alternative is using raw SQL, but that's error prone and does not offer any composability.). For more information read [esqueleto](http://hackage.haskell.org/package/esqueleto). ## 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](http://www.yesodweb.com/book/persistent) first to learn how to define your schema. If you need to use `persistent`'s default support for queries as well, either import it qualified: ```haskell -- For a module that mostly uses esqueleto. import Database.Esqueleto import qualified Database.Persistent as P ``` or import `esqueleto` itself qualified: ```haskell -- For a module that 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. ## Goals The main goals of `esqueleto` are: - Be easily translatable to SQL. (You should be able to know exactly how the SQL query will end up.) - Support the most widely used SQL features. - Be as type-safe as possible. It is _not_ a goal to be able to write portable SQL. We do not try to hide the differences between DBMSs from you ## Introduction For the following examples, we'll use this example schema: ```haskell 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 |] ``` ## Select 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: ```haskell putPersons :: SqlPersist m () putPersons = do people <- select $ from $ \person -> do return person liftIO $ mapM_ (putStrLn . personName . entityVal) people ``` which generates this SQL: ```sql SELECT * FROM Person ``` `esqueleto` knows that we want an `Entity Person` just because of the `personName` that is printed. ## Where Filtering by `PersonName`: ```haskell select $ from $ \p -> do where_ (p ^. PersonName ==. val "John") return p ``` which generates this SQL: ```sql SELECT * FROM Person WHERE Person.name = "John" ``` 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: In `esqueleto`, we may write the same query above as: ```haskell select $ from $ \p -> do where_ (p ^. PersonAge >=. just (val 18)) return p ``` which generates this SQL: ```sql SELECT * FROM Person WHERE Person.age >= 18 ``` Since `age` is an optional `Person` field, we use `just` to lift`val 18 :: SqlExpr (Value Int)` into `just (val 18) ::SqlExpr (Value (Maybe Int))`. ## Joins Implicit joins are represented by tuples. For example, to get the list of all blog posts and their authors, we could write: ```haskell select $ from $ \(b, p) -> do where_ (b ^. BlogPostAuthorId ==. p ^. PersonId) orderBy [asc (b ^. BlogPostTitle)] return (b, p) ``` which generates this SQL: ```sql SELECT BlogPost.*, Person.* FROM BlogPost, Person WHERE BlogPost.authorId = Person.id ORDER BY BlogPost.title ASC ``` However, you may want your results to include people who don't have any blog posts as well using a `LEFT OUTER JOIN`: ```haskell select $ from $ \(p `LeftOuterJoin` mb) -> do on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId) orderBy [asc (p ^. PersonName), asc (mb ?. BlogPostTitle)] return (p, mb) ``` which generates this SQL: ```sql SELECT Person.*, BlogPost.* FROM Person LEFT OUTER JOIN BlogPost ON Person.id = BlogPost.authorId ORDER BY Person.name ASC, BlogPost.title ASC ``` ## Left Outer Join 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 of the `Follow` entity: ```haskell select $ from $ \(p1 `InnerJoin` f `InnerJoin` p2) -> do on (p2 ^. PersonId ==. f ^. FollowFollowed) on (p1 ^. PersonId ==. f ^. FollowFollower) return (p1, f, p2) ``` which generates this SQL: ```sql SELECT P1.*, Follow.*, P2.* FROM Person AS P1 INNER JOIN Follow ON P1.id = Follow.follower INNER JOIN Person AS P2 ON P2.id = Follow.followed ``` ## Update and Delete ```haskell 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: ```haskell insertSelect $ from $ \p-> return $ BlogPost <# "Group Blog Post" <&> (p ^. PersonId) ``` which generates this SQL: ```sql INSERT INTO BlogPost SELECT ('Group Blog Post', id) FROM Person ``` Individual insertions can be performed through Persistent's `insert` function, reexported for convenience. ### Re-exports We re-export many symbols from `persistent` for convenience: - "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`. ### RDBMS Specific 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` - MySQL: `Database.Esqueleto.MySQL` - SQLite: `Database.Esqueleto.SQLite` In order to use these functions, you need to explicitly import their corresponding modules. ### Unsafe functions, operators and values Esqueleto doesn't support every possible function, and it can't - many functions aren't available on every RDBMS platform, and sometimes the same functionality is hidden behind different names. To overcome this problem, Esqueleto exports a number of unsafe functions to call any function, operator or value. These functions can be found in Database.Esqueleto.Internal.Sql module. Warning: the functions discussed in this section must always be used with an explicit type signature,and the user must be careful to provide a type signature that corresponds correctly with the underlying code. The functions have extremely general types, and if you allow type inference to figure everything out for you, it may not correspond with the underlying SQL types that you want. This interface is effectively the FFI to SQL database, so take care! The most common use of these functions is for calling RDBMS specific or custom functions, for that end we use `unsafeSqlFunction`. For example, if we wish to consult the postgres `now` function we could so as follow: ```haskell postgresTime :: (MonadIO m, MonadLogger m) => SqlWriteT m UTCTime postgresTime = result <- select (pure now) case result of [x] -> pure x _ -> error "now() is guaranteed to return a single result" where now :: SqlExpr (Value UTCTime) now = unsafeSqlFunction "now" () ``` which generates this SQL: ```sql SELECT now() ``` With the `now` function we could now use the current time of the postgres RDBMS on any query. Do notice that `now` does not use any arguments, so we use `()` that is an instance of `UnsafeSqlFunctionArgument` to represent no arguments, an empty list cast to a correct value will yield the same result as `()`. We can also use `unsafeSqlFunction` for more complex functions with customs values using `unsafeSqlValue` which turns any string into a sql value of whatever type we want, disclaimer: if you use it badly you will cause a runtime error. For example, say we want to try postgres' `date_part` function and get the day of a timestamp, we could use: ```haskell postgresTimestampDay :: (MonadIO m, MonadLogger m) => SqlWriteT m Int postgresTimestampDay = result <- select (return $ dayPart date) case result of [x] -> pure x _ -> error "dayPart is guaranteed to return a single result" where dayPart :: SqlExpr (Value UTCTime) -> SqlExpr (Value Int) dayPart s = unsafeSqlFunction "date_part" (unsafeSqlValue "\'day\'" :: SqlExpr (Value String) ,s) date :: SqlExpr (Value UTCTime) date = unsafeSqlValue "TIMESTAMP \'2001-02-16 20:38:40\'" ``` which generates this SQL: ```sql SELECT date_part('day', TIMESTAMP '2001-02-16 20:38:40') ``` Using `unsafeSqlValue` we were required to also define the type of the value. Another useful unsafe function is `unsafeSqlCastAs`, which allows us to cast any type to another within a query. For example, say we want to use our previews `dayPart` function on the current system time, we could: ```haskell postgresTimestampDay :: (MonadIO m, MonadLogger m) => SqlWriteT m Int postgresTimestampDay = do currentTime <- liftIO getCurrentTime result <- select (return $ dayPart (toTIMESTAMP $ val currentTime)) case result of [x] -> pure x _ -> error "dayPart is guaranteed to return a single result" where dayPart :: SqlExpr (Value UTCTime) -> SqlExpr (Value Int) dayPart s = unsafeSqlFunction "date_part" (unsafeSqlValue "\'day\'" :: SqlExpr (Value String) ,s) toTIMESTAMP :: SqlExpr (Value UTCTime) -> SqlExpr (Value UTCTime) toTIMESTAMP = unsafeSqlCastAs "TIMESTAMP" ``` which generates this SQL: ```sql SELECT date_part('day', CAST('2019-10-28 23:19:39.400898344Z' AS TIMESTAMP)) ``` ### SQL injection Esqueleto uses parameterization to prevent sql injections on values and arguments on all queries, for example, if we have: ```haskell myEvilQuery :: (MonadIO m, MonadLogger m) => SqlWriteT m () myEvilQuery = select (return $ val ("hi\'; DROP TABLE foo; select \'bye\'" :: String)) >>= liftIO . print ``` which generates this SQL(when using postgres): ```sql SELECT 'hi''; DROP TABLE foo; select ''bye''' ``` And the printed value is `hi\'; DROP TABLE foo; select \'bye\'` and no table is dropped. This is good and makes the use of strings values safe. Unfortunately this is not the case when using unsafe functions. Let's see an example of defining a new evil `now` function: ```haskell myEvilQuery :: (MonadIO m, MonadLogger m) => SqlWriteT m () myEvilQuery = select (return nowWithInjection) >>= liftIO . print where nowWithInjection :: SqlExpr (Value UTCTime) nowWithInjection = unsafeSqlFunction "0; DROP TABLE bar; select now" ([] :: [SqlExpr (Value Int)]) ``` which generates this SQL: ```sql SELECT 0; DROP TABLE bar; select now() ``` If we were to run the above code we would see the postgres time printed but the table `bar` will be erased with no indication whatsoever. Another example of this behavior is seen when using `unsafeSqlValue`: ```haskell myEvilQuery :: (MonadIO m, MonadLogger m) => SqlWriteT m () myEvilQuery = select (return $ dayPart dateWithInjection) >>= liftIO . print where dayPart :: SqlExpr (Value UTCTime) -> SqlExpr (Value Int) dayPart s = unsafeSqlFunction "date_part" (unsafeSqlValue "\'day\'" :: SqlExpr (Value String) ,s) dateWithInjection :: SqlExpr (Value UTCTime) dateWithInjection = unsafeSqlValue "TIMESTAMP \'2001-02-16 20:38:40\');DROP TABLE bar; select (16" ``` which generates this SQL: ```sql SELECT date_part('day', TIMESTAMP '2001-02-16 20:38:40');DROP TABLE bar; select (16) ``` This will print 16 and also erase the `bar` table. The main take away of this examples is to never use any user or third party input inside an unsafe function without first parsing it or heavily sanitizing the input. ### Tests and Postgres To run the tests, do `stack test`. This tests all the backends, so you'll need to have MySQL and Postgresql installed. Using apt-get, you should be able to do: ``` sudo apt-get install postgresql postgresql-contrib sudo apt-get install libpq-dev ``` Using homebrew on OSx ``` brew install postgresql brew install libpq ``` Detailed instructions on the Postgres wiki [here](https://wiki.postgresql.org/wiki/Detailed_installation_guides) The connection details are located near the bottom of the [test/PostgreSQL/Test.hs](test/PostgreSQL/Test.hs) file: ``` withConn = R.runResourceT . withPostgresqlConn "host=localhost port=5432 user=esqutest password=esqutest dbname=esqutest" ``` You can change these if you like but to just get them working set up as follows on linux: ```$ sudo -u postgres createuser esqutest``` ```$ sudo -u postgres createdb esqutest``` ``` $ sudo -u postgres psql postgres=# \password esqutest ``` And on osx ```$ createuser esqutest``` ```$ createdb esqutest``` ``` $ psql postgres postgres=# \password esqutest ``` esqueleto-3.3.3.2/changelog.md0000644000000000000000000001170213674150634014337 0ustar00000000000000003.3.3.2 ======== - @maxgabriel - [#190](https://github.com/bitemyapp/esqueleto/pull/190) Further document and test `ToBaseId` 3.3.3.1 ======== - @belevy - [#189](https://github.com/bitemyapp/esqueleto/pull/189) - Fix bug in function calls with aliased values introduced by SubQuery joins. 3.3.3.0 ======== - @belevy - [#172](https://github.com/bitemyapp/esqueleto/pull/172) - Introduce new experimental module for joins, set operations (eg UNION), and safer queries from outer joins. 3.3.2 ======== - @belevy - [#177](https://github.com/bitemyapp/esqueleto/pull/177) Fix natural key handling in (^.) 3.3.1.1 ======== - @parsonsmatt - [#170](https://github.com/bitemyapp/esqueleto/pull/170) Add documentation to `groupBy` to explain tuple nesting. 3.3.1 ======== - @charukiewicz, @belevy, @joemalin95 - [#167](https://github.com/bitemyapp/esqueleto/pull/167): Exposed functions that were added in `3.3.0` 3.3.0 ======== - @charukiewicz, @belevy, @joemalin95 - [#166](https://github.com/bitemyapp/esqueleto/pull/166): Add several common SQL string functions: `upper_`, `trim_`, `ltrim_`, `rtrim_`, `length_`, `left_`, `right_` 3.2.3 ======== - @hdgarrood - [#163](https://github.com/bitemyapp/esqueleto/pull/163): Allow `unsafeSqlFunction` to take up to 10 arguments without needing to nest tuples. 3.2.2 ======== - @parsonsmatt - [#161](https://github.com/bitemyapp/esqueleto/pull/161/): Fix an issue where nested joins didn't get the right on clause. 3.2.1 ======== - @parsonsmatt - [#159](https://github.com/bitemyapp/esqueleto/pull/159): Add an instance of `UnsafeSqlFunction ()` for 0-argument SQL functions. 3.2.0 ======== - @parsonsmatt - [#153](https://github.com/bitemyapp/esqueleto/pull/153): Deprecate `sub_select` and introduce `subSelect`, `subSelectMaybe`, and `subSelectUnsafe`. - @parsonsmatt - [#156](https://github.com/bitemyapp/esqueleto/pull/156): Remove the restriction that `on` clauses must appear in reverse order to the joining tables. 3.1.3 ======== - @JoseD92 - [#155](https://github.com/bitemyapp/esqueleto/pull/149): Added `insertSelectWithConflict` postgres function. 3.1.2 ======== - @tippenein - [#149](https://github.com/bitemyapp/esqueleto/pull/157): Added `associateJoin` query helpers. 3.1.1 ======= - @JoseD92 - [#149](https://github.com/bitemyapp/esqueleto/pull/149): Added `upsert` support. - @parsonsmatt - [#133](https://github.com/bitemyapp/esqueleto/pull/133): Added `renderQueryToText` and related functions. 3.1.0 ======= - @Vlix - [#128](https://github.com/bitemyapp/esqueleto/pull/128): Added `Database.Esqueleto.PostgreSQL.JSON` module with JSON operators and `JSONB` data type. - @ibarrae - [#127](https://github.com/bitemyapp/esqueleto/pull/127): Added `between` and support for composite keys in `unsafeSqlBinOp`. 3.0.0 ======= - @parsonsmatt - [#122](https://github.com/bitemyapp/esqueleto/pull/122): Support `persistent-2.10.0`. This is a breaking change due to the removal of deprecated exports from the `persistent` library. - [#113](https://github.com/bitemyapp/esqueleto/pull/113): Remove the `esqueleto` type class. To migrate here, use `SqlExpr`, `SqlQuery`, and `SqlBackend` instead of using the polymorphic `Esqueleto sqlExpr sqlQuery sqlBackend => ...` types. 2.7.0 ======= - @parsonsmatt - [#117](https://github.com/bitemyapp/esqueleto/pull/117): Removed `sqlQQ` and `executeQQ` functions from export, fixing doc build and building with `persistent` >= 2.9 2.6.1 ======= - @ChrisCoffey - [#114](https://github.com/bitemyapp/esqueleto/pull/114): Fix Haddock by working around an upstream bug. 2.6.0 ======== - @bitemyapp - Reorganized dependencies, decided to break compatibility for Conduit 1.3, Persistent 2.8, and `unliftio`. - Moved tests for `random()` into database-specific test suites. - Deprecated Language `random_`, split it into database-specific modules. - @parsonsmatt - Added support for `PersistQueryRead`/`PersistQueryWrite`, enabling type-safe differentation of read and write capabilities. - https://github.com/bitemyapp/esqueleto/pull/66 - @sestrella - Added support for `arrayAggDistinct` and `arrayRemove`. - https://github.com/bitemyapp/esqueleto/pull/65 - https://github.com/bitemyapp/esqueleto/pull/66 - @mheinzel - Fixed JOIN syntax in the documentation https://github.com/bitemyapp/esqueleto/pull/60 - @illmade - Added instructions for running database specific tests - https://github.com/bitemyapp/esqueleto/pull/64 - @FintanH - Removed CPP from the test suite, split the database-specific tests into their own respective modules. - https://github.com/bitemyapp/esqueleto/pull/48 - Added support for PostgreSQL's `now()` - https://github.com/bitemyapp/esqueleto/pull/46 - Added a comprehensive examples project to make practical application of Esqueleto easier. - https://github.com/bitemyapp/esqueleto/pull/40 - @EdwardBetts - Fixed a spelling error - https://github.com/bitemyapp/esqueleto/pull/52