esqueleto 1.3.3 → 1.3.4
raw patch · 4 files changed
+171/−93 lines, 4 files
Files
- esqueleto.cabal +1/−1
- src/Database/Esqueleto/Internal/Language.hs +11/−0
- src/Database/Esqueleto/Internal/Sql.hs +126/−91
- test/Test.hs +33/−1
esqueleto.cabal view
@@ -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
src/Database/Esqueleto/Internal/Language.hs view
@@ -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.
src/Database/Esqueleto/Internal/Sql.hs view
@@ -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
test/Test.hs view
@@ -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