esqueleto 0.2.5 → 0.2.6
raw patch · 5 files changed
+145/−61 lines, 5 files
Files
- esqueleto.cabal +1/−1
- src/Database/Esqueleto.hs +1/−1
- src/Database/Esqueleto/Internal/Language.hs +7/−0
- src/Database/Esqueleto/Internal/Sql.hs +92/−59
- test/Test.hs +44/−0
esqueleto.cabal view
@@ -1,5 +1,5 @@ name: esqueleto-version: 0.2.5+version: 0.2.6 synopsis: Bare bones, type-safe EDSL for SQL queries on persistent backends. homepage: https://github.com/meteficha/esqueleto license: BSD3
src/Database/Esqueleto.hs view
@@ -18,7 +18,7 @@ -- $gettingstarted -- * @esqueleto@'s Language- Esqueleto( where_, on, orderBy, asc, desc+ Esqueleto( where_, on, orderBy, asc, desc, limit, offset , sub_select, sub_selectDistinct, (^.), (?.) , val, isNothing, just, nothing, countRows, not_ , (==.), (>=.), (>.), (<=.), (<.), (!=.), (&&.), (||.)
src/Database/Esqueleto/Internal/Language.hs view
@@ -33,6 +33,7 @@ import Control.Applicative (Applicative(..), (<$>)) import Control.Exception (Exception)+import Data.Int (Int64) import Data.String (IsString) import Data.Typeable (Typeable) import Database.Persist.GenericSql@@ -135,6 +136,12 @@ -- | Descending order of this field or expression. desc :: PersistField a => expr (Value a) -> expr OrderBy++ -- | @LIMIT@. Limit the number of returned rows.+ limit :: Int64 -> query ()++ -- | @OFFSET@. Usually used with 'limit'.+ offset :: Int64 -> query () -- | Execute a subquery @SELECT@ in an expression. sub_select :: PersistField a => query (expr (Value a)) -> expr (Value a)
src/Database/Esqueleto/Internal/Sql.hs view
@@ -31,7 +31,6 @@ , rawExecute , toRawSql , Mode(..)- , Escape , SqlSelect , veryUnsafeCoerceSqlExprValue ) where@@ -44,11 +43,12 @@ import Control.Monad.Logger (MonadLogger) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Resource (MonadResourceBase)+import Data.Int (Int64) import Data.List (intersperse) import Data.Monoid (Monoid(..), (<>)) import Database.Persist.EntityDef import Database.Persist.GenericSql-import Database.Persist.GenericSql.Internal (Connection(escapeName))+import Database.Persist.GenericSql.Internal (Connection(escapeName, noLimit)) import Database.Persist.GenericSql.Raw (withStmt, execute) import Database.Persist.Store hiding (delete) import qualified Control.Monad.Trans.Reader as R@@ -60,6 +60,7 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TLB+import qualified Data.Text.Lazy.Builder.Int as TLBI import Database.Esqueleto.Internal.Language @@ -93,12 +94,13 @@ , sdSetClause :: ![SetClause] , sdWhereClause :: !WhereClause , sdOrderByClause :: ![OrderByClause]+ , sdLimitClause :: !LimitClause } instance Monoid SideData where- mempty = SideData mempty mempty mempty mempty- SideData f s w o `mappend` SideData f' s' w' o' =- SideData (f <> f') (s <> s') (w <> w') (o <> o')+ mempty = SideData mempty mempty mempty mempty mempty+ SideData f s w o l `mappend` SideData f' s' w' o' l' =+ SideData (f <> f') (s <> s') (w <> w') (o <> o') (l <> l') -- | A part of a @FROM@ clause.@@ -155,6 +157,18 @@ type OrderByClause = SqlExpr OrderBy +-- | A @LIMIT@ clause.+data LimitClause = Limit (Maybe Int64) (Maybe Int64)++instance Monoid LimitClause where+ mempty = Limit mzero mzero+ Limit l1 o1 `mappend` Limit l2 o2 =+ Limit (l2 `mplus` l1) (o2 `mplus` o1)+ -- More than one 'limit' or 'offset' is issued, we want to+ -- keep the latest one. That's why we use mplus with+ -- "reversed" arguments.++ ---------------------------------------------------------------------- @@ -193,8 +207,8 @@ -- | Use an identifier.-useIdent :: Escape -> Ident -> TLB.Builder-useIdent esc (I ident) = esc (DBName ident)+useIdent :: Connection -> Ident -> TLB.Builder+useIdent conn (I ident) = fromDBName conn $ DBName ident ----------------------------------------------------------------------@@ -204,7 +218,7 @@ data SqlExpr a where EEntity :: Ident -> SqlExpr (Entity val) EMaybe :: SqlExpr a -> SqlExpr (Maybe a)- ERaw :: NeedParens -> (Escape -> (TLB.Builder, [PersistValue])) -> SqlExpr (Value a)+ ERaw :: NeedParens -> (Connection -> (TLB.Builder, [PersistValue])) -> SqlExpr (Value a) EOrderBy :: OrderByType -> SqlExpr (Value a) -> SqlExpr OrderBy ESet :: (SqlExpr (Entity val) -> SqlExpr (Value ())) -> SqlExpr (Update val) EPreprocessedFrom :: a -> FromClause -> SqlExpr (PreprocessedFrom a)@@ -217,10 +231,7 @@ data OrderByType = ASC | DESC --- | (Internal) Backend-specific function that escapes a 'DBName'.-type Escape = DBName -> TLB.Builder - instance Esqueleto SqlQuery SqlExpr SqlPersist where fromStart = x where@@ -260,11 +271,14 @@ asc = EOrderBy ASC desc = EOrderBy DESC + limit n = Q $ W.tell mempty { sdLimitClause = Limit (Just n) Nothing }+ offset n = Q $ W.tell mempty { sdLimitClause = Limit Nothing (Just n) }+ sub_select = sub SELECT sub_selectDistinct = sub SELECT_DISTINCT EEntity ident ^. field =- ERaw Never $ \esc -> (useIdent esc ident <> ("." <> fieldName esc field), [])+ ERaw Never $ \conn -> (useIdent conn ident <> ("." <> fieldName conn field), []) EMaybe r ?. field = maybelize (r ^. field) where@@ -278,8 +292,8 @@ nothing = unsafeSqlValue "NULL" countRows = unsafeSqlValue "COUNT(*)" - not_ (ERaw p f) = ERaw Never $ \esc -> let (b, vals) = f esc- in ("NOT " <> parensM p b, vals)+ not_ (ERaw p f) = ERaw Never $ \conn -> let (b, vals) = f conn+ in ("NOT " <> parensM p b, vals) (==.) = unsafeSqlBinOp " = " (>=.) = unsafeSqlBinOp " >= "@@ -311,18 +325,18 @@ fieldName :: (PersistEntity val, PersistField typ)- => Escape -> EntityField val typ -> TLB.Builder-fieldName esc = esc . fieldDB . persistFieldDef+ => Connection -> EntityField val typ -> TLB.Builder+fieldName conn = fromDBName conn . 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 $ \esc -> (fieldName esc field, mempty)+ where name = ERaw Never $ \conn -> (fieldName conn field, mempty) sub :: PersistField a => Mode -> SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a)-sub mode query = ERaw Parens $ \esc -> first parens (toRawSql mode esc query)+sub mode query = ERaw Parens $ \conn -> first parens (toRawSql mode conn query) fromDBName :: Connection -> DBName -> TLB.Builder fromDBName conn = TLB.fromText . escapeName conn@@ -346,10 +360,10 @@ 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 esc = let (b1, vals1) = f1 esc- (b2, vals2) = f2 esc- in ( parensM p1 b1 <> op <> parensM p2 b2- , vals1 <> vals2 )+ f conn = let (b1, vals1) = f1 conn+ (b2, vals2) = f2 conn+ in ( parensM p1 b1 <> op <> parensM p2 b2+ , vals1 <> vals2 ) {-# INLINE unsafeSqlBinOp #-} @@ -365,9 +379,9 @@ unsafeSqlFunction :: UnsafeSqlFunctionArgument a => TLB.Builder -> a -> SqlExpr (Value b) unsafeSqlFunction name arg =- ERaw Never $ \esc ->+ ERaw Never $ \conn -> let (argsTLB, argsVals) =- uncommas' $ map (\(ERaw _ f) -> f esc) $ toArgList arg+ uncommas' $ map (\(ERaw _ f) -> f conn) $ toArgList arg in (name <> parens argsTLB, argsVals) class UnsafeSqlFunctionArgument a where@@ -421,7 +435,7 @@ run conn = uncurry withStmt $ first builderToText $- toRawSql mode (fromDBName conn) query+ toRawSql mode conn query massage = do mrow <- C.await@@ -533,7 +547,7 @@ conn <- SqlPersist R.ask uncurry execute $ first builderToText $- toRawSql mode (fromDBName conn) query+ toRawSql mode conn query -- | Execute an @esqueleto@ @DELETE@ query inside @persistent@'s@@ -600,18 +614,19 @@ -- @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 -> Escape -> SqlQuery a -> (TLB.Builder, [PersistValue])-toRawSql mode esc query =- let (ret, SideData fromClauses setClauses whereClauses orderByClauses) =+toRawSql :: SqlSelect a r => Mode -> Connection -> SqlQuery a -> (TLB.Builder, [PersistValue])+toRawSql mode conn query =+ let (ret, SideData fromClauses setClauses whereClauses orderByClauses limitClause) = flip S.evalState initialIdentState $ W.runWriterT $ unQ query in mconcat- [ makeSelect esc mode ret- , makeFrom esc mode fromClauses- , makeSet esc setClauses- , makeWhere esc whereClauses- , makeOrderBy esc orderByClauses+ [ makeSelect conn mode ret+ , makeFrom conn mode fromClauses+ , makeSet conn setClauses+ , makeWhere conn whereClauses+ , makeOrderBy conn orderByClauses+ , makeLimit conn limitClause ] -- | (Internal) Mode of query being converted by 'toRawSql'.@@ -625,8 +640,8 @@ uncommas' = (uncommas *** mconcat) . unzip -makeSelect :: SqlSelect a r => Escape -> Mode -> a -> (TLB.Builder, [PersistValue])-makeSelect esc mode ret = first (s <>) (sqlSelectCols esc ret)+makeSelect :: SqlSelect a r => Connection -> Mode -> a -> (TLB.Builder, [PersistValue])+makeSelect conn mode ret = first (s <>) (sqlSelectCols conn ret) where s = case mode of SELECT -> "SELECT "@@ -635,9 +650,9 @@ UPDATE -> "UPDATE " -makeFrom :: Escape -> Mode -> [FromClause] -> (TLB.Builder, [PersistValue])-makeFrom _ _ [] = mempty-makeFrom esc mode fs = ret+makeFrom :: Connection -> Mode -> [FromClause] -> (TLB.Builder, [PersistValue])+makeFrom _ _ [] = mempty+makeFrom conn mode fs = ret where ret = case collectOnClauses fs of Left expr -> throw $ mkExc expr@@ -658,8 +673,8 @@ base ident@(I identText) def = let db@(DBName dbText) = entityDB def in ( if dbText == identText- then esc db- else esc db <> (" AS " <> useIdent esc ident)+ then fromDBName conn db+ else fromDBName conn db <> (" AS " <> useIdent conn ident) , mempty ) fromKind InnerJoinKind = " INNER JOIN "@@ -668,35 +683,53 @@ fromKind RightOuterJoinKind = " RIGHT OUTER JOIN " fromKind FullOuterJoinKind = " FULL OUTER JOIN " - makeOnClause (ERaw _ f) = first (" ON " <>) (f esc)+ makeOnClause (ERaw _ f) = first (" ON " <>) (f conn) mkExc :: SqlExpr (Value Bool) -> OnClauseWithoutMatchingJoinException mkExc (ERaw _ f) = OnClauseWithoutMatchingJoinException $- TL.unpack $ TLB.toLazyText $ fst (f esc)+ TL.unpack $ TLB.toLazyText $ fst (f conn) -makeSet :: Escape -> [SetClause] -> (TLB.Builder, [PersistValue])-makeSet _ [] = mempty-makeSet esc os = first ("\nSET " <>) $ uncommas' (map mk os)+makeSet :: Connection -> [SetClause] -> (TLB.Builder, [PersistValue])+makeSet _ [] = mempty+makeSet conn os = first ("\nSET " <>) $ uncommas' (map mk os) where- mk (SetClause (ERaw _ f)) = f esc+ mk (SetClause (ERaw _ f)) = f conn -makeWhere :: Escape -> WhereClause -> (TLB.Builder, [PersistValue])-makeWhere _ NoWhere = mempty-makeWhere esc (Where (ERaw _ f)) = first ("\nWHERE " <>) (f esc)+makeWhere :: Connection -> WhereClause -> (TLB.Builder, [PersistValue])+makeWhere _ NoWhere = mempty+makeWhere conn (Where (ERaw _ f)) = first ("\nWHERE " <>) (f conn) -makeOrderBy :: Escape -> [OrderByClause] -> (TLB.Builder, [PersistValue])-makeOrderBy _ [] = mempty-makeOrderBy esc os = first ("\nORDER BY " <>) $ uncommas' (map mk os)+makeOrderBy :: Connection -> [OrderByClause] -> (TLB.Builder, [PersistValue])+makeOrderBy _ [] = mempty+makeOrderBy conn os = first ("\nORDER BY " <>) $ uncommas' (map mk os) where- mk (EOrderBy t (ERaw _ f)) = first (<> orderByType t) (f esc)+ mk (EOrderBy t (ERaw _ f)) = first (<> orderByType t) (f conn) orderByType ASC = " ASC" orderByType DESC = " DESC" +makeLimit :: Connection -> LimitClause -> (TLB.Builder, [PersistValue])+makeLimit _ (Limit Nothing Nothing) = mempty+makeLimit _ (Limit Nothing (Just 0)) = mempty+makeLimit conn (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 (noLimit conn)++ offsetTLB =+ case mo of+ Just o -> " OFFSET " <> TLBI.decimal o+ Nothing -> mempty++ parens :: TLB.Builder -> TLB.Builder parens b = "(" <> (b <> ")") @@ -714,7 +747,7 @@ -- | Creates the variable part of the @SELECT@ query and -- returns the list of 'PersistValue's that will be given to -- 'withStmt'.- sqlSelectCols :: Escape -> a -> (TLB.Builder, [PersistValue])+ sqlSelectCols :: Connection -> a -> (TLB.Builder, [PersistValue]) -- | Number of columns that will be consumed. Must be -- non-strict on the argument.@@ -733,10 +766,10 @@ -- | You may return an 'Entity' from a 'select' query. instance PersistEntity a => SqlSelect (SqlExpr (Entity a)) (Entity a) where- sqlSelectCols escape expr@(EEntity ident) = ret+ sqlSelectCols conn expr@(EEntity ident) = ret where process ed = uncommas $- map ((name <>) . escape) $+ map ((name <>) . fromDBName conn) $ (entityID ed:) $ map fieldDB $ entityFields ed@@ -746,7 +779,7 @@ -- clause), while 'rawSql' assumes that it's just the -- name of the table (which doesn't allow self-joins, for -- example).- name = useIdent escape ident <> "."+ name = useIdent conn ident <> "." ret = let ed = entityDef $ getEntityVal expr in (process ed, mempty) sqlSelectColCount = (+1) . length . entityFields . entityDef . getEntityVal@@ -761,7 +794,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 escape (EMaybe ent) = sqlSelectCols escape ent+ sqlSelectCols conn (EMaybe ent) = sqlSelectCols conn ent sqlSelectColCount = sqlSelectColCount . fromEMaybe where fromEMaybe :: SqlExpr (Maybe e) -> SqlExpr e
test/Test.hs view
@@ -117,6 +117,50 @@ , (Value (personName p2), Value (personName p1)) , (Value (personName p2), Value (personName p2)) ] + it "works with many kinds of LIMITs and OFFSETs" $+ run $ do+ [p1e, p2e, p3e, p4e] <- mapM insert' [p1, p2, p3, p4]+ let people = from $ \p -> do+ orderBy [asc (p ^. PersonName)]+ return p+ ret1 <- select $ do+ p <- people+ limit 2+ limit 1+ return p+ liftIO $ ret1 `shouldBe` [ p1e ]+ ret2 <- select $ do+ p <- people+ limit 1+ limit 2+ return p+ liftIO $ ret2 `shouldBe` [ p1e, p4e ]+ ret3 <- select $ do+ p <- people+ offset 3+ offset 2+ return p+ liftIO $ ret3 `shouldBe` [ p3e, p2e ]+ ret4 <- select $ do+ p <- people+ offset 3+ limit 5+ offset 2+ limit 3+ offset 1+ limit 2+ return p+ liftIO $ ret4 `shouldBe` [ p4e, p3e ]+ ret5 <- select $ do+ p <- people+ offset 1000+ limit 1+ limit 1000+ offset 0+ return p+ liftIO $ ret5 `shouldBe` [ p1e, p4e, p3e, p2e ]++ describe "select/JOIN" $ do it "works with a LEFT OUTER JOIN" $ run $ do