haskell/esqueleto
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'master' of github.com:meteficha/esqueleto into HEAD

Browse Source 
Conflicts:
	esqueleto.cabal
	src/Database/Esqueleto/Internal/Sql.hs
This commit is contained in:
Michael Snoyman 2014-05-26 16:34:34 +03:00
commit 2685cdb7f7
6 changed files with 190 additions and 124 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitignore vendored
View File

@ -1,2 +1,4 @@
/dist* /dist*
*~ *~
.cabal-sandbox/
cabal.sandbox.config

45
esqueleto.cabal
View File

@ -1,38 +1,37 @@
name: esqueleto name: esqueleto
version: 2.0.0 version: 2.0.0
synopsis: Bare bones, type-safe EDSL for SQL queries on persistent backends. synopsis: Type-safe EDSL for SQL queries on persistent backends.
homepage: https://github.com/meteficha/esqueleto homepage: https://github.com/meteficha/esqueleto
license: BSD3 license: BSD3
license-file: LICENSE license-file: LICENSE
author: Felipe Lessa author: Felipe Lessa
maintainer: felipe.lessa@gmail.com maintainer: felipe.lessa@gmail.com
copyright: (c) 2012 Felipe Almeida Lessa copyright: (c) 2012-2014 Felipe Almeida Lessa
category: Database category: Database
build-type: Simple build-type: Simple
cabal-version: >=1.8 cabal-version: >=1.8
description: description:
@persistent@ is a library for type-safe data serialization. It
has many kinds of backends, such as SQL backends
(@persistent-mysql@, @persistent-postgresql@,
@persistent-sqlite@) and NoSQL backends (@persistent-mongoDB@).
.
While @persistent@ is a nice library for storing and retrieving
records, currently it has a poor interface for SQL backends
compared to SQL itself. For example, it's extremely hard to do
a type-safe @JOIN@ on a many-to-one relation, and simply
impossible to do any other kinds of @JOIN@s (including for the
very common many-to-many relations). Users have the option of
writing raw SQL, but that's error prone and not type-checked.
.
@esqueleto@ is a bare bones, type-safe EDSL for SQL queries @esqueleto@ is a bare bones, type-safe EDSL for SQL queries
that works with unmodified @persistent@ SQL backends. Its that works with unmodified @persistent@ SQL backends. Its
language closely resembles SQL, so (a) you don't have to learn language closely resembles SQL, so you don't have to learn
new concepts, just new syntax, and (b) it's fairly easy to new concepts, just new syntax, and it's fairly easy to
predict the generated SQL and optimize it for your backend. predict the generated SQL and optimize it for your backend.
Most kinds of errors committed when writing SQL are caught as Most kinds of errors committed when writing SQL are caught as
compile-time errors---although it is possible to write compile-time errors---although it is possible to write
type-checked @esqueleto@ queries that fail at runtime. type-checked @esqueleto@ queries that fail at runtime.
. .
@persistent@ is a library for type-safe data serialization. It
has many kinds of backends, such as SQL backends
(@persistent-mysql@, @persistent-postgresql@,
@persistent-sqlite@) and NoSQL backends (@persistent-mongoDB@).
While @persistent@ is a nice library for storing and retrieving
records, including with filters, it does not try to support
some of the features that are specific to SQL backends. In
particular, @esqueleto@ is the recommended library for
type-safe @JOIN@s on @persistent@ SQL backends. (The
alternative is using raw SQL, but that's error prone and does
not offer any composability.)
.
Currently, @SELECT@s, @UPDATE@s, @INSERT@s and @DELETE@s are supported. Currently, @SELECT@s, @UPDATE@s, @INSERT@s and @DELETE@s are supported.
Not all SQL features are available, but most of them can be easily added Not all SQL features are available, but most of them can be easily added
(especially functions), so please open an issue or send a pull request if (especially functions), so please open an issue or send a pull request if
@ -63,15 +62,15 @@ library
other-modules: other-modules:
Database.Esqueleto.Internal.PersistentImport Database.Esqueleto.Internal.PersistentImport
build-depends: build-depends:
base >= 4.5 && < 4.7 base >= 4.5 && < 4.8
, text == 0.11.* , text >= 0.11
, persistent >= 2.0 && < 2.1 , persistent >= 2.0 && < 2.1
, transformers >= 0.2 , transformers >= 0.2
, unordered-containers >= 0.2 , unordered-containers >= 0.2
, tagged >= 0.2 , tagged >= 0.2
, monad-logger , monad-logger
, conduit , conduit >= 1.1
, resourcet >= 1.1 , resourcet >= 1.1
hs-source-dirs: src/ hs-source-dirs: src/
ghc-options: -Wall ghc-options: -Wall
@ -84,13 +83,14 @@ test-suite test
build-depends: build-depends:
-- Library dependencies used on the tests. No need to -- Library dependencies used on the tests. No need to
-- specify versions since they'll use the same as above. -- specify versions since they'll use the same as above.
base, persistent, transformers, conduit, text base, persistent, transformers, resourcet, text
-- Test-only dependencies -- Test-only dependencies
, conduit >= 1.1
, containers , containers
, HUnit , HUnit
, QuickCheck , QuickCheck
, hspec >= 1.3 && < 1.8 , hspec >= 1.8
, persistent-sqlite >= 2.0 && < 2.1 , persistent-sqlite >= 2.0 && < 2.1
, persistent-template >= 2.0 && < 2.1 , persistent-template >= 2.0 && < 2.1
, monad-control , monad-control
@ -114,4 +114,3 @@ test-suite test
, persistent-mysql >= 2.0 , persistent-mysql >= 2.0
cpp-options: -DWITH_MYSQL cpp-options: -DWITH_MYSQL

