diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,15 @@ +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 ======== @@ -11,7 +23,7 @@ - [#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. diff --git a/esqueleto.cabal b/esqueleto.cabal --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -1,7 +1,7 @@ cabal-version: 1.12 name: esqueleto -version: 3.1.3 +version: 3.2.0 synopsis: Type-safe EDSL for SQL queries on persistent backends. description: @esqueleto@ is a bare bones, type-safe EDSL for SQL queries that works with unmodified @persistent@ SQL backends. Its language closely resembles SQL, so you don't have to learn new concepts, just new syntax, and it's fairly easy to predict the generated SQL and optimize it for your backend. Most kinds of errors committed when writing SQL are caught as compile-time errors---although it is possible to write type-checked @esqueleto@ queries that fail at runtime. . @@ -31,12 +31,13 @@ Database.Esqueleto 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.Internal Database.Esqueleto.Internal.PersistentImport Database.Esqueleto.PostgreSQL.JSON.Instances Paths_esqueleto @@ -45,10 +46,12 @@ build-depends: base >=4.8 && <5.0 , aeson >=1.0 + , attoparsec >= 0.13 && < 0.14 , blaze-html , bytestring , containers , conduit >=1.3 + , containers , monad-logger , persistent >=2.10.0 && <2.11 , resourcet >=1.2 @@ -75,6 +78,7 @@ ghc-options: -Wall build-depends: base >=4.8 && <5.0 + , attoparsec , blaze-html , bytestring , conduit >=1.3 @@ -83,6 +87,7 @@ , exceptions , hspec , monad-logger + , mtl , mysql , mysql-simple , persistent >=2.8.0 && <2.11 @@ -110,6 +115,7 @@ build-depends: base >=4.8 && <5.0 , aeson + , attoparsec , blaze-html , bytestring , conduit >=1.3 @@ -118,6 +124,7 @@ , exceptions , hspec , monad-logger + , mtl , persistent >=2.10.0 && <2.11 , persistent-postgresql >= 2.10.0 && <2.11 , persistent-template @@ -144,6 +151,7 @@ ghc-options: -Wall build-depends: base >=4.8 && <5.0 + , attoparsec , blaze-html , bytestring , conduit >=1.3 @@ -152,6 +160,7 @@ , exceptions , hspec , monad-logger + , mtl , persistent >=2.8.0 && <2.11 , persistent-sqlite , persistent-template diff --git a/src/Database/Esqueleto.hs b/src/Database/Esqueleto.hs --- a/src/Database/Esqueleto.hs +++ b/src/Database/Esqueleto.hs @@ -53,6 +53,12 @@ , in_, notIn, exists, notExists , set, (=.), (+=.), (-=.), (*=.), (/=.) , case_, toBaseId + , subSelect + , subSelectMaybe + , subSelectCount + , subSelectForeign + , subSelectList + , subSelectUnsafe , ToBaseId(..) , when_ , then_ @@ -327,15 +333,10 @@ -- @ -- 'select' $ -- 'from' $ \\(p1 `'InnerJoin`` f `'InnerJoin`` p2) -> do --- 'on' (p2 '^.' PersonId '==.' f '^.' FollowFollowed) -- 'on' (p1 '^.' PersonId '==.' f '^.' FollowFollower) +-- 'on' (p2 '^.' PersonId '==.' f '^.' FollowFollowed) -- return (p1, f, p2) -- @ --- --- /Note carefully that the order of the ON clauses is/ --- /reversed!/ You're required to write your 'on's in reverse --- order because that helps composability (see the documentation --- of 'on' for more details). -- -- We also currently support @UPDATE@ and @DELETE@ statements. -- For example: diff --git a/src/Database/Esqueleto/Internal/ExprParser.hs b/src/Database/Esqueleto/Internal/ExprParser.hs new file mode 100644 --- /dev/null +++ b/src/Database/Esqueleto/Internal/ExprParser.hs @@ -0,0 +1,82 @@ +{-# 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) diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -25,11 +25,16 @@ -- | 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 Control.Monad (ap, MonadPlus(..), void) +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) @@ -43,6 +48,8 @@ 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 @@ -57,6 +64,8 @@ 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': @@ -80,8 +89,8 @@ let ed = entityDef (getVal x) ident <- newIdentFor (entityDB ed) let ret = EEntity ident - from_ = FromStart ident ed - return (EPreprocessedFrom ret from_) + f' = FromStart ident ed + return (EPreprocessedFrom ret f') getVal :: SqlQuery (SqlExpr (PreprocessedFrom (SqlExpr (Entity a)))) -> Proxy a getVal = const Proxy @@ -94,7 +103,7 @@ where maybelize :: SqlExpr (PreprocessedFrom (SqlExpr (Entity a))) -> SqlExpr (PreprocessedFrom (SqlExpr (Maybe (Entity a)))) - maybelize (EPreprocessedFrom ret from_) = EPreprocessedFrom (EMaybe ret) from_ + maybelize (EPreprocessedFrom ret f') = EPreprocessedFrom (EMaybe ret) f' -- | (Internal) Do a @JOIN@. fromJoin @@ -105,71 +114,75 @@ fromJoin (EPreprocessedFrom lhsRet lhsFrom) (EPreprocessedFrom rhsRet rhsFrom) = Q $ do let ret = smartJoin lhsRet rhsRet - from_ = FromJoin lhsFrom -- LHS + from' = FromJoin lhsFrom -- LHS (reifyJoinKind ret) -- JOIN rhsFrom -- RHS Nothing -- ON - return (EPreprocessedFrom ret from_) + return (EPreprocessedFrom ret from') -- | (Internal) Finish a @JOIN@. fromFinish :: SqlExpr (PreprocessedFrom a) -> SqlQuery a -fromFinish (EPreprocessedFrom ret from_) = Q $ do - W.tell mempty { sdFromClause = [from_] } +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 } --- | @ON@ clause: restrict the a @JOIN@'s result. The @ON@ --- clause will be applied to the /last/ @JOIN@ that does not --- have an @ON@ clause yet. If there are no @JOIN@s without --- @ON@ clauses (either because you didn't do any @JOIN@, or --- because all @JOIN@s already have their own @ON@ clauses), a --- runtime exception 'OnClauseWithoutMatchingJoinException' is --- thrown. @ON@ clauses are optional when doing @JOIN@s. +-- | 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. -- --- On the simple case of doing just one @JOIN@, for example +-- 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 $ +-- 'select' $ -- 'from' $ \\(foo `'InnerJoin`` bar) -> do -- 'on' (foo '^.' FooId '==.' bar '^.' BarFooId) -- ... -- @ -- --- there's no ambiguity and the rules above just mean that --- you're allowed to call 'on' only once (as in SQL). If you --- have many joins, then the 'on's are applied on the /reverse/ --- order that the @JOIN@s appear. For example: +-- We need to specify the clause for joining the two columns together. If we had +-- this: -- -- @ --- select $ +-- '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) -- ... -- @ -- --- The order is /reversed/ in order to improve composability. --- For example, consider @query1@ and @query2@ below: +-- 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: -- -- @ --- let query1 = --- 'from' $ \\(foo `'InnerJoin`` bar) -> do --- 'on' (foo '^.' FooId '==.' bar '^.' BarFooId) --- query2 = --- 'from' $ \\(mbaz `'LeftOuterJoin`` quux) -> do --- return (mbaz '?.' BazName, quux) --- test1 = (,) \<$\> query1 \<*\> query2 --- test2 = flip (,) \<$\> query2 \<*\> query1 +-- 'select' $ +-- 'from' $ \\(foo `'InnerJoin`` bar `'InnerJoin`` baz) -> do +-- 'on' (foo '^.' FooId '==.' bar '^.' BarFooId) +-- 'on' (baz '^.' BazId '==.' bar '^.' BarBazId) +-- ... -- @ --- --- If the order was /not/ reversed, then @test2@ would be --- broken: @query1@'s 'on' would refer to @query2@'s --- 'LeftOuterJoin'. on :: SqlExpr (Value Bool) -> SqlQuery () on expr = Q $ W.tell mempty { sdFromClause = [OnClause expr] } @@ -339,12 +352,149 @@ 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 with = + subSelectUnsafe $ + from $ \table -> do + where_ $ expr ^. foreignKey ==. table ^. persistIdField + pure (with 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) @@ -1396,33 +1546,109 @@ -- | Collect 'OnClause's on 'FromJoin's. Returns the first -- unmatched 'OnClause's data on error. Returns a list without -- 'OnClauses' on success. -collectOnClauses :: [FromClause] -> Either (SqlExpr (Value Bool)) [FromClause] -collectOnClauses = go [] +collectOnClauses + :: SqlBackend + -> [FromClause] + -> Either (SqlExpr (Value Bool)) [FromClause] +collectOnClauses sqlBackend = go Set.empty [] where - go [] (f@(FromStart _ _):fs) = fmap (f:) (go [] fs) -- fast path - go acc (OnClause expr :fs) = findMatching acc expr >>= flip go fs - go acc (f:fs) = go (f:acc) fs - go acc [] = return $ reverse acc + 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 (f : acc) expr = - case tryMatch expr f of - Just f' -> return (f' : acc) - Nothing -> (f:) <$> findMatching acc expr - findMatching [] expr = Left expr + findMatching + :: Set Ident + -> [FromClause] + -> SqlExpr (Value Bool) + -> Either (SqlExpr (Value Bool)) (Set Ident, [FromClause]) + findMatching idents fromClauses expr = + 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 - tryMatch expr (FromJoin l k r onClause) = - matchR `mplus` matchC `mplus` matchL -- right to left - where - matchR = (\r' -> FromJoin l k r' onClause) <$> tryMatch expr r - matchL = (\l' -> FromJoin l' k r onClause) <$> tryMatch expr l - matchC = case onClause of - Nothing | k /= CrossJoinKind - -> return (FromJoin l k r (Just expr)) - | otherwise -> mzero - Just _ -> mzero - tryMatch _ _ = mzero + findRightmostIdent (FromStart i _) = Just i + findRightmostIdent (FromJoin _ _ r _) = findRightmostIdent r + findRightmostIdent (OnClause {}) = Nothing + findLeftmostIdent (FromStart i _) = Just i + findLeftmostIdent (FromJoin l _ _ _) = findLeftmostIdent l + findLeftmostIdent (OnClause {}) = 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 + i1 <- findLeftmostIdent l + i2 <- findRightmostIdent r + guard $ + Set.isSubsetOf + identsInOnClause + (Set.fromList [i1, i2]) + guard $ k /= CrossJoinKind + guard $ Maybe.isNothing onClause + pure (Set.fromList [] <> 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 @@ -1476,6 +1702,7 @@ -- | Identifier used for table names. newtype Ident = I T.Text + deriving (Eq, Ord, Show) -- | List of identifiers already in use and supply of temporary @@ -1489,24 +1716,18 @@ -- | Create a fresh 'Ident'. If possible, use the given -- 'DBName'. newIdentFor :: DBName -> SqlQuery Ident -newIdentFor = Q . lift . try . unDBName +newIdentFor (DBName original) = Q $ lift $ findFree Nothing where - try orig = do - s <- S.get - let go (t:ts) | t `HS.member` inUse s = go ts - | otherwise = use t - go [] = throw (UnexpectedCaseErr NewIdentForError) - go (possibilities orig) - - possibilities t = t : map addNum [2..] - where - addNum :: Int -> T.Text - addNum = T.append t . T.pack . show - - use t = do - S.modify (\s -> s { inUse = HS.insert t (inUse s) }) - return (I t) - + 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) @@ -1914,7 +2135,7 @@ -- @Value t@. You may use @Value@ to return projections of an -- @Entity@ (see @('^.')@ and @('?.')@) or to return any other -- value calculated on the query (e.g., 'countRows' or --- 'sub_select'). +-- 'subSelect'). -- -- The @SqlSelect a r@ class has functional dependencies that -- allow type information to flow both from @a@ to @r@ and @@ -2209,11 +2430,15 @@ plain v = (v, []) -makeFrom :: IdentInfo -> Mode -> [FromClause] -> (TLB.Builder, [PersistValue]) +makeFrom + :: IdentInfo + -> Mode + -> [FromClause] + -> (TLB.Builder, [PersistValue]) makeFrom _ _ [] = mempty makeFrom info mode fs = ret where - ret = case collectOnClauses fs of + ret = case collectOnClauses (fst info) fs of Left expr -> throw $ mkExc expr Right fs' -> keyword $ uncommas' (map (mk Never) fs') keyword = case mode of @@ -2932,3 +3157,33 @@ 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) + +-- | 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 diff --git a/src/Database/Esqueleto/Internal/Language.hs b/src/Database/Esqueleto/Internal/Language.hs --- a/src/Database/Esqueleto/Internal/Language.hs +++ b/src/Database/Esqueleto/Internal/Language.hs @@ -56,6 +56,12 @@ , in_, notIn, exists, notExists , set, (=.), (+=.), (-=.), (*=.), (/=.) , case_, toBaseId, (<#), (<&>) + , subSelect + , subSelectMaybe + , subSelectCount + , subSelectList + , subSelectForeign + , subSelectUnsafe ) where import Database.Esqueleto.Internal.PersistentImport diff --git a/src/Database/Esqueleto/Internal/Sql.hs b/src/Database/Esqueleto/Internal/Sql.hs --- a/src/Database/Esqueleto/Internal/Sql.hs +++ b/src/Database/Esqueleto/Internal/Sql.hs @@ -55,6 +55,7 @@ , Mode(..) , NeedParens(..) , IdentState + , renderExpr , initialIdentState , IdentInfo , SqlSelect(..) @@ -71,6 +72,7 @@ , parens , toArgList , builderToText + , Ident(..) ) where import Database.Esqueleto.Internal.Internal diff --git a/test/Common/Test.hs b/test/Common/Test.hs --- a/test/Common/Test.hs +++ b/test/Common/Test.hs @@ -1,7 +1,9 @@ -{-# OPTIONS_GHC -fno-warn-unused-binds #-} -{-# OPTIONS_GHC -fno-warn-deprecations #-} +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} {-# LANGUAGE ConstraintKinds , CPP + , TypeApplications + , PartialTypeSignatures , UndecidableInstances , EmptyDataDecls , FlexibleContexts @@ -55,7 +57,9 @@ , Unique(..) ) where +import Data.Either import Control.Monad (forM_, replicateM, replicateM_, void) +import Control.Monad.Reader (ask) import Control.Monad.Catch (MonadCatch) #if __GLASGOW_HASKELL__ >= 806 import Control.Monad.Fail (MonadFail) @@ -69,8 +73,8 @@ import Database.Persist.TH import Test.Hspec import UnliftIO +import qualified Data.Attoparsec.Text as AP -import Database.Persist (PersistValue(..)) import Data.Conduit (ConduitT, (.|), runConduit) import qualified Data.Conduit.List as CL import qualified Data.List as L @@ -80,16 +84,17 @@ 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 Person name String @@ -101,6 +106,18 @@ title String authorId PersonId deriving Eq Show + Comment + body String + blog BlogPostId + deriving Eq Show + Profile + name String + person PersonId + deriving Eq Show + Reply + guy PersonId + body String + deriving Eq Show Lord county String maxlen=100 @@ -160,6 +177,36 @@ Numbers int Int double Double + deriving Eq Show + + JoinOne + name String + deriving Eq Show + + JoinTwo + joinOne JoinOneId + name String + deriving Eq Show + + JoinThree + joinTwo JoinTwoId + name String + deriving Eq Show + + JoinFour + name String + joinThree JoinThreeId + deriving Eq Show + + JoinOther + name String + deriving Eq Show + + JoinMany + name String + joinOther JoinOtherId + joinOne JoinOneId + deriving Eq Show |] -- Unique Test schema @@ -242,7 +289,180 @@ 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 @@ -317,6 +537,7 @@ , (p2e, p1e) , (p2e, p2e) ] + it "works for a self-join via sub_select" $ run $ do p1k <- insert p1 @@ -447,7 +668,7 @@ testSelectJoin :: Run -> Spec testSelectJoin run = do - describe "select/JOIN" $ do + describe "select:JOIN" $ do it "works with a LEFT OUTER JOIN" $ run $ do p1e <- insert' p1 @@ -604,11 +825,9 @@ return p liftIO $ (entityVal <$> ps) `shouldBe` [p1] - - testSelectWhere :: Run -> Spec testSelectWhere run = do - describe "select/where_" $ do + describe "select where_" $ do it "works for a simple example with (==.)" $ run $ do p1e <- insert' p1 @@ -828,6 +1047,17 @@ , (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 @@ -1461,7 +1691,7 @@ liftIO $ (n :: Int) `shouldBe` expected testRenderSql :: Run -> Spec -testRenderSql run = +testRenderSql run = do describe "testRenderSql" $ do it "works" $ do (queryText, queryVals) <- run $ renderQuerySelect $ @@ -1481,12 +1711,457 @@ `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 + + + +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 @@ -1503,6 +2178,7 @@ testCase run testCountingRows run testRenderSql run + testOnClauseOrder run insert' :: ( Functor m @@ -1535,12 +2211,15 @@ :: (forall m. RunDbMonad m => SqlPersistT (R.ResourceT m) ()) cleanDB = do - delete $ from $ \(_ :: SqlExpr (Entity Foo)) -> return () delete $ from $ \(_ :: SqlExpr (Entity Bar)) -> return () + delete $ from $ \(_ :: SqlExpr (Entity Foo)) -> return () - delete $ from $ \(_ :: SqlExpr (Entity BlogPost)) -> return () - delete $ from $ \(_ :: SqlExpr (Entity Follow)) -> return () - delete $ from $ \(_ :: SqlExpr (Entity Person)) -> 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 () @@ -1557,6 +2236,12 @@ delete $ from $ \(_ :: SqlExpr (Entity Point)) -> return () delete $ from $ \(_ :: SqlExpr (Entity Numbers)) -> return () + delete $ from $ \(_ :: SqlExpr (Entity JoinMany)) -> return () + delete $ from $ \(_ :: SqlExpr (Entity JoinFour)) -> return () + delete $ from $ \(_ :: SqlExpr (Entity JoinThree)) -> return () + delete $ from $ \(_ :: SqlExpr (Entity JoinTwo)) -> return () + delete $ from $ \(_ :: SqlExpr (Entity JoinOne)) -> return () + delete $ from $ \(_ :: SqlExpr (Entity JoinOther)) -> return () cleanUniques @@ -1564,3 +2249,13 @@ => 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 diff --git a/test/PostgreSQL/Test.hs b/test/PostgreSQL/Test.hs --- a/test/PostgreSQL/Test.hs +++ b/test/PostgreSQL/Test.hs @@ -958,10 +958,10 @@ 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.", + sqlState = "23505", + sqlExecStatus = FatalError, + sqlErrorMsg = "duplicate key value violates unique constraint \"UniqueValue\"", + sqlErrorDetail = "Key (value)=(0) already exists.", sqlErrorHint = ""} testUpsert :: Spec