diff --git a/esqueleto.cabal b/esqueleto.cabal --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -1,5 +1,5 @@ name: esqueleto -version: 0.2.4 +version: 0.2.5 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.hs b/src/Database/Esqueleto.hs --- a/src/Database/Esqueleto.hs +++ b/src/Database/Esqueleto.hs @@ -23,6 +23,7 @@ , val, isNothing, just, nothing, countRows, not_ , (==.), (>=.), (>.), (<=.), (<.), (!=.), (&&.), (||.) , (+.), (-.), (/.), (*.) + , like, (%), concat_, (++.) , set, (=.), (+=.), (-=.), (*=.), (/=.) ) , from , Value(..) @@ -38,6 +39,7 @@ -- * SQL backend , SqlQuery , SqlExpr + , SqlEntity , select , selectDistinct , selectSource @@ -85,14 +87,18 @@ -- project page () if -- there's anything missing that you'd like to see. -- --- * Be as type-safe as possible. There are ways of shooting --- yourself in the foot while using @esqueleto@ because it's --- extremely hard to provide 100% type-safety into a SQL-like --- EDSL---there's a tension between supporting features with a --- nice syntax and rejecting bad code. However, we strive to --- provide as many type checks as possible. If you get bitten --- by some invalid code that type-checks, please open an issue --- on our project page so we can take a look. +-- * Be as type-safe as possible. We strive to provide as many +-- type checks as possible. If you get bitten by some invalid +-- code that type-checks, please open an issue on our project +-- page so we can take a look. +-- +-- However, it is /not/ a goal to be able to write portable SQL. +-- We do not try to hide the differences between DBMSs from you, +-- and @esqueleto@ code that works for one database may not work +-- on another. This is a compromise we have to make in order to +-- give you as much control over the raw SQL as possible without +-- losing too much convenience. This also means that you may +-- type-check a query that doesn't work on your DBMS. ---------------------------------------------------------------------- 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 @@ -33,6 +33,7 @@ import Control.Applicative (Applicative(..), (<$>)) import Control.Exception (Exception) +import Data.String (IsString) import Data.Typeable (Typeable) import Database.Persist.GenericSql import Database.Persist.Store @@ -183,6 +184,25 @@ (/.) :: PersistField a => expr (Value a) -> expr (Value a) -> expr (Value a) (*.) :: PersistField a => expr (Value a) -> expr (Value a) -> expr (Value a) + -- | @LIKE@ operator. + like :: (PersistField s, IsString s) => expr (Value s) -> expr (Value s) -> expr (Value Bool) + -- | The string @'%'@. May be useful while using 'like' and + -- concatenation ('concat_' or '++.', depending on your + -- database). Note that you always to type the parenthesis, + -- for example: + -- + -- @ + -- name ``'like'`` (%) ++. val "John" ++. (%) + -- @ + (%) :: (PersistField s, IsString s) => expr (Value s) + -- | The @CONCAT@ function with a variable number of + -- parameters. Supported by MySQL and PostgreSQL. + concat_ :: (PersistField s, IsString s) => [expr (Value s)] -> expr (Value s) + -- | The @||@ string concatenation operator (named after + -- Haskell's '++' in order to avoid naming clash with '||.'). + -- Supported by SQLite and PostgreSQL. + (++.) :: (PersistField s, IsString s) => expr (Value s) -> expr (Value s) -> expr (Value s) + -- | @SET@ clause used on @UPDATE@s. Note that while it's not -- a type error to use this function on a @SELECT@, it will -- most certainly result in a runtime error. @@ -199,9 +219,10 @@ infixl 9 ^. infixl 7 *., /. infixl 6 +., -. +infixr 5 ++. infix 4 ==., >=., >., <=., <., !=. infixr 3 &&., =., +=., -=., *=., /=. -infixr 2 ||., `InnerJoin`, `CrossJoin`, `LeftOuterJoin`, `RightOuterJoin`, `FullOuterJoin` +infixr 2 ||., `InnerJoin`, `CrossJoin`, `LeftOuterJoin`, `RightOuterJoin`, `FullOuterJoin`, `like` -- | A single value (as opposed to a whole entity). You may use 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 @@ -14,6 +14,7 @@ ( -- * The pretty face SqlQuery , SqlExpr + , SqlEntity , select , selectSource , selectDistinct @@ -21,6 +22,10 @@ , delete , update -- * The guts + , unsafeSqlBinOp + , unsafeSqlValue + , unsafeSqlFunction + , UnsafeSqlFunctionArgument , rawSelectSource , runSource , rawExecute @@ -28,6 +33,7 @@ , Mode(..) , Escape , SqlSelect + , veryUnsafeCoerceSqlExprValue ) where import Control.Applicative (Applicative(..), (<$>)) @@ -74,6 +80,11 @@ (<*>) = ap +-- | Constraint synonym for @persistent@ entities whose backend +-- is 'SqlPersist'. +type SqlEntity ent = (PersistEntity ent, PersistEntityBackend ent ~ SqlPersist) + + ---------------------------------------------------------------------- @@ -264,25 +275,30 @@ isNothing (ERaw p f) = ERaw Never $ first ((<> " IS NULL") . parensM p) . f just (ERaw p f) = ERaw p f - nothing = ERaw Never $ \_ -> ("NULL", mempty) - countRows = ERaw Never $ \_ -> ("COUNT(*)", mempty) + nothing = unsafeSqlValue "NULL" + countRows = unsafeSqlValue "COUNT(*)" not_ (ERaw p f) = ERaw Never $ \esc -> let (b, vals) = f esc in ("NOT " <> parensM p b, vals) - (==.) = binop " = " - (>=.) = binop " >= " - (>.) = binop " > " - (<=.) = binop " <= " - (<.) = binop " < " - (!=.) = binop " != " - (&&.) = binop " AND " - (||.) = binop " OR " - (+.) = binop " + " - (-.) = binop " - " - (/.) = binop " / " - (*.) = binop " * " + (==.) = unsafeSqlBinOp " = " + (>=.) = unsafeSqlBinOp " >= " + (>.) = unsafeSqlBinOp " > " + (<=.) = unsafeSqlBinOp " <= " + (<.) = unsafeSqlBinOp " < " + (!=.) = unsafeSqlBinOp " != " + (&&.) = unsafeSqlBinOp " AND " + (||.) = unsafeSqlBinOp " OR " + (+.) = unsafeSqlBinOp " + " + (-.) = unsafeSqlBinOp " - " + (/.) = unsafeSqlBinOp " / " + (*.) = unsafeSqlBinOp " * " + like = unsafeSqlBinOp " LIKE " + (%) = unsafeSqlValue "'%'" + concat_ = unsafeSqlFunction "CONCAT" + (++.) = unsafeSqlBinOp " || " + set ent upds = Q $ W.tell mempty { sdSetClause = map apply upds } where apply (ESet f) = SetClause (f ent) @@ -302,7 +318,7 @@ => EntityField val typ -> (SqlExpr (Entity val) -> SqlExpr (Value typ)) -> SqlExpr (Update val) -setAux field mkVal = ESet $ \ent -> binop " = " name (mkVal ent) +setAux field mkVal = ESet $ \ent -> unsafeSqlBinOp " = " name (mkVal ent) where name = ERaw Never $ \esc -> (fieldName esc field, mempty) sub :: PersistField a => Mode -> SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a) @@ -311,15 +327,80 @@ fromDBName :: Connection -> DBName -> TLB.Builder fromDBName conn = TLB.fromText . escapeName conn -binop :: TLB.Builder -> SqlExpr (Value a) -> SqlExpr (Value b) -> SqlExpr (Value c) -binop op (ERaw p1 f1) (ERaw p2 f2) = ERaw Parens f + +---------------------------------------------------------------------- + + +-- | (Internal) Create a custom binary operator. You /should/ +-- /not/ use this function directly since its type is very +-- general, you should always use it with an explicit type +-- signature. For example: +-- +-- @ +-- (==.) :: SqlExpr (Value a) -> SqlExpr (Value a) -> SqlExpr (Value Bool) +-- (==.) = unsafeSqlBinOp " = " +-- @ +-- +-- In the example above, we constraint the arguments to be of the +-- same type and constraint the result to be a boolean value. +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 ) +{-# INLINE unsafeSqlBinOp #-} +-- | (Internal) A raw SQL value. The same warning from +-- 'unsafeSqlBinOp' applies to this function as well. +unsafeSqlValue :: TLB.Builder -> SqlExpr (Value a) +unsafeSqlValue v = ERaw Never $ \_ -> (v, mempty) +{-# INLINE unsafeSqlValue #-} + + +-- | (Internal) A raw SQL function. Once again, the same warning +-- from 'unsafeSqlBinOp' applies to this function as well. +unsafeSqlFunction :: UnsafeSqlFunctionArgument a => + TLB.Builder -> a -> SqlExpr (Value b) +unsafeSqlFunction name arg = + ERaw Never $ \esc -> + let (argsTLB, argsVals) = + uncommas' $ map (\(ERaw _ f) -> f esc) $ toArgList arg + in (name <> parens argsTLB, argsVals) + +class UnsafeSqlFunctionArgument a where + toArgList :: a -> [SqlExpr (Value ())] +instance (a ~ Value b) => UnsafeSqlFunctionArgument (SqlExpr a) where + toArgList = (:[]) . veryUnsafeCoerceSqlExprValue +instance UnsafeSqlFunctionArgument a => + UnsafeSqlFunctionArgument [a] where + toArgList = concatMap toArgList +instance ( UnsafeSqlFunctionArgument a + , UnsafeSqlFunctionArgument b + ) => UnsafeSqlFunctionArgument (a, b) where + toArgList (a, b) = toArgList a ++ toArgList b +instance ( UnsafeSqlFunctionArgument a + , UnsafeSqlFunctionArgument b + , UnsafeSqlFunctionArgument c + ) => UnsafeSqlFunctionArgument (a, b, c) where + toArgList = toArgList . from3 +instance ( UnsafeSqlFunctionArgument a + , UnsafeSqlFunctionArgument b + , UnsafeSqlFunctionArgument c + , UnsafeSqlFunctionArgument d + ) => UnsafeSqlFunctionArgument (a, b, c, d) where + toArgList = toArgList . from4 + + +-- | (Internal) Coerce a type of a 'SqlExpr (Value a)' into +-- another 'SqlExpr (Value b)'. You should /not/ use this +-- function unless you know what you're doing! +veryUnsafeCoerceSqlExprValue :: SqlExpr (Value a) -> SqlExpr (Value b) +veryUnsafeCoerceSqlExprValue (ERaw p f) = ERaw p f + + ---------------------------------------------------------------------- @@ -339,7 +420,7 @@ run conn = uncurry withStmt $ - first (TL.toStrict . TLB.toLazyText) $ + first builderToText $ toRawSql mode (fromDBName conn) query massage = do @@ -451,7 +532,7 @@ rawExecute mode query = do conn <- SqlPersist R.ask uncurry execute $ - first (TL.toStrict . TLB.toLazyText) $ + first builderToText $ toRawSql mode (fromDBName conn) query @@ -498,14 +579,19 @@ -- @ update :: ( MonadLogger m , MonadResourceBase m - , PersistEntity val - , PersistEntityBackend val ~ SqlPersist ) + , SqlEntity val ) => (SqlExpr (Entity val) -> SqlQuery ()) -> SqlPersist m () update = rawExecute UPDATE . from ---------------------------------------------------------------------- + + +builderToText :: TLB.Builder -> T.Text +builderToText = TL.toStrict . TLB.toLazyTextWith defaultChunkSize + where + defaultChunkSize = 1024 - 32 -- | (Internal) Pretty prints a 'SqlQuery' into a SQL query. diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -344,6 +344,21 @@ return title liftIO $ ret `shouldBe` [ Value t1, Value t2, Value t3 ] + describe "text functions" $ + it "like, (%) and (++.) work on a simple example" $ + run $ do + [p1e, p2e, p3e, p4e] <- mapM insert' [p1, p2, p3, p4] + let nameContains t expected = do + ret <- select $ + from $ \p -> do + where_ (p ^. PersonName `like` (%) ++. val t ++. (%)) + orderBy [asc (p ^. PersonName)] + return p + liftIO $ ret `shouldBe` expected + nameContains "h" [p1e, p2e] + nameContains "i" [p4e, p3e] + nameContains "iv" [p4e] + describe "delete" $ it "works on a simple example" $ run $ do