5
src/Database/Esqueleto.hs
View File

@ -38,7 +38,7 @@ module Database.Esqueleto
-- $gettingstarted -- $gettingstarted
-- * @esqueleto@'s Language -- * @esqueleto@'s Language
Esqueleto( where_, on, groupBy, orderBy, asc, desc, limit, offset, having Esqueleto( where_, on, groupBy, orderBy, rand, asc, desc, limit, offset, having
, sub_select, sub_selectDistinct, (^.), (?.) , sub_select, sub_selectDistinct, (^.), (?.)
, val, isNothing, just, nothing, joinV, countRows, count, not_ , val, isNothing, just, nothing, joinV, countRows, count, not_
, (==.), (>=.), (>.), (<=.), (<.), (!=.), (&&.), (||.) , (==.), (>=.), (>.), (<=.), (<.), (!=.), (&&.), (||.)
@ -51,6 +51,7 @@ module Database.Esqueleto
, set, (=.), (+=.), (-=.), (*=.), (/=.) ) , set, (=.), (+=.), (-=.), (*=.), (/=.) )
, from , from
, Value(..) , Value(..)
, unValue
, ValueList(..) , ValueList(..)
, OrderBy , OrderBy
-- ** Joins -- ** Joins
@ -239,7 +240,7 @@ import qualified Database.Persist
-- --
-- Since @age@ is an optional @Person@ field, we use 'just' lift -- Since @age@ is an optional @Person@ field, we use 'just' lift
-- @val 18 :: SqlExpr (Value Int)@ into @just (val 18) :: -- @val 18 :: SqlExpr (Value Int)@ into @just (val 18) ::
-- SqlExpr (Value (Just Int))@. -- SqlExpr (Value (Maybe Int))@.
-- --
-- Implicit joins are represented by tuples. For example, to get -- Implicit joins are represented by tuples. For example, to get
-- the list of all blog posts and their authors, we could write: -- the list of all blog posts and their authors, we could write:

27
src/Database/Esqueleto/Internal/Language.hs
View File

@ -16,6 +16,7 @@ module Database.Esqueleto.Internal.Language
Esqueleto(..) Esqueleto(..)
, from , from
, Value(..) , Value(..)
, unValue
, ValueList(..) , ValueList(..)
, SomeValue(..) , SomeValue(..)
, ToSomeValues(..) , ToSomeValues(..)
@ -174,6 +175,11 @@ class (Functor query, Applicative query, Monad query) =>
-- | @OFFSET@. Usually used with 'limit'. -- | @OFFSET@. Usually used with 'limit'.
offset :: Int64 -> query () offset :: Int64 -> query ()
-- | @ORDER BY random()@ clause.
--
-- /Since: 1.3.10/
rand :: expr OrderBy
-- | @HAVING@. -- | @HAVING@.
-- --
-- /Since: 1.2.2/ -- /Since: 1.2.2/
@ -237,12 +243,12 @@ class (Functor query, Applicative query, Monad query) =>
(*.) :: PersistField a => expr (Value a) -> expr (Value a) -> expr (Value a) (*.) :: PersistField a => expr (Value a) -> expr (Value a) -> expr (Value a)
random_ :: PersistField a => expr (Value a) random_ :: (PersistField a, Num a) => expr (Value a)
round_ :: (PersistField a, PersistField b) => expr (Value a) -> expr (Value b) round_ :: (PersistField a, Num a, PersistField b, Num b) => expr (Value a) -> expr (Value b)
ceiling_ :: (PersistField a, PersistField b) => expr (Value a) -> expr (Value b) ceiling_ :: (PersistField a, Num a, PersistField b, Num b) => expr (Value a) -> expr (Value b)
floor_ :: (PersistField a, PersistField b) => expr (Value a) -> expr (Value b) floor_ :: (PersistField a, Num a, PersistField b, Num b) => expr (Value a) -> expr (Value b)
sum_ :: (PersistField a) => expr (Value a) -> expr (Value (Maybe a)) sum_ :: (PersistField a, PersistField b) => expr (Value a) -> expr (Value (Maybe b))
min_ :: (PersistField a) => expr (Value a) -> expr (Value (Maybe a)) min_ :: (PersistField a) => expr (Value a) -> expr (Value (Maybe a))
max_ :: (PersistField a) => expr (Value a) -> expr (Value (Maybe a)) max_ :: (PersistField a) => expr (Value a) -> expr (Value (Maybe a))
avg_ :: (PersistField a, PersistField b) => expr (Value a) -> expr (Value (Maybe b)) avg_ :: (PersistField a, PersistField b) => expr (Value a) -> expr (Value (Maybe b))
@ -329,13 +335,22 @@ infixr 2 ||., `InnerJoin`, `CrossJoin`, `LeftOuterJoin`, `RightOuterJoin`, `Full
-- @('^.')@ or @('?.')@ to get a 'Value' from an 'Entity'. -- @('^.')@ or @('?.')@ to get a 'Value' from an 'Entity'.
data Value a = Value a deriving (Eq, Ord, Show, Typeable) data Value a = Value a deriving (Eq, Ord, Show, Typeable)
-- Note: because of GHC bug #6124 we use @data@ instead of @newtype@. -- Note: because of GHC bug #6124 we use @data@ instead of @newtype@.
-- <https://ghc.haskell.org/trac/ghc/ticket/6124>
-- | A list of single values. There's a limited set of funcitons -- | Unwrap a 'Value'.
--
-- /Since: 1.4.1/
unValue :: Value a -> a
unValue (Value a) = a
-- | A list of single values. There's a limited set of functions
-- able to work with this data type (such as 'subList_select', -- able to work with this data type (such as 'subList_select',
-- 'valList', 'in_' and 'exists'). -- 'valList', 'in_' and 'exists').
data ValueList a = ValueList a deriving (Eq, Ord, Show, Typeable) data ValueList a = ValueList a deriving (Eq, Ord, Show, Typeable)
-- Note: because of GHC bug #6124 we use @data@ instead of @newtype@. -- Note: because of GHC bug #6124 we use @data@ instead of @newtype@.
-- <https://ghc.haskell.org/trac/ghc/ticket/6124>
-- | A wrapper type for for any @expr (Value a)@ for all a. -- | A wrapper type for for any @expr (Value a)@ for all a.

158
src/Database/Esqueleto/Internal/Sql.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE ConstraintKinds {-# LANGUAGE ConstraintKinds
, EmptyDataDecls
, FlexibleContexts , FlexibleContexts
, FlexibleInstances , FlexibleInstances
, FunctionalDependencies , FunctionalDependencies
@ -29,6 +30,7 @@ module Database.Esqueleto.Internal.Sql
, unsafeSqlBinOp , unsafeSqlBinOp
, unsafeSqlValue , unsafeSqlValue
, unsafeSqlFunction , unsafeSqlFunction
, unsafeSqlExtractSubField
, UnsafeSqlFunctionArgument , UnsafeSqlFunctionArgument
, rawSelectSource , rawSelectSource
, runSource , runSource
@ -40,6 +42,7 @@ module Database.Esqueleto.Internal.Sql
, IdentInfo , IdentInfo
, SqlSelect(..) , SqlSelect(..)
, veryUnsafeCoerceSqlExprValue , veryUnsafeCoerceSqlExprValue
, veryUnsafeCoerceSqlExprValueList
) where ) where
import Control.Applicative (Applicative(..), (<$>), (<$)) import Control.Applicative (Applicative(..), (<$>), (<$))
@ -48,13 +51,12 @@ import Control.Exception (throw, throwIO)
import Control.Monad (ap, MonadPlus(..), liftM) import Control.Monad (ap, MonadPlus(..), liftM)
import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Class (lift)
import qualified Control.Monad.Trans.Resource as Res import qualified Control.Monad.Trans.Reader as R
import Data.Int (Int64) import Data.Int (Int64)
import Data.List (intersperse) import Data.List (intersperse)
import Data.Monoid (Monoid(..), (<>)) import Data.Monoid (Monoid(..), (<>))
import Data.Proxy (Proxy(..)) import Data.Proxy (Proxy(..))
import Database.Esqueleto.Internal.PersistentImport import Database.Esqueleto.Internal.PersistentImport
import qualified Control.Monad.Trans.Reader as R
import qualified Control.Monad.Trans.State as S import qualified Control.Monad.Trans.State as S
import qualified Control.Monad.Trans.Writer as W import qualified Control.Monad.Trans.Writer as W
import qualified Data.Conduit as C import qualified Data.Conduit as C
@ -63,7 +65,6 @@ import qualified Data.HashSet as HS
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB import qualified Data.Text.Lazy.Builder as TLB
import qualified Data.Text.Lazy.Builder.Int as TLBI
import Data.Acquire (with, allocateAcquire, Acquire) import Data.Acquire (with, allocateAcquire, Acquire)
import Control.Monad.Trans.Resource (MonadResource) import Control.Monad.Trans.Resource (MonadResource)
@ -256,6 +257,7 @@ data SqlExpr a where
-- A 'SqlExpr' accepted only by 'orderBy'. -- A 'SqlExpr' accepted only by 'orderBy'.
EOrderBy :: OrderByType -> SqlExpr (Value a) -> SqlExpr OrderBy EOrderBy :: OrderByType -> SqlExpr (Value a) -> SqlExpr OrderBy
EOrderRandom :: SqlExpr OrderBy
-- A 'SqlExpr' accepted only by 'set'. -- A 'SqlExpr' accepted only by 'set'.
ESet :: (SqlExpr (Entity val) -> SqlExpr (Value ())) -> SqlExpr (Update val) ESet :: (SqlExpr (Entity val) -> SqlExpr (Value ())) -> SqlExpr (Update val)
@ -265,6 +267,10 @@ data SqlExpr a where
-- Used by 'insertSelect'. -- Used by 'insertSelect'.
EInsert :: Proxy a -> (IdentInfo -> (TLB.Builder, [PersistValue])) -> SqlExpr (Insertion a) EInsert :: Proxy a -> (IdentInfo -> (TLB.Builder, [PersistValue])) -> SqlExpr (Insertion a)
EInsertFinal :: PersistEntity a => SqlExpr (Insertion a) -> SqlExpr InsertFinal
-- | Phantom type used to mark a @INSERT INTO@ query.
data InsertFinal
data NeedParens = Parens | Never data NeedParens = Parens | Never
@ -318,6 +324,8 @@ instance Esqueleto SqlQuery SqlExpr SqlBackend where
asc = EOrderBy ASC asc = EOrderBy ASC
desc = EOrderBy DESC desc = EOrderBy DESC
rand = EOrderRandom
limit n = Q $ W.tell mempty { sdLimitClause = Limit (Just n) Nothing } limit n = Q $ W.tell mempty { sdLimitClause = Limit (Just n) Nothing }
offset n = Q $ W.tell mempty { sdLimitClause = Limit Nothing (Just n) } offset n = Q $ W.tell mempty { sdLimitClause = Limit Nothing (Just n) }
@ -418,7 +426,7 @@ setAux field mkVal = ESet $ \ent -> unsafeSqlBinOp " = " name (mkVal ent)
where name = ERaw Never $ \info -> (fieldName info field, mempty) where name = ERaw Never $ \info -> (fieldName info field, mempty)
sub :: PersistField a => Mode -> SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a) sub :: PersistField a => Mode -> SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a)
sub mode query = ERaw Parens $ \info -> toRawSql mode pureQuery info query sub mode query = ERaw Parens $ \info -> toRawSql mode info query
fromDBName :: IdentInfo -> DBName -> TLB.Builder fromDBName :: IdentInfo -> DBName -> TLB.Builder
fromDBName (conn, _) = TLB.fromText . connEscapeName conn fromDBName (conn, _) = TLB.fromText . connEscapeName conn
@ -476,6 +484,19 @@ unsafeSqlFunction name arg =
uncommas' $ map (\(ERaw _ f) -> f info) $ toArgList arg uncommas' $ map (\(ERaw _ f) -> f info) $ toArgList arg
in (name <> parens argsTLB, argsVals) in (name <> parens argsTLB, argsVals)
-- | (Internal) An unsafe SQL function to extract a subfield from a compound
-- field, e.g. datetime. See 'unsafeSqlBinOp' for warnings.
--
-- Since: 1.3.6.
unsafeSqlExtractSubField :: UnsafeSqlFunctionArgument a =>
TLB.Builder -> a -> SqlExpr (Value b)
unsafeSqlExtractSubField subField arg =
ERaw Never $ \info ->
let (argsTLB, argsVals) =
uncommas' $ map (\(ERaw _ f) -> f info) $ toArgList arg
in ("EXTRACT" <> parens (subField <> " FROM " <> argsTLB), argsVals)
class UnsafeSqlFunctionArgument a where class UnsafeSqlFunctionArgument a where
toArgList :: a -> [SqlExpr (Value ())] toArgList :: a -> [SqlExpr (Value ())]
instance (a ~ Value b) => UnsafeSqlFunctionArgument (SqlExpr a) where instance (a ~ Value b) => UnsafeSqlFunctionArgument (SqlExpr a) where
@ -500,6 +521,7 @@ instance ( UnsafeSqlFunctionArgument a
toArgList = toArgList . from4 toArgList = toArgList . from4
-- | (Internal) Coerce a value's type from 'SqlExpr (Value a)' to -- | (Internal) Coerce a value's type from 'SqlExpr (Value a)' to
-- 'SqlExpr (Value b)'. You should /not/ use this function -- 'SqlExpr (Value b)'. You should /not/ use this function
-- unless you know what you're doing! -- unless you know what you're doing!
@ -536,7 +558,7 @@ rawSelectSource mode query =
run conn = run conn =
uncurry rawQueryRes $ uncurry rawQueryRes $
first builderToText $ first builderToText $
toRawSql mode pureQuery (conn, initialIdentState) query toRawSql mode (conn, initialIdentState) query
massage = do massage = do
mrow <- C.await mrow <- C.await
@ -649,15 +671,15 @@ runSource src = src C.$$ CL.consume
-- | (Internal) Execute an @esqueleto@ statement inside -- | (Internal) Execute an @esqueleto@ statement inside
-- @persistent@'s 'SqlPersistT' monad. -- @persistent@'s 'SqlPersistT' monad.
rawEsqueleto :: ( MonadIO m ) rawEsqueleto :: ( MonadIO m, SqlSelect a r )
=> Mode => Mode
-> SqlQuery () -> SqlQuery a
-> SqlPersistT m Int64 -> SqlPersistT m Int64
rawEsqueleto mode query = do rawEsqueleto mode query = do
conn <- R.ask conn <- R.ask
uncurry rawExecuteCount $ uncurry rawExecuteCount $
first builderToText $ first builderToText $
toRawSql mode pureQuery (conn, initialIdentState) query toRawSql mode (conn, initialIdentState) query
-- | Execute an @esqueleto@ @DELETE@ query inside @persistent@'s -- | Execute an @esqueleto@ @DELETE@ query inside @persistent@'s
@ -737,8 +759,8 @@ builderToText = TL.toStrict . TLB.toLazyTextWith defaultChunkSize
-- @esqueleto@, instead of manually using this function (which is -- @esqueleto@, instead of manually using this function (which is
-- possible but tedious), you may just turn on query logging of -- possible but tedious), you may just turn on query logging of
-- @persistent@. -- @persistent@.
toRawSql :: SqlSelect a r => Mode -> QueryType a -> IdentInfo -> SqlQuery a -> (TLB.Builder, [PersistValue]) toRawSql :: SqlSelect a r => Mode -> IdentInfo -> SqlQuery a -> (TLB.Builder, [PersistValue])
toRawSql mode qt (conn, firstIdentState) query = toRawSql mode (conn, firstIdentState) query =
let ((ret, sd), finalIdentState) = let ((ret, sd), finalIdentState) =
flip S.runState firstIdentState $ flip S.runState firstIdentState $
W.runWriterT $ W.runWriterT $
@ -756,36 +778,27 @@ toRawSql mode qt (conn, firstIdentState) query =
-- appear on the expressions below. -- appear on the expressions below.
info = (conn, finalIdentState) info = (conn, finalIdentState)
in mconcat in mconcat
[ makeInsert qt ret [ makeInsertInto info mode ret
, makeSelect info mode ret , makeSelect info mode ret
, makeFrom info mode fromClauses , makeFrom info mode fromClauses
, makeSet info setClauses , makeSet info setClauses
, makeWhere info whereClauses , makeWhere info whereClauses
, makeGroupBy info groupByClause , makeGroupBy info groupByClause
, makeHaving info havingClause , makeHaving info havingClause
, makeOrderBy info orderByClauses , makeOrderBy info orderByClauses
, makeLimit info limitClause , makeLimit info limitClause orderByClauses
] ]
-- | (Internal) Mode of query being converted by 'toRawSql'. -- | (Internal) Mode of query being converted by 'toRawSql'.
data Mode = SELECT | SELECT_DISTINCT | DELETE | UPDATE data Mode =
SELECT
| SELECT_DISTINCT
| DELETE
| UPDATE
| INSERT_INTO Mode
-- ^ 'Mode' should be either 'SELECT' or 'SELECT_DISTINCT'.
newtype QueryType a = QueryType { unQueryType :: a -> TLB.Builder }
pureQuery :: QueryType a
pureQuery = QueryType (const mempty)
insertQuery :: PersistEntity a => QueryType (SqlExpr (Insertion a))
insertQuery = QueryType $ \(EInsert p _)->
let def = entityDef p
unName = TLB.fromText . unDBName
fields = uncommas $ map (unName . fieldDB) (entityFields def)
table = unName . entityDB . entityDef $ p
in "INSERT INTO " <> table <> parens fields <> "\n"
makeInsert :: QueryType a -> a -> (TLB.Builder, [PersistValue])
makeInsert q a = (unQueryType q a, [])
uncommas :: [TLB.Builder] -> TLB.Builder uncommas :: [TLB.Builder] -> TLB.Builder
uncommas = mconcat . intersperse ", " . filter (/= mempty) uncommas = mconcat . intersperse ", " . filter (/= mempty)
@ -794,14 +807,21 @@ uncommas' :: Monoid a => [(TLB.Builder, a)] -> (TLB.Builder, a)
uncommas' = (uncommas *** mconcat) . unzip uncommas' = (uncommas *** mconcat) . unzip
makeInsertInto :: SqlSelect a r => IdentInfo -> Mode -> a -> (TLB.Builder, [PersistValue])
makeInsertInto info (INSERT_INTO _) ret = sqlInsertInto info ret
makeInsertInto _ _ _ = mempty
makeSelect :: SqlSelect a r => IdentInfo -> Mode -> a -> (TLB.Builder, [PersistValue]) makeSelect :: SqlSelect a r => IdentInfo -> Mode -> a -> (TLB.Builder, [PersistValue])
makeSelect info mode ret = makeSelect info mode_ ret = process mode_
case mode of
SELECT -> withCols "SELECT "
SELECT_DISTINCT -> withCols "SELECT DISTINCT "
DELETE -> plain "DELETE "
UPDATE -> plain "UPDATE "
where where
process mode =
case mode of
SELECT -> withCols "SELECT "
SELECT_DISTINCT -> withCols "SELECT DISTINCT "
DELETE -> plain "DELETE "
UPDATE -> plain "UPDATE "
INSERT_INTO mode' -> process mode'
withCols v = first (v <>) (sqlSelectCols info ret) withCols v = first (v <>) (sqlSelectCols info ret)
plain v = (v, []) plain v = (v, [])
@ -873,27 +893,19 @@ makeOrderBy :: IdentInfo -> [OrderByClause] -> (TLB.Builder, [PersistValue])
makeOrderBy _ [] = mempty makeOrderBy _ [] = mempty
makeOrderBy info os = first ("\nORDER BY " <>) $ uncommas' (map mk os) makeOrderBy info os = first ("\nORDER BY " <>) $ uncommas' (map mk os)
where where
mk :: OrderByClause -> (TLB.Builder, [PersistValue])
mk (EOrderBy t (ERaw p f)) = first ((<> orderByType t) . parensM p) (f info) mk (EOrderBy t (ERaw p f)) = first ((<> orderByType t) . parensM p) (f info)
mk EOrderRandom = first ((<> "RANDOM()")) mempty
orderByType ASC = " ASC" orderByType ASC = " ASC"
orderByType DESC = " DESC" orderByType DESC = " DESC"
makeLimit :: IdentInfo -> LimitClause -> (TLB.Builder, [PersistValue]) makeLimit :: IdentInfo -> LimitClause -> [OrderByClause] -> (TLB.Builder, [PersistValue])
makeLimit _ (Limit Nothing Nothing) = mempty makeLimit (conn,_) (Limit ml mo) orderByClauses =
makeLimit _ (Limit Nothing (Just 0)) = mempty let limitRaw = connLimitOffset conn (v ml, v mo) hasOrderClause "\n"
makeLimit info (Limit ml mo) = (ret, mempty) hasOrderClause = not (null orderByClauses)
where v = maybe 0 fromIntegral
ret = TLB.singleton '\n' <> (limitTLB <> offsetTLB) in (TLB.fromText limitRaw, mempty)
limitTLB =
case ml of
Just l -> "LIMIT " <> TLBI.decimal l
Nothing -> TLB.fromText (connNoLimit $ fst info)
offsetTLB =
case mo of
Just o -> " OFFSET " <> TLBI.decimal o
Nothing -> mempty
parens :: TLB.Builder -> TLB.Builder parens :: TLB.Builder -> TLB.Builder
@ -921,14 +933,25 @@ class SqlSelect a r | a -> r, r -> a where
-- | Transform a row of the result into the data type. -- | Transform a row of the result into the data type.
sqlSelectProcessRow :: [PersistValue] -> Either T.Text r sqlSelectProcessRow :: [PersistValue] -> Either T.Text r
-- | Create @INSERT INTO@ clause instead.
sqlInsertInto :: IdentInfo -> a -> (TLB.Builder, [PersistValue])
sqlInsertInto = error "Type does not support sqlInsertInto."
-- | You may return an insertion of some PersistEntity
instance PersistEntity a => SqlSelect (SqlExpr (Insertion a)) (Insertion a) where -- | @INSERT INTO@ hack.
sqlSelectCols info (EInsert _ f) = f info instance SqlSelect (SqlExpr InsertFinal) InsertFinal where
sqlSelectColCount = const 0 sqlInsertInto info (EInsertFinal (EInsert p _)) =
let fields = uncommas $
map (fromDBName info . fieldDB) $
entityFields $
entityDef p
table = fromDBName info . entityDB . entityDef $ p
in ("INSERT INTO " <> table <> parens fields <> "\n", [])
sqlSelectCols info (EInsertFinal (EInsert _ f)) = f info
sqlSelectColCount = const 0
sqlSelectProcessRow = const (Right (error msg)) sqlSelectProcessRow = const (Right (error msg))
where where
msg = "sqlSelectProcessRow/SqlSelect (SqlExpr (Insertion a)) (Insertion a): never here" msg = "sqlSelectProcessRow/SqlSelect/InsertionFinal: never here"
-- | Not useful for 'select', but used for 'update' and 'delete'. -- | Not useful for 'select', but used for 'update' and 'delete'.
@ -1480,19 +1503,18 @@ 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,
-- | Insert a 'PersistField' for every selected value. -- | Insert a 'PersistField' for every selected value.
insertSelect :: (MonadIO m, SqlSelect (SqlExpr (Insertion a)) r, PersistEntity a) => insertSelect :: (MonadIO m, PersistEntity a) =>
SqlQuery (SqlExpr (Insertion a)) -> SqlPersistT m () SqlQuery (SqlExpr (Insertion a)) -> SqlPersistT m ()
insertSelect = insertGeneralSelect SELECT insertSelect = insertGeneralSelect SELECT
-- | Insert a 'PersistField' for every unique selected value. -- | Insert a 'PersistField' for every unique selected value.
insertSelectDistinct :: (MonadIO m, SqlSelect (SqlExpr (Insertion a)) r, PersistEntity a) => insertSelectDistinct :: (MonadIO m, PersistEntity a) =>
SqlQuery (SqlExpr (Insertion a)) -> SqlPersistT m () SqlQuery (SqlExpr (Insertion a)) -> SqlPersistT m ()
insertSelectDistinct = insertGeneralSelect SELECT_DISTINCT insertSelectDistinct = insertGeneralSelect SELECT_DISTINCT
insertGeneralSelect :: (MonadIO m, SqlSelect (SqlExpr (Insertion a)) r, PersistEntity a) => insertGeneralSelect :: (MonadIO m, PersistEntity a) =>
Mode -> SqlQuery (SqlExpr (Insertion a)) -> SqlPersistT m () Mode -> SqlQuery (SqlExpr (Insertion a)) -> SqlPersistT m ()
insertGeneralSelect mode query = do insertGeneralSelect mode =
conn <- R.ask liftM (const ()) . rawEsqueleto (INSERT_INTO mode) . fmap EInsertFinal
uncurry rawExecute $ first builderToText $ toRawSql mode insertQuery (conn, initialIdentState) query

77
test/Test.hs
View File

@ -21,7 +21,6 @@ import Control.Monad.Logger (MonadLogger(..), runStderrLoggingT, runNoLoggingT)
import Control.Monad.Trans.Control (MonadBaseControl(..)) import Control.Monad.Trans.Control (MonadBaseControl(..))
import Control.Monad.Trans.Reader (ReaderT) import Control.Monad.Trans.Reader (ReaderT)
import Database.Esqueleto import Database.Esqueleto
import Database.Persist.Sqlite (withSqliteConn)
#if defined (WITH_POSTGRESQL) #if defined (WITH_POSTGRESQL)
import Database.Persist.Postgresql (withPostgresqlConn) import Database.Persist.Postgresql (withPostgresqlConn)
#elif defined (WITH_MYSQL) #elif defined (WITH_MYSQL)
@ -31,11 +30,13 @@ import Database.Persist.MySQL ( withMySQLConn
, connectUser , connectUser
, connectPassword , connectPassword
, defaultConnectInfo) , defaultConnectInfo)
#else
import Database.Persist.Sqlite (withSqliteConn)
#endif #endif
import Database.Persist.TH import Database.Persist.TH
import Test.Hspec import Test.Hspec
import qualified Data.Conduit as C import qualified Control.Monad.Trans.Resource as R
import qualified Data.Set as S import qualified Data.Set as S
import qualified Data.List as L import qualified Data.List as L
@ -122,8 +123,8 @@ main = do
run $ do run $ do
p1k <- insert p1 p1k <- insert p1
p2k <- insert p2 p2k <- insert p2
f1k <- insert (Follow p1k p2k) _f1k <- insert (Follow p1k p2k)
f2k <- insert (Follow p2k p1k) _f2k <- insert (Follow p2k p1k)
ret <- select $ ret <- select $
from $ \followA -> do from $ \followA -> do
let subquery = let subquery =
@ -138,8 +139,8 @@ main = do
run $ do run $ do
p1k <- insert p1 p1k <- insert p1
p2k <- insert p2 p2k <- insert p2
f1k <- insert (Follow p1k p2k) _f1k <- insert (Follow p1k p2k)
f2k <- insert (Follow p2k p1k) _f2k <- insert (Follow p2k p1k)
ret <- select $ ret <- select $
from $ \followA -> do from $ \followA -> do
where_ $ exists $ where_ $ exists $
@ -324,7 +325,13 @@ main = do
ret <- select $ ret <- select $
from $ \p-> from $ \p->
return $ joinV $ sum_ (p ^. PersonAge) return $ joinV $ sum_ (p ^. PersonAge)
#if defined(WITH_POSTGRESQL)
liftIO $ ret `shouldBe` [ Value $ Just (36 + 17 + 17 :: Rational ) ]
#elif defined(WITH_MYSQL)
liftIO $ ret `shouldBe` [ Value $ Just (36 + 17 + 17 :: Double ) ]
#else
liftIO $ ret `shouldBe` [ Value $ Just (36 + 17 + 17 :: Int) ] liftIO $ ret `shouldBe` [ Value $ Just (36 + 17 + 17 :: Int) ]
#endif
it "works with avg_" $ it "works with avg_" $
run $ do run $ do
@ -362,9 +369,9 @@ main = do
it "works with random_" $ it "works with random_" $
run $ do run $ do
#if defined(WITH_POSTGRESQL) || defined(WITH_MYSQL) #if defined(WITH_POSTGRESQL) || defined(WITH_MYSQL)
ret <- select $ return (random_ :: SqlExpr (Value Double)) _ <- select $ return (random_ :: SqlExpr (Value Double))
#else #else
ret <- select $ return (random_ :: SqlExpr (Value Int)) _ <- select $ return (random_ :: SqlExpr (Value Int))
#endif #endif
return () return ()
@ -524,10 +531,10 @@ main = do
it "works with asc random_" $ it "works with asc random_" $
run $ do run $ do
p1e <- insert' p1 _p1e <- insert' p1
p2e <- insert' p2 _p2e <- insert' p2
p3e <- insert' p3 _p3e <- insert' p3
p4e <- insert' p4 _p4e <- insert' p4
rets <- rets <-
fmap S.fromList $ fmap S.fromList $
replicateM 11 $ replicateM 11 $
@ -674,7 +681,7 @@ main = do
it "GROUP BY works with HAVING" $ it "GROUP BY works with HAVING" $
run $ do run $ do
p1k <- insert p1 p1k <- insert p1
p2k <- insert p2 _p2k <- insert p2
p3k <- insert p3 p3k <- insert p3
replicateM_ 3 (insert $ BlogPost "" p1k) replicateM_ 3 (insert $ BlogPost "" p1k)
replicateM_ 7 (insert $ BlogPost "" p3k) replicateM_ 7 (insert $ BlogPost "" p3k)
@ -694,7 +701,7 @@ main = do
run $ do run $ do
p1k <- insert p1 p1k <- insert p1
p2k <- insert p2 p2k <- insert p2
p3k <- insert p3 _p3k <- insert p3
ret <- select $ ret <- select $
from $ \p -> do from $ \p -> do
where_ (p ^. PersonName `in_` valList (personName <$> [p1, p2])) where_ (p ^. PersonName `in_` valList (personName <$> [p1, p2]))
@ -704,9 +711,9 @@ main = do
it "IN works for valList (null list)" $ it "IN works for valList (null list)" $
run $ do run $ do
p1k <- insert p1 _p1k <- insert p1
p2k <- insert p2 _p2k <- insert p2
p3k <- insert p3 _p3k <- insert p3
ret <- select $ ret <- select $
from $ \p -> do from $ \p -> do
where_ (p ^. PersonName `in_` valList []) where_ (p ^. PersonName `in_` valList [])
@ -716,7 +723,7 @@ main = do
it "IN works for subList_select" $ it "IN works for subList_select" $
run $ do run $ do
p1k <- insert p1 p1k <- insert p1
p2k <- insert p2 _p2k <- insert p2
p3k <- insert p3 p3k <- insert p3
_ <- insert (BlogPost "" p1k) _ <- insert (BlogPost "" p1k)
_ <- insert (BlogPost "" p3k) _ <- insert (BlogPost "" p3k)
@ -750,7 +757,7 @@ main = do
it "EXISTS works for subList_select" $ it "EXISTS works for subList_select" $
run $ do run $ do
p1k <- insert p1 p1k <- insert p1
p2k <- insert p2 _p2k <- insert p2
p3k <- insert p3 p3k <- insert p3
_ <- insert (BlogPost "" p1k) _ <- insert (BlogPost "" p1k)
_ <- insert (BlogPost "" p3k) _ <- insert (BlogPost "" p3k)
@ -786,9 +793,29 @@ main = do
_ <- insert p3 _ <- insert p3
insertSelect $ from $ \p -> do insertSelect $ from $ \p -> do
return $ BlogPost <# val "FakePost" <&> (p ^. PersonId) return $ BlogPost <# val "FakePost" <&> (p ^. PersonId)
ret <- select $ from (\(b::(SqlExpr (Entity BlogPost))) -> return countRows) ret <- select $ from (\(_::(SqlExpr (Entity BlogPost))) -> return countRows)
liftIO $ ret `shouldBe` [Value (3::Int)] liftIO $ ret `shouldBe` [Value (3::Int)]
describe "rand works" $ do
it "returns result in random order" $
run $ do
replicateM_ 20 $ do
_ <- insert p1
_ <- insert p2
_ <- insert p3
_ <- insert p4
_ <- insert $ Person "Jane" Nothing
_ <- insert $ Person "Mark" Nothing
_ <- insert $ Person "Sarah" Nothing
insert $ Person "Paul" Nothing
ret1 <- fmap (map unValue) $ select $ from $ \p -> do
orderBy [rand]
return (p ^. PersonId)
ret2 <- fmap (map unValue) $ select $ from $ \p -> do
orderBy [rand]
return (p ^. PersonId)
liftIO $ (ret1 == ret2) `shouldBe` False
---------------------------------------------------------------------- ----------------------------------------------------------------------
@ -802,7 +829,7 @@ insert' v = flip Entity v <$> insert v
type RunDbMonad m = ( MonadBaseControl IO m, MonadIO m, MonadLogger m type RunDbMonad m = ( MonadBaseControl IO m, MonadIO m, MonadLogger m
, C.MonadUnsafeIO m, C.MonadThrow m ) , R.MonadThrow m )
#if defined (WITH_POSTGRESQL) || defined (WITH_MYSQL) #if defined (WITH_POSTGRESQL) || defined (WITH_MYSQL)
-- With SQLite and in-memory databases, a separate connection implies a -- With SQLite and in-memory databases, a separate connection implies a
@ -811,7 +838,7 @@ type RunDbMonad m = ( MonadBaseControl IO m, MonadIO m, MonadLogger m
-- TODO: there is certainly a better way... -- TODO: there is certainly a better way...
cleanDB cleanDB
:: (forall m. RunDbMonad m :: (forall m. RunDbMonad m
=> SqlPersistT (C.ResourceT m) ()) => SqlPersistT (R.ResourceT m) ())
cleanDB = do cleanDB = do
delete $ from $ \(blogpost :: SqlExpr (Entity BlogPost))-> return () delete $ from $ \(blogpost :: SqlExpr (Entity BlogPost))-> return ()
delete $ from $ \(follow :: SqlExpr (Entity Follow)) -> return () delete $ from $ \(follow :: SqlExpr (Entity Follow)) -> return ()
@ -819,7 +846,7 @@ cleanDB = do
#endif #endif
run, runSilent, runVerbose :: (forall m. RunDbMonad m => SqlPersistT (C.ResourceT m) a) -> IO a run, runSilent, runVerbose :: (forall m. RunDbMonad m => SqlPersistT (R.ResourceT m) a) -> IO a
runSilent act = runNoLoggingT $ run_worker act runSilent act = runNoLoggingT $ run_worker act
runVerbose act = runStderrLoggingT $ run_worker act runVerbose act = runStderrLoggingT $ run_worker act
run = run =
@ -832,9 +859,9 @@ verbose :: Bool
verbose = True verbose = True
run_worker :: RunDbMonad m => SqlPersistT (C.ResourceT m) a -> m a run_worker :: RunDbMonad m => SqlPersistT (R.ResourceT m) a -> m a
run_worker act = run_worker act =
C.runResourceT . R.runResourceT .
#if defined(WITH_POSTGRESQL) #if defined(WITH_POSTGRESQL)
withPostgresqlConn "host=localhost port=5432 user=test dbname=test" . withPostgresqlConn "host=localhost port=5432 user=test dbname=test" .
#elif defined (WITH_MYSQL) #elif defined (WITH_MYSQL)