diff --git a/esqueleto.cabal b/esqueleto.cabal --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -1,5 +1,5 @@ name: esqueleto -version: 1.3.3 +version: 1.3.4 synopsis: Bare bones, type-safe EDSL for SQL queries on persistent backends. homepage: https://github.com/meteficha/esqueleto license: BSD3 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 @@ -27,6 +27,7 @@ , OnClauseWithoutMatchingJoinException(..) , OrderBy , Update + , Insertion -- * The guts , JoinKind(..) , IsJoinKind(..) @@ -307,7 +308,13 @@ (*=.) :: (PersistEntity val, PersistField a) => EntityField val a -> expr (Value a) -> expr (Update val) (/=.) :: (PersistEntity val, PersistField a) => EntityField val a -> expr (Value a) -> expr (Update val) + -- | Apply a 'PersistField' constructor to @expr Value@ arguments. + (<#) :: (a -> b) -> expr (Value a) -> expr (Insertion b) + -- | Apply extra @expr Value@ arguments to a 'PersistField' constructor + (<&>) :: expr (Insertion (a -> b)) -> expr (Value a) -> expr (Insertion b) + + -- Fixity declarations infixl 9 ^. infixl 7 *., /. @@ -490,6 +497,10 @@ -- | 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 -- | @FROM@ clause: bring entities into scope. 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 @@ -23,6 +23,8 @@ , deleteCount , update , updateCount + , insertSelectDistinct + , insertSelect -- * The guts , unsafeSqlBinOp , unsafeSqlValue @@ -33,12 +35,11 @@ , rawEsqueleto , toRawSql , Mode(..) + , IdentState + , initialIdentState + , IdentInfo , SqlSelect , veryUnsafeCoerceSqlExprValue - , insertSelectDistinct - , insertSelect - , (<#) - , (<&>) ) where import Control.Applicative (Applicative(..), (<$>), (<$)) @@ -221,27 +222,49 @@ return (I t) +-- | Information needed to escape and use identifiers. +type IdentInfo = (Connection, IdentState) + + -- | Use an identifier. -useIdent :: Connection -> Ident -> TLB.Builder -useIdent conn (I ident) = fromDBName conn $ DBName ident +useIdent :: IdentInfo -> Ident -> TLB.Builder +useIdent info (I ident) = fromDBName info $ DBName ident ---------------------------------------------------------------------- -type Insertion = Proxy -- | An expression on the SQL backend. data SqlExpr a where - EInsert :: Proxy a -> (Connection -> (TLB.Builder, [PersistValue])) -> SqlExpr (Insertion a) + -- | An entity, created by 'from' (cf. 'fromStart'). EEntity :: Ident -> SqlExpr (Entity val) + + -- | Just a tag stating that something is nullable. EMaybe :: SqlExpr a -> SqlExpr (Maybe a) - ERaw :: NeedParens -> (Connection -> (TLB.Builder, [PersistValue])) -> SqlExpr (Value a) - EList :: SqlExpr (Value a) -> SqlExpr (ValueList 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) + + -- | '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 - ESet :: (SqlExpr (Entity val) -> SqlExpr (Value ())) -> SqlExpr (Update val) + + -- | 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) + data NeedParens = Parens | Never parensM :: NeedParens -> TLB.Builder -> TLB.Builder @@ -301,7 +324,7 @@ sub_selectDistinct = sub SELECT_DISTINCT EEntity ident ^. field = - ERaw Never $ \conn -> (useIdent conn ident <> ("." <> fieldName conn field), []) + ERaw Never $ \info -> (useIdent info ident <> ("." <> fieldName info field), []) EMaybe r ?. field = maybelize (r ^. field) where @@ -315,10 +338,10 @@ nothing = unsafeSqlValue "NULL" joinV (ERaw p f) = ERaw p f countRows = unsafeSqlValue "COUNT(*)" - count (ERaw _ f) = ERaw Never $ \conn -> let (b, vals) = f conn + count (ERaw _ f) = ERaw Never $ \info -> let (b, vals) = f info in ("COUNT" <> parens b, vals) - not_ (ERaw p f) = ERaw Never $ \conn -> let (b, vals) = f conn + not_ (ERaw p f) = ERaw Never $ \info -> let (b, vals) = f info in ("NOT " <> parensM p b, vals) (==.) = unsafeSqlBinOp " = " @@ -371,32 +394,39 @@ field *=. expr = setAux field (\ent -> ent ^. field *. expr) field /=. expr = setAux field (\ent -> ent ^. field /. expr) + (<#) _ (ERaw _ f) = EInsert Proxy f + (EInsert _ f) <&> (ERaw _ g) = EInsert Proxy $ \x -> + let (fb, fv) = f x + (gb, gv) = g x + in (fb <> ", " <> gb, fv ++ gv) + + instance ToSomeValues SqlExpr (SqlExpr (Value a)) where toSomeValues a = [SomeValue a] fieldName :: (PersistEntity val, PersistField typ) - => Connection -> EntityField val typ -> TLB.Builder -fieldName conn = fromDBName conn . fieldDB . persistFieldDef + => IdentInfo -> EntityField val typ -> TLB.Builder +fieldName info = fromDBName info . fieldDB . persistFieldDef 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 $ \conn -> (fieldName conn field, mempty) + 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 $ \conn -> toRawSql mode pureQuery conn query +sub mode query = ERaw Parens $ \info -> toRawSql mode pureQuery info query -fromDBName :: Connection -> DBName -> TLB.Builder -fromDBName conn = TLB.fromText . connEscapeName conn +fromDBName :: IdentInfo -> DBName -> TLB.Builder +fromDBName (conn, _) = TLB.fromText . connEscapeName conn -existsHelper :: SqlQuery () -> SqlExpr (Value a) -existsHelper = - ERaw Parens . - flip (toRawSql SELECT pureQuery) . - (>> return (val True :: SqlExpr (Value Bool))) +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 @@ -421,8 +451,8 @@ 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 conn = let (b1, vals1) = f1 conn - (b2, vals2) = f2 conn + f info = let (b1, vals1) = f1 info + (b2, vals2) = f2 info in ( parensM p1 b1 <> op <> parensM p2 b2 , vals1 <> vals2 ) {-# INLINE unsafeSqlBinOp #-} @@ -440,9 +470,9 @@ unsafeSqlFunction :: UnsafeSqlFunctionArgument a => TLB.Builder -> a -> SqlExpr (Value b) unsafeSqlFunction name arg = - ERaw Never $ \conn -> + ERaw Never $ \info -> let (argsTLB, argsVals) = - uncommas' $ map (\(ERaw _ f) -> f conn) $ toArgList arg + uncommas' $ map (\(ERaw _ f) -> f info) $ toArgList arg in (name <> parens argsTLB, argsVals) class UnsafeSqlFunctionArgument a where @@ -504,7 +534,7 @@ run conn = uncurry rawQuery $ first builderToText $ - toRawSql mode pureQuery conn query + toRawSql mode pureQuery (conn, initialIdentState) query massage = do mrow <- C.await @@ -616,7 +646,7 @@ conn <- SqlPersistT R.ask uncurry rawExecuteCount $ first builderToText $ - toRawSql mode pureQuery conn query + toRawSql mode pureQuery (conn, initialIdentState) query -- | Execute an @esqueleto@ @DELETE@ query inside @persistent@'s @@ -700,24 +730,37 @@ -- @esqueleto@, instead of manually using this function (which is -- possible but tedious), you may just turn on query logging of -- @persistent@. -toRawSql :: SqlSelect a r => Mode -> QueryType a -> Connection -> SqlQuery a -> (TLB.Builder, [PersistValue]) -toRawSql mode qt conn query = - let (ret, SideData fromClauses setClauses whereClauses groupByClause havingClause orderByClauses limitClause) = - flip S.evalState initialIdentState $ +toRawSql :: SqlSelect a r => Mode -> QueryType a -> IdentInfo -> SqlQuery a -> (TLB.Builder, [PersistValue]) +toRawSql mode qt (conn, firstIdentState) query = + let ((ret, sd), finalIdentState) = + flip S.runState firstIdentState $ W.runWriterT $ unQ query + SideData fromClauses + setClauses + whereClauses + groupByClause + havingClause + orderByClauses + limitClause = sd + -- Pass the finalIdentState (containing all identifiers + -- that were used) to the subsequent calls. This ensures + -- that no name clashes will occur on subqueries that may + -- appear on the expressions below. + info = (conn, finalIdentState) in mconcat [ makeInsert qt ret - , makeSelect conn mode ret - , makeFrom conn mode fromClauses - , makeSet conn setClauses - , makeWhere conn whereClauses - , makeGroupBy conn groupByClause - , makeHaving conn havingClause - , makeOrderBy conn orderByClauses - , makeLimit conn limitClause + , makeSelect info mode ret + , makeFrom info mode fromClauses + , makeSet info setClauses + , makeWhere info whereClauses + , makeGroupBy info groupByClause + , makeHaving info havingClause + , makeOrderBy info orderByClauses + , makeLimit info limitClause ] + -- | (Internal) Mode of query being converted by 'toRawSql'. data Mode = SELECT | SELECT_DISTINCT | DELETE | UPDATE @@ -744,21 +787,21 @@ uncommas' = (uncommas *** mconcat) . unzip -makeSelect :: SqlSelect a r => Connection -> Mode -> a -> (TLB.Builder, [PersistValue]) -makeSelect conn mode ret = +makeSelect :: SqlSelect a r => IdentInfo -> Mode -> a -> (TLB.Builder, [PersistValue]) +makeSelect info mode ret = case mode of SELECT -> withCols "SELECT " SELECT_DISTINCT -> withCols "SELECT DISTINCT " DELETE -> plain "DELETE " UPDATE -> plain "UPDATE " where - withCols v = first (v <>) (sqlSelectCols conn ret) + withCols v = first (v <>) (sqlSelectCols info ret) plain v = (v, []) -makeFrom :: Connection -> Mode -> [FromClause] -> (TLB.Builder, [PersistValue]) +makeFrom :: IdentInfo -> Mode -> [FromClause] -> (TLB.Builder, [PersistValue]) makeFrom _ _ [] = mempty -makeFrom conn mode fs = ret +makeFrom info mode fs = ret where ret = case collectOnClauses fs of Left expr -> throw $ mkExc expr @@ -779,8 +822,8 @@ base ident@(I identText) def = let db@(DBName dbText) = entityDB def in ( if dbText == identText - then fromDBName conn db - else fromDBName conn db <> (" AS " <> useIdent conn ident) + then fromDBName info db + else fromDBName info db <> (" AS " <> useIdent info ident) , mempty ) fromKind InnerJoinKind = " INNER JOIN " @@ -789,56 +832,56 @@ fromKind RightOuterJoinKind = " RIGHT OUTER JOIN " fromKind FullOuterJoinKind = " FULL OUTER JOIN " - makeOnClause (ERaw _ f) = first (" ON " <>) (f conn) + makeOnClause (ERaw _ f) = first (" ON " <>) (f info) mkExc :: SqlExpr (Value Bool) -> OnClauseWithoutMatchingJoinException mkExc (ERaw _ f) = OnClauseWithoutMatchingJoinException $ - TL.unpack $ TLB.toLazyText $ fst (f conn) + TL.unpack $ TLB.toLazyText $ fst (f info) -makeSet :: Connection -> [SetClause] -> (TLB.Builder, [PersistValue]) +makeSet :: IdentInfo -> [SetClause] -> (TLB.Builder, [PersistValue]) makeSet _ [] = mempty -makeSet conn os = first ("\nSET " <>) $ uncommas' (map mk os) +makeSet info os = first ("\nSET " <>) $ uncommas' (map mk os) where - mk (SetClause (ERaw _ f)) = f conn + mk (SetClause (ERaw _ f)) = f info -makeWhere :: Connection -> WhereClause -> (TLB.Builder, [PersistValue]) +makeWhere :: IdentInfo -> WhereClause -> (TLB.Builder, [PersistValue]) makeWhere _ NoWhere = mempty -makeWhere conn (Where (ERaw _ f)) = first ("\nWHERE " <>) (f conn) +makeWhere info (Where (ERaw _ f)) = first ("\nWHERE " <>) (f info) -makeGroupBy :: Connection -> GroupByClause -> (TLB.Builder, [PersistValue]) +makeGroupBy :: IdentInfo -> GroupByClause -> (TLB.Builder, [PersistValue]) makeGroupBy _ (GroupBy []) = (mempty, []) -makeGroupBy conn (GroupBy fields) = first ("\nGROUP BY " <>) build +makeGroupBy info (GroupBy fields) = first ("\nGROUP BY " <>) build where - build = uncommas' $ map (\(SomeValue (ERaw _ f)) -> f conn) fields + build = uncommas' $ map (\(SomeValue (ERaw _ f)) -> f info) fields -makeHaving :: Connection -> WhereClause -> (TLB.Builder, [PersistValue]) +makeHaving :: IdentInfo -> WhereClause -> (TLB.Builder, [PersistValue]) makeHaving _ NoWhere = mempty -makeHaving conn (Where (ERaw _ f)) = first ("\nHAVING " <>) (f conn) +makeHaving info (Where (ERaw _ f)) = first ("\nHAVING " <>) (f info) -makeOrderBy :: Connection -> [OrderByClause] -> (TLB.Builder, [PersistValue]) +makeOrderBy :: IdentInfo -> [OrderByClause] -> (TLB.Builder, [PersistValue]) makeOrderBy _ [] = mempty -makeOrderBy conn os = first ("\nORDER BY " <>) $ uncommas' (map mk os) +makeOrderBy info os = first ("\nORDER BY " <>) $ uncommas' (map mk os) where - mk (EOrderBy t (ERaw p f)) = first ((<> orderByType t) . parensM p) (f conn) + mk (EOrderBy t (ERaw p f)) = first ((<> orderByType t) . parensM p) (f info) orderByType ASC = " ASC" orderByType DESC = " DESC" -makeLimit :: Connection -> LimitClause -> (TLB.Builder, [PersistValue]) +makeLimit :: IdentInfo -> LimitClause -> (TLB.Builder, [PersistValue]) makeLimit _ (Limit Nothing Nothing) = mempty makeLimit _ (Limit Nothing (Just 0)) = mempty -makeLimit conn (Limit ml mo) = (ret, mempty) +makeLimit info (Limit ml mo) = (ret, mempty) where ret = TLB.singleton '\n' <> (limitTLB <> offsetTLB) limitTLB = case ml of Just l -> "LIMIT " <> TLBI.decimal l - Nothing -> TLB.fromText (connNoLimit conn) + Nothing -> TLB.fromText (connNoLimit $ fst info) offsetTLB = case mo of @@ -863,7 +906,7 @@ -- | Creates the variable part of the @SELECT@ query and -- returns the list of 'PersistValue's that will be given to -- 'rawQuery'. - sqlSelectCols :: Connection -> a -> (TLB.Builder, [PersistValue]) + sqlSelectCols :: IdentInfo -> a -> (TLB.Builder, [PersistValue]) -- | Number of columns that will be consumed. sqlSelectColCount :: Proxy a -> Int @@ -874,10 +917,11 @@ -- | You may return an insertion of some PersistEntity instance PersistEntity a => SqlSelect (SqlExpr (Insertion a)) (Insertion a) where - sqlSelectCols esc (EInsert _ f) = let (b, vals) = f esc - in (b, vals) + sqlSelectCols info (EInsert _ f) = f info sqlSelectColCount = const 0 - sqlSelectProcessRow = const (Right Proxy) + sqlSelectProcessRow = const (Right (error msg)) + where + msg = "sqlSelectProcessRow/SqlSelect (SqlExpr (Insertion a)) (Insertion a): never here" -- | Not useful for 'select', but used for 'update' and 'delete'. @@ -889,10 +933,10 @@ -- | You may return an 'Entity' from a 'select' query. instance PersistEntity a => SqlSelect (SqlExpr (Entity a)) (Entity a) where - sqlSelectCols conn expr@(EEntity ident) = ret + sqlSelectCols info expr@(EEntity ident) = ret where process ed = uncommas $ - map ((name <>) . fromDBName conn) $ + map ((name <>) . fromDBName info) $ (entityID ed:) $ map fieldDB $ entityFields ed @@ -902,7 +946,7 @@ -- clause), while 'rawSql' assumes that it's just the -- name of the table (which doesn't allow self-joins, for -- example). - name = useIdent conn ident <> "." + name = useIdent info ident <> "." ret = let ed = entityDef $ getEntityVal $ return expr in (process ed, mempty) sqlSelectColCount = (+1) . length . entityFields . entityDef . getEntityVal @@ -917,7 +961,7 @@ -- | You may return a possibly-@NULL@ 'Entity' from a 'select' query. instance PersistEntity a => SqlSelect (SqlExpr (Maybe (Entity a))) (Maybe (Entity a)) where - sqlSelectCols conn (EMaybe ent) = sqlSelectCols conn ent + sqlSelectCols info (EMaybe ent) = sqlSelectCols info ent sqlSelectColCount = sqlSelectColCount . fromEMaybe where fromEMaybe :: Proxy (SqlExpr (Maybe e)) -> Proxy (SqlExpr e) @@ -930,8 +974,8 @@ -- | 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 esc (ERaw p f) = let (b, vals) = f esc - in (parensM p b, vals) + sqlSelectCols info (ERaw p f) = let (b, vals) = f info + in (parensM p b, vals) sqlSelectColCount = const 1 sqlSelectProcessRow [pv] = Value <$> fromPersistValue pv sqlSelectProcessRow _ = Left "SqlSelect (Value a): wrong number of columns." @@ -1427,23 +1471,14 @@ 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) --- | Apply a 'PersistField' constructor to @SqlExpr Value@ arguments -(<#) :: (a -> b) -> SqlExpr (Value a) -> SqlExpr (Insertion b) -(<#) _ (ERaw _ f) = EInsert Proxy f --- | Apply extra @SqlExpr Value@ arguments to a 'PersistField' constructor -(<&>) :: SqlExpr (Insertion (a -> b)) -> SqlExpr (Value a) -> SqlExpr (Insertion b) -(EInsert _ f) <&> (ERaw _ g) = EInsert Proxy $ \x-> - let (fb, fv) = f x - (gb, gv) = g x - in (fb <> ", " <> gb, fv ++ gv) - --- | Insert a 'PersistField' for every selected value +-- | Insert a 'PersistField' for every selected value. insertSelect :: (MonadLogger m, MonadResourceBase m, SqlSelect (SqlExpr (Insertion a)) r, PersistEntity a) => SqlQuery (SqlExpr (Insertion a)) -> SqlPersistT m () insertSelect = insertGeneralSelect SELECT --- | Insert a 'PersistField' for every unique selected value + +-- | Insert a 'PersistField' for every unique selected value. insertSelectDistinct :: (MonadLogger m, MonadResourceBase m, SqlSelect (SqlExpr (Insertion a)) r, PersistEntity a) => SqlQuery (SqlExpr (Insertion a)) -> SqlPersistT m () insertSelectDistinct = insertGeneralSelect SELECT_DISTINCT @@ -1453,4 +1488,4 @@ Mode -> SqlQuery (SqlExpr (Insertion a)) -> SqlPersistT m () insertGeneralSelect mode query = do conn <- SqlPersistT R.ask - uncurry rawExecute $ first builderToText $ toRawSql mode insertQuery conn query + uncurry rawExecute $ first builderToText $ toRawSql mode insertQuery (conn, initialIdentState) query diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -101,6 +101,37 @@ , (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 @@ -643,7 +674,8 @@ ret <- select $ from $ \p -> do let subquery = - from $ \bp -> + from $ \bp -> do + orderBy [ asc (bp ^. BlogPostAuthorId) ] return (bp ^. BlogPostAuthorId) where_ (p ^. PersonId `in_` subList_select subquery) return p