esqueleto 0.2.4 → 0.2.5
raw patch · 5 files changed
+159/−31 lines, 5 files
Files
- esqueleto.cabal +1/−1
- src/Database/Esqueleto.hs +14/−8
- src/Database/Esqueleto/Internal/Language.hs +22/−1
- src/Database/Esqueleto/Internal/Sql.hs +107/−21
- test/Test.hs +15/−0
esqueleto.cabal view
@@ -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
src/Database/Esqueleto.hs view
@@ -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 (<https://github.com/meteficha/esqueleto>) 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. ----------------------------------------------------------------------
src/Database/Esqueleto/Internal/Language.hs view
@@ -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
src/Database/Esqueleto/Internal/Sql.hs view
@@ -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.
test/Test.hs view
@@ -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