diff --git a/esqueleto.cabal b/esqueleto.cabal --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -1,5 +1,5 @@ name: esqueleto -version: 2.1.2.3 +version: 2.1.3 synopsis: Type-safe EDSL for SQL queries on persistent backends. homepage: https://github.com/prowdsponsor/esqueleto license: BSD3 @@ -64,9 +64,9 @@ other-modules: Database.Esqueleto.Internal.PersistentImport build-depends: - base >= 4.5 && < 4.9 - , text >= 0.11 && < 1.3 - , persistent >= 2.1 && < 2.2 + base >= 4.5 && < 4.9 + , text >= 0.11 && < 1.3 + , persistent >= 2.1.1.7 && < 2.2 , transformers >= 0.2 , unordered-containers >= 0.2 , tagged >= 0.2 diff --git a/src/Database/Esqueleto.hs b/src/Database/Esqueleto.hs --- a/src/Database/Esqueleto.hs +++ b/src/Database/Esqueleto.hs @@ -44,7 +44,7 @@ , (==.), (>=.), (>.), (<=.), (<.), (!=.), (&&.), (||.) , (+.), (-.), (/.), (*.) , random_, round_, ceiling_, floor_ - , min_, max_, sum_, avg_ + , min_, max_, sum_, avg_, lower_ , coalesce, coalesceDefault , like, (%), concat_, (++.) , subList_select, subList_selectDistinct, valList 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 @@ -255,6 +255,7 @@ min_ :: (PersistField a) => expr (Value a) -> expr (Value (Maybe a)) max_ :: (PersistField a) => expr (Value a) -> expr (Value (Maybe a)) avg_ :: (PersistField a, PersistField b) => expr (Value a) -> expr (Value (Maybe b)) + lower_ :: (PersistField a, IsString a) => expr (Value a) -> expr (Value a) -- | @COALESCE@ function. Evaluates the arguments in order and -- returns the value of the first non-NULL expression, or NULL 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 @@ -7,6 +7,8 @@ , MultiParamTypeClasses , OverloadedStrings , UndecidableInstances + , ScopedTypeVariables + , InstanceSigs #-} -- | This is an internal module, anything exported by this module -- may change without a major version bump. Please use only @@ -29,6 +31,7 @@ -- * The guts , unsafeSqlCase , unsafeSqlBinOp + , unsafeSqlBinOpList , unsafeSqlValue , unsafeSqlFunction , unsafeSqlExtractSubField @@ -58,6 +61,9 @@ import Data.Monoid (Monoid(..), (<>)) import Data.Proxy (Proxy(..)) import Database.Esqueleto.Internal.PersistentImport +import Database.Persist.Sql.Util ( + entityColumnNames, entityColumnCount, parseEntityValues, isIdField + , hasCompositeKey) import qualified Control.Monad.Trans.State as S import qualified Control.Monad.Trans.Writer as W import qualified Data.Conduit as C @@ -226,7 +232,7 @@ -- | Information needed to escape and use identifiers. -type IdentInfo = (Connection, IdentState) +type IdentInfo = (SqlBackend, IdentState) -- | Use an identifier. @@ -252,6 +258,9 @@ -- interpolated by the SQL backend. ERaw :: NeedParens -> (IdentInfo -> (TLB.Builder, [PersistValue])) -> SqlExpr (Value a) + -- Used to support non-id/composite primary keys + ERawList :: (IdentInfo -> ([TLB.Builder], [PersistValue])) -> SqlExpr (Value a) + -- 'EList' and 'EEmptyList' are used by list operators. EList :: SqlExpr (Value a) -> SqlExpr (ValueList a) EEmptyList :: SqlExpr (ValueList a) @@ -333,33 +342,50 @@ sub_select = sub SELECT sub_selectDistinct = sub SELECT_DISTINCT - EEntity ident ^. field = - ERaw Never $ \info -> (useIdent info ident <> ("." <> fieldName info field), []) + (^.) :: forall val typ. (PersistEntity val, PersistField typ) + => SqlExpr (Entity val) -> EntityField val typ -> SqlExpr (Value typ) + EEntity ident ^. field + | isComposite = ERawList $ \info -> (dot info <$> compositeFields pdef, []) + | otherwise = ERaw Never $ \info -> (dot info $ persistFieldDef field, []) + where + isComposite = isIdField field && hasCompositeKey ed + dot info x = useIdent info ident <> "." <> fromDBName info (fieldDB x) + ed = entityDef $ getEntityVal (Proxy :: Proxy (SqlExpr (Entity val))) + Just pdef = entityPrimary ed EMaybe r ?. field = maybelize (r ^. field) where maybelize :: SqlExpr (Value a) -> SqlExpr (Value (Maybe a)) - maybelize (ERaw p f) = ERaw p f + maybelize (ERaw p f) = ERaw p f + maybelize (ERawList f) = ERawList f - val = ERaw Never . const . (,) "?" . return . toPersistValue + val v = + case toPersistValue v of + PersistList vs -> ERawList $ const (replicate (length vs) "?", vs) + pv -> ERaw Never $ const ("?", [pv]) - isNothing (ERaw p f) = ERaw Parens $ first ((<> " IS NULL") . parensM p) . f - just (ERaw p f) = ERaw p f - nothing = unsafeSqlValue "NULL" - joinV (ERaw p f) = ERaw p f + isNothing (ERaw p f) = ERaw Parens $ first ((<> " IS NULL") . parensM p) . f + isNothing (ERawList f) = ERaw Parens $ first (intersperseB " AND " . map (<> " IS NULL")) . f + just (ERaw p f) = ERaw p f + just (ERawList f) = ERawList f + nothing = unsafeSqlValue "NULL" + joinV (ERaw p f) = ERaw p f + joinV (ERawList f) = ERawList f countRows = unsafeSqlValue "COUNT(*)" count (ERaw _ f) = ERaw Never $ \info -> let (b, vals) = f info in ("COUNT" <> parens b, vals) + count (ERawList _) = unsafeSqlValue "COUNT(*)" -- Assumes no NULLs on a PK not_ (ERaw p f) = ERaw Never $ \info -> let (b, vals) = f info in ("NOT " <> parensM p b, vals) + not_ (ERawList _) = unexpectedCompositeKeyError - (==.) = unsafeSqlBinOp " = " + (==.) = unsafeSqlBinOpList " = " " AND " + (!=.) = unsafeSqlBinOpList " != " " OR " (>=.) = unsafeSqlBinOp " >= " (>.) = unsafeSqlBinOp " > " (<=.) = unsafeSqlBinOp " <= " (<.) = unsafeSqlBinOp " < " - (!=.) = unsafeSqlBinOp " != " (&&.) = unsafeSqlBinOp " AND " (||.) = unsafeSqlBinOp " OR " (+.) = unsafeSqlBinOp " + " @@ -368,16 +394,18 @@ (*.) = unsafeSqlBinOp " * " random_ = unsafeSqlValue "RANDOM()" - sum_ = unsafeSqlFunction "SUM" round_ = unsafeSqlFunction "ROUND" ceiling_ = unsafeSqlFunction "CEILING" floor_ = unsafeSqlFunction "FLOOR" - avg_ = unsafeSqlFunction "AVG" + + sum_ = unsafeSqlFunction "SUM" min_ = unsafeSqlFunction "MIN" max_ = unsafeSqlFunction "MAX" + avg_ = unsafeSqlFunction "AVG" + lower_ = unsafeSqlFunction "LOWER" - coalesce = unsafeSqlFunction "COALESCE" - coalesceDefault exprs = unsafeSqlFunction "COALESCE" . (exprs ++) . return . just + coalesce = unsafeSqlFunctionParens "COALESCE" + coalesceDefault exprs = unsafeSqlFunctionParens "COALESCE" . (exprs ++) . return . just like = unsafeSqlBinOp " LIKE " (%) = unsafeSqlValue "'%'" @@ -407,12 +435,14 @@ field *=. expr = setAux field (\ent -> ent ^. field *. expr) field /=. expr = setAux field (\ent -> ent ^. field /. expr) - (<#) _ (ERaw _ f) = EInsert Proxy f + (<#) _ (ERaw _ f) = EInsert Proxy f + (<#) _ (ERawList _) = unexpectedCompositeKeyError (EInsert _ f) <&> (ERaw _ g) = EInsert Proxy $ \x -> let (fb, fv) = f x (gb, gv) = g x in (fb <> ", " <> gb, fv ++ gv) + (EInsert _ _) <&> (ERawList _) = unexpectedCompositeKeyError case_ = unsafeSqlCase @@ -423,6 +453,7 @@ => 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)) @@ -454,23 +485,25 @@ -- -- Since: 2.1.1 unsafeSqlCase :: PersistField a => [(SqlExpr (Value Bool), SqlExpr (Value a))] -> SqlExpr (Value a) -> SqlExpr (Value a) -unsafeSqlCase when_ (ERaw p1 f1) = ERaw Never buildCase +unsafeSqlCase when (ERaw p1 f1) = ERaw Never buildCase where buildCase :: IdentInfo -> (TLB.Builder, [PersistValue]) buildCase info = let (b1, vals1) = f1 info - (b2, vals2) = mapWhen when_ info + (b2, vals2) = mapWhen when info in ( "CASE" <> b2 <> " ELSE " <> parensM p1 b1 <> " END", vals2 <> vals1) mapWhen :: [(SqlExpr (Value Bool), SqlExpr (Value a))] -> IdentInfo -> (TLB.Builder, [PersistValue]) - mapWhen [] _ = error "unsafeSqlCase: empty when_ list." - mapWhen when_ info = foldl (foldHelp info) (mempty, mempty) when_ + mapWhen [] _ = error "unsafeSqlCase: empty when list." + mapWhen when' info = foldl (foldHelp info) (mempty, mempty) when' foldHelp :: IdentInfo -> (TLB.Builder, [PersistValue]) -> (SqlExpr (Value Bool), SqlExpr (Value a)) -> (TLB.Builder, [PersistValue]) - foldHelp info (b0, vals0) (ERaw p1 f1, ERaw p2 f2) = - let (b1, vals1) = f1 info + foldHelp info (b0, vals0) (ERaw p1' f1', ERaw p2 f2) = + let (b1, vals1) = f1' info (b2, vals2) = f2 info - in ( b0 <> " WHEN " <> parensM p1 b1 <> " THEN " <> parensM p2 b2, vals0 <> vals1 <> vals2 ) + in ( b0 <> " WHEN " <> parensM p1' b1 <> " THEN " <> parensM p2 b2, vals0 <> vals1 <> vals2 ) + foldHelp _ _ _ = unexpectedCompositeKeyError +unsafeSqlCase _ (ERawList _) = unexpectedCompositeKeyError -- | (Internal) Create a custom binary operator. You /should/ @@ -492,9 +525,36 @@ (b2, vals2) = f2 info in ( parensM p1 b1 <> op <> parensM p2 b2 , vals1 <> vals2 ) +unsafeSqlBinOp _ _ _ = unexpectedCompositeKeyError {-# 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) +-- (==.) = unsafeSqlBinOpList " = " " AND " +-- @ +unsafeSqlBinOpList :: TLB.Builder -> TLB.Builder -> SqlExpr (Value a) -> SqlExpr (Value b) -> SqlExpr (Value c) +unsafeSqlBinOpList op _ a@(ERaw _ _) b@(ERaw _ _) = unsafeSqlBinOp op a b +unsafeSqlBinOpList op sep (ERawList f1) (ERawList f2) = ERaw Never f + where + f info = let (b1, vals1) = f1 info + (b2, vals2) = f2 info + in ( intersperseB sep . map (\(a,b) -> a <> op <> b) $ + zip b1 b2 + , vals1 <> vals2 ) +unsafeSqlBinOpList op sep a b = unsafeSqlBinOpList op sep (promote a) (promote b) + where + promote :: SqlExpr (Value d) -> SqlExpr (Value d) + promote (ERaw p f) = ERawList $ first (return . parensM p) . f + promote x@(ERawList _) = x +{-# INLINE unsafeSqlBinOpList #-} + -- | (Internal) A raw SQL value. The same warning from -- 'unsafeSqlBinOp' applies to this function as well. unsafeSqlValue :: TLB.Builder -> SqlExpr (Value a) @@ -524,7 +584,17 @@ uncommas' $ map (\(ERaw _ f) -> f info) $ toArgList arg in ("EXTRACT" <> parens (subField <> " FROM " <> argsTLB), argsVals) +-- | (Internal) A raw SQL function. Preserves parentheses around arguments. +-- See 'unsafeSqlBinOp' for warnings. +unsafeSqlFunctionParens :: UnsafeSqlFunctionArgument a => + TLB.Builder -> a -> SqlExpr (Value b) +unsafeSqlFunctionParens name arg = + ERaw Never $ \info -> + let (argsTLB, argsVals) = + uncommas' $ map (\(ERaw p f) -> first (parensM p) (f info)) $ toArgList arg + in (name <> parens argsTLB, argsVals) + class UnsafeSqlFunctionArgument a where toArgList :: a -> [SqlExpr (Value ())] instance (a ~ Value b) => UnsafeSqlFunctionArgument (SqlExpr a) where @@ -555,6 +625,7 @@ -- unless you know what you're doing! veryUnsafeCoerceSqlExprValue :: SqlExpr (Value a) -> SqlExpr (Value b) veryUnsafeCoerceSqlExprValue (ERaw p f) = ERaw p f +veryUnsafeCoerceSqlExprValue (ERawList f) = ERawList f -- | (Internal) Coerce a value's type from 'SqlExpr (ValueList @@ -829,8 +900,11 @@ uncommas :: [TLB.Builder] -> TLB.Builder -uncommas = mconcat . intersperse ", " . filter (/= mempty) +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 @@ -887,24 +961,30 @@ fromKind RightOuterJoinKind = " RIGHT OUTER JOIN " fromKind FullOuterJoinKind = " FULL OUTER JOIN " - makeOnClause (ERaw _ f) = first (" ON " <>) (f info) + makeOnClause (ERaw _ f) = first (" ON " <>) (f info) + makeOnClause (ERawList _) = unexpectedCompositeKeyError mkExc :: SqlExpr (Value Bool) -> OnClauseWithoutMatchingJoinException mkExc (ERaw _ f) = OnClauseWithoutMatchingJoinException $ TL.unpack $ TLB.toLazyText $ fst (f info) + mkExc (ERawList _) = unexpectedCompositeKeyError +unexpectedCompositeKeyError :: a +unexpectedCompositeKeyError = error "non-id/composite keys not expected here" + makeSet :: IdentInfo -> [SetClause] -> (TLB.Builder, [PersistValue]) makeSet _ [] = mempty -makeSet info os = first ("\nSET " <>) $ uncommas' (map mk os) +makeSet info os = first ("\nSET " <>) . uncommas' $ concatMap mk os where - mk (SetClause (ERaw _ f)) = f info - + mk (SetClause (ERaw _ f)) = [f info] + mk (SetClause (ERawList _)) = error "esqueleto/makeSet: FIXME" makeWhere :: IdentInfo -> WhereClause -> (TLB.Builder, [PersistValue]) -makeWhere _ NoWhere = mempty -makeWhere info (Where (ERaw _ f)) = first ("\nWHERE " <>) (f info) +makeWhere _ NoWhere = mempty +makeWhere info (Where (ERaw _ f)) = first ("\nWHERE " <>) (f info) +makeWhere _ (Where (ERawList _)) = unexpectedCompositeKeyError makeGroupBy :: IdentInfo -> GroupByClause -> (TLB.Builder, [PersistValue]) @@ -914,22 +994,26 @@ build = uncommas' $ map (\(SomeValue (ERaw _ f)) -> f info) fields makeHaving :: IdentInfo -> WhereClause -> (TLB.Builder, [PersistValue]) -makeHaving _ NoWhere = mempty -makeHaving info (Where (ERaw _ f)) = first ("\nHAVING " <>) (f info) +makeHaving _ NoWhere = mempty +makeHaving info (Where (ERaw _ f)) = first ("\nHAVING " <>) (f info) +makeHaving _ (Where (ERawList _ )) = unexpectedCompositeKeyError makeOrderBy :: IdentInfo -> [OrderByClause] -> (TLB.Builder, [PersistValue]) makeOrderBy _ [] = mempty -makeOrderBy info os = first ("\nORDER BY " <>) $ uncommas' (map mk os) +makeOrderBy info os = first ("\nORDER BY " <>) . uncommas' $ concatMap mk os where - mk :: OrderByClause -> (TLB.Builder, [PersistValue]) - mk (EOrderBy t (ERaw p f)) = first ((<> orderByType t) . parensM p) (f info) - mk EOrderRandom = first ((<> "RANDOM()")) mempty + mk :: OrderByClause -> [(TLB.Builder, [PersistValue])] + mk (EOrderBy t (ERaw p f)) = [first ((<> orderByType t) . parensM p) (f info)] + mk (EOrderBy t (ERawList f)) = let fs = fst $ f info + vals = repeat [] + in zip (map (<> orderByType t) fs) vals + mk EOrderRandom = [first ((<> "RANDOM()")) mempty] orderByType ASC = " ASC" orderByType DESC = " DESC" makeLimit :: IdentInfo -> LimitClause -> [OrderByClause] -> (TLB.Builder, [PersistValue]) -makeLimit (conn,_) (Limit ml mo) orderByClauses = +makeLimit (conn, _) (Limit ml mo) orderByClauses = let limitRaw = connLimitOffset conn (v ml, v mo) hasOrderClause "\n" hasOrderClause = not (null orderByClauses) v = maybe 0 fromIntegral @@ -994,10 +1078,8 @@ sqlSelectCols info expr@(EEntity ident) = ret where process ed = uncommas $ - map ((name <>) . fromDBName info) $ - map fieldDB $ - entityId ed : - entityFields ed + 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 @@ -1007,12 +1089,11 @@ name = useIdent info ident <> "." ret = let ed = entityDef $ getEntityVal $ return expr in (process ed, mempty) - sqlSelectColCount = (+1) . length . entityFields . entityDef . getEntityVal - sqlSelectProcessRow (idCol:ent) = - Entity <$> fromPersistValue idCol - <*> fromPersistValues ent - sqlSelectProcessRow _ = Left "SqlSelect (Entity a): wrong number of columns." + 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 @@ -1034,6 +1115,10 @@ instance PersistField a => SqlSelect (SqlExpr (Value a)) (Value a) where sqlSelectCols info (ERaw p f) = let (b, vals) = f info in (parensM p b, vals) + sqlSelectCols info (ERawList f) = let (b, vals) = f info + in case b of + [b'] -> (parensM Parens b', vals) + _ -> unexpectedCompositeKeyError sqlSelectColCount = const 1 sqlSelectProcessRow [pv] = Value <$> fromPersistValue pv sqlSelectProcessRow _ = Left "SqlSelect (Value a): wrong number of columns." diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -1,6 +1,8 @@ {-# LANGUAGE ConstraintKinds , EmptyDataDecls , FlexibleContexts + , FlexibleInstances + , DeriveGeneric , GADTs , GeneralizedNewtypeDeriving , MultiParamTypeClasses @@ -44,6 +46,7 @@ import qualified Control.Monad.Trans.Resource as R import qualified Data.Set as S import qualified Data.List as L +import Data.Char (toLower, toUpper) -- Test schema @@ -62,6 +65,41 @@ follower PersonId followed PersonId deriving Eq Show + Frontcover + number Int + title String + Primary number + deriving Eq Show + Article + title String + frontcoverNumber Int + Foreign Frontcover fkfrontcover frontcoverNumber + deriving Eq Show + Tag + name String + Primary name + deriving Eq Show + ArticleTag + articleId ArticleId + tagId TagId + Primary articleId tagId + deriving Eq Show + Article2 + title String + frontcoverId FrontcoverId + deriving Eq Show + Point + x Int + y Int + name String + Primary x y + deriving Eq Show + Circle + centerX Int + centerY Int + name String + Foreign Point fkpoint centerX centerY + deriving Eq Show |] -- | this could be achieved with S.fromList, but not all lists @@ -224,7 +262,39 @@ 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" $ + pendingWith "Need to refactor 'Value a's SqlQuery instance" + {- + run $ do + let p = Point 10 20 "" + thePk <- insert p + [Value ppk] <- select $ from $ \p' -> return (p'^.PointId) + liftIO $ ppk `shouldBe` thePk + -} + + describe "select/JOIN" $ do it "works with a LEFT OUTER JOIN" $ run $ do @@ -279,6 +349,96 @@ return (p, mb) ) `shouldThrow` (\(OnClauseWithoutMatchingJoinException _) -> True) + it "works with ForeignKey to a non-id primary key returning one entity" $ + run $ do + let fc = Frontcover number "" + article = Article "Esqueleto supports composite pks!" number + number = 101 + Right thePk = keyFromValues [toPersistValue number] + fcPk <- insert fc + insert_ article + [Entity _ retFc] <- select $ + from $ \(a `InnerJoin` f) -> do + on (f^.FrontcoverNumber ==. a^.ArticleFrontcoverNumber) + return f + liftIO $ do + retFc `shouldBe` fc + fcPk `shouldBe` thePk + + it "works with a ForeignKey to a non-id primary key returning both entities" $ + run $ do + let fc = Frontcover number "" + article = Article "Esqueleto supports composite pks!" number + number = 101 + Right thePk = keyFromValues [toPersistValue number] + fcPk <- insert fc + insert_ article + [(Entity _ retFc, Entity _ retArt)] <- select $ + from $ \(a `InnerJoin` f) -> do + on (f^.FrontcoverNumber ==. a^.ArticleFrontcoverNumber) + return (f, a) + liftIO $ do + retFc `shouldBe` fc + retArt `shouldBe` article + fcPk `shouldBe` thePk + articleFkfrontcover retArt `shouldBe` thePk + + it "works with a non-id primary key returning one entity" $ + run $ do + let fc = Frontcover number "" + article = Article2 "Esqueleto supports composite pks!" thePk + number = 101 + Right thePk = keyFromValues [toPersistValue number] + fcPk <- insert fc + insert_ article + [Entity _ retFc] <- select $ + from $ \(a `InnerJoin` f) -> do + on (f^.FrontcoverId ==. a^.Article2FrontcoverId) + return f + liftIO $ do + retFc `shouldBe` fc + fcPk `shouldBe` thePk + + it "works with a composite primary key" $ + pendingWith "Persistent does not create the CircleFkPoint constructor. See: https://github.com/yesodweb/persistent/issues/341" + {- + run $ do + let p = Point x y "" + c = Circle x y "" + x = 10 + y = 15 + Right thePk = keyFromValues [toPersistValue x, toPersistValue y] + pPk <- insert p + insert_ c + [Entity _ ret] <- select $ from $ \(c' `InnerJoin` p') -> do + on (p'^.PointId ==. c'^.CircleFkpoint) + return p' + liftIO $ do + ret `shouldBe` p + pPk `shouldBe` thePk + -} + + it "works when joining via a non-id primary key" $ + run $ do + let fc = Frontcover number "" + article = Article "Esqueleto supports composite pks!" number + tag = Tag "foo" + otherTag = Tag "ignored" + number = 101 + insert_ fc + insert_ otherTag + artId <- insert article + tagId <- insert tag + insert_ $ ArticleTag artId tagId + [(Entity _ retArt, Entity _ retTag)] <- select $ + from $ \(a `InnerJoin` at `InnerJoin` t) -> do + on (t^.TagId ==. at^.ArticleTagTagId) + on (a^.ArticleId ==. at^.ArticleTagArticleId) + return (a, t) + liftIO $ do + retArt `shouldBe` article + retTag `shouldBe` tag + describe "select/where_" $ do it "works for a simple example with (==.)" $ run $ do @@ -374,6 +534,25 @@ 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' + ret <- select $ + from $ \p-> do + where_ (lower_ (p ^. PersonName) ==. val (map toLower $ personName p1)) + return p + liftIO $ ret `shouldBe` [ p1e ] + + -- name == lower('BOB') + ret <- select $ + from $ \p-> do + where_ (p ^. PersonName ==. lower_ (val $ map toUpper $ personName bob)) + return p + liftIO $ ret `shouldBe` [ p2e ] + it "works with random_" $ run $ do #if defined(WITH_POSTGRESQL) || defined(WITH_MYSQL) @@ -476,7 +655,21 @@ , (p3e, Nothing, Nothing) , (p2e, Just f21, Just p1e) ] + it "works with a composite primary key" $ + run $ do + let p = Point x y "" + x = 10 + y = 15 + Right thePk = keyFromValues [toPersistValue x, toPersistValue y] + pPk <- insert p + [Entity _ ret] <- select $ from $ \p' -> do + where_ (p'^.PointId ==. val pPk) + return p' + liftIO $ do + ret `shouldBe` p + pPk `shouldBe` thePk + describe "select/orderBy" $ do it "works with a single ASC field" $ run $ do @@ -555,7 +748,17 @@ -- is 1/2^40, so this test should pass almost everytime. liftIO $ S.size rets `shouldSatisfy` (>2) + it "works on a composite primary key" $ + run $ do + let ps = [Point 2 1 "", Point 1 2 ""] + mapM_ insert ps + eps <- select $ + from $ \p' -> do + orderBy [asc (p'^.PointId)] + return p' + liftIO $ map entityVal eps `shouldBe` reverse ps + describe "selectDistinct" $ it "works on a simple example" $ run $ do @@ -595,6 +798,28 @@ , Value 5 ] + it "works with sub-queries" $ + run $ do + p1id <- insert p1 + p2id <- insert p2 + p3id <- insert p3 + _ <- insert p4 + _ <- insert p5 + _ <- insert $ BlogPost "a" p1id + _ <- insert $ BlogPost "b" p2id + _ <- insert $ BlogPost "c" p3id + ret <- select $ + from $ \b -> do + let sub = + from $ \p -> do + where_ (p ^. PersonId ==. b ^. BlogPostAuthorId) + return $ p ^. PersonAge + return $ coalesceDefault [sub_select sub] (val (42 :: Int)) + liftIO $ ret `shouldBe` [ Value (36 :: Int) + , Value 42 + , Value 17 + ] + #if defined(WITH_POSTGRESQL) || defined(WITH_MYSQL) it "works on PostgreSQL and MySQL with <2 arguments" $ run $ do @@ -712,6 +937,24 @@ 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