Merge branch 'master' of github.com:meteficha/esqueleto into HEAD
Conflicts: esqueleto.cabal src/Database/Esqueleto/Internal/Sql.hs
This commit is contained in:
Michael Snoyman
commit
2685cdb7f7
2
.gitignore
vendored
2
.gitignore
vendored
@ -1,2 +1,4 @@
|
||||
/dist*
|
||||
*~
|
||||
.cabal-sandbox/
|
||||
cabal.sandbox.config
|
||||
|
||||
@ -1,38 +1,37 @@
|
||||
name: esqueleto
|
||||
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
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
author: Felipe Lessa
|
||||
maintainer: felipe.lessa@gmail.com
|
||||
copyright: (c) 2012 Felipe Almeida Lessa
|
||||
copyright: (c) 2012-2014 Felipe Almeida Lessa
|
||||
category: Database
|
||||
build-type: Simple
|
||||
cabal-version: >=1.8
|
||||
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
|
||||
that works with unmodified @persistent@ SQL backends. Its
|
||||
language closely resembles SQL, so (a) you don't have to learn
|
||||
new concepts, just new syntax, and (b) it's fairly easy to
|
||||
language closely resembles SQL, so you don't have to learn
|
||||
new concepts, just new syntax, and it's fairly easy to
|
||||
predict the generated SQL and optimize it for your backend.
|
||||
Most kinds of errors committed when writing SQL are caught as
|
||||
compile-time errors---although it is possible to write
|
||||
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.
|
||||
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
|
||||
@ -63,15 +62,15 @@ library
|
||||
other-modules:
|
||||
Database.Esqueleto.Internal.PersistentImport
|
||||
build-depends:
|
||||
base >= 4.5 && < 4.7
|
||||
, text == 0.11.*
|
||||
base >= 4.5 && < 4.8
|
||||
, text >= 0.11
|
||||
, persistent >= 2.0 && < 2.1
|
||||
, transformers >= 0.2
|
||||
, unordered-containers >= 0.2
|
||||
, tagged >= 0.2
|
||||
|
||||
, monad-logger
|
||||
, conduit
|
||||
, conduit >= 1.1
|
||||
, resourcet >= 1.1
|
||||
hs-source-dirs: src/
|
||||
ghc-options: -Wall
|
||||
@ -84,13 +83,14 @@ test-suite test
|
||||
build-depends:
|
||||
-- Library dependencies used on the tests. No need to
|
||||
-- specify versions since they'll use the same as above.
|
||||
base, persistent, transformers, conduit, text
|
||||
base, persistent, transformers, resourcet, text
|
||||
|
||||
-- Test-only dependencies
|
||||
, conduit >= 1.1
|
||||
, containers
|
||||
, HUnit
|
||||
, QuickCheck
|
||||
, hspec >= 1.3 && < 1.8
|
||||
, hspec >= 1.8
|
||||
, persistent-sqlite >= 2.0 && < 2.1
|
||||
, persistent-template >= 2.0 && < 2.1
|
||||
, monad-control
|
||||
@ -114,4 +114,3 @@ test-suite test
|
||||
, persistent-mysql >= 2.0
|
||||
|
||||
cpp-options: -DWITH_MYSQL
|
||||
|
||||
|
||||
@ -38,7 +38,7 @@ module Database.Esqueleto
|
||||
-- $gettingstarted
|
||||
|
||||
-- * @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, (^.), (?.)
|
||||
, val, isNothing, just, nothing, joinV, countRows, count, not_
|
||||
, (==.), (>=.), (>.), (<=.), (<.), (!=.), (&&.), (||.)
|
||||
@ -51,6 +51,7 @@ module Database.Esqueleto
|
||||
, set, (=.), (+=.), (-=.), (*=.), (/=.) )
|
||||
, from
|
||||
, Value(..)
|
||||
, unValue
|
||||
, ValueList(..)
|
||||
, OrderBy
|
||||
-- ** Joins
|
||||
@ -239,7 +240,7 @@ import qualified Database.Persist
|
||||
--
|
||||
-- Since @age@ is an optional @Person@ field, we use 'just' lift
|
||||
-- @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
|
||||
-- the list of all blog posts and their authors, we could write:
|
||||
|
||||
@ -16,6 +16,7 @@ module Database.Esqueleto.Internal.Language
|
||||
Esqueleto(..)
|
||||
, from
|
||||
, Value(..)
|
||||
, unValue
|
||||
, ValueList(..)
|
||||
, SomeValue(..)
|
||||
, ToSomeValues(..)
|
||||
@ -174,6 +175,11 @@ class (Functor query, Applicative query, Monad query) =>
|
||||
-- | @OFFSET@. Usually used with 'limit'.
|
||||
offset :: Int64 -> query ()
|
||||
|
||||
-- | @ORDER BY random()@ clause.
|
||||
--
|
||||
-- /Since: 1.3.10/
|
||||
rand :: expr OrderBy
|
||||
|
||||
-- | @HAVING@.
|
||||
--
|
||||
-- /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)
|
||||
|
||||
|
||||
random_ :: PersistField a => expr (Value a)
|
||||
round_ :: (PersistField a, PersistField b) => expr (Value a) -> expr (Value b)
|
||||
ceiling_ :: (PersistField a, PersistField b) => expr (Value a) -> expr (Value b)
|
||||
floor_ :: (PersistField a, PersistField b) => expr (Value a) -> expr (Value b)
|
||||
random_ :: (PersistField a, Num a) => expr (Value a)
|
||||
round_ :: (PersistField a, Num a, PersistField b, Num 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, 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))
|
||||
max_ :: (PersistField a) => expr (Value a) -> expr (Value (Maybe a))
|
||||
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'.
|
||||
data Value a = Value a deriving (Eq, Ord, Show, Typeable)
|
||||
-- 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',
|
||||
-- 'valList', 'in_' and 'exists').
|
||||
data ValueList a = ValueList a deriving (Eq, Ord, Show, Typeable)
|
||||
-- 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.
|
||||
|
||||
@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE ConstraintKinds
|
||||
, EmptyDataDecls
|
||||
, FlexibleContexts
|
||||
, FlexibleInstances
|
||||
, FunctionalDependencies
|
||||
@ -29,6 +30,7 @@ module Database.Esqueleto.Internal.Sql
|
||||
, unsafeSqlBinOp
|
||||
, unsafeSqlValue
|
||||
, unsafeSqlFunction
|
||||
, unsafeSqlExtractSubField
|
||||
, UnsafeSqlFunctionArgument
|
||||
, rawSelectSource
|
||||
, runSource
|
||||
@ -40,6 +42,7 @@ module Database.Esqueleto.Internal.Sql
|
||||
, IdentInfo
|
||||
, SqlSelect(..)
|
||||
, veryUnsafeCoerceSqlExprValue
|
||||
, veryUnsafeCoerceSqlExprValueList
|
||||
) where
|
||||
|
||||
import Control.Applicative (Applicative(..), (<$>), (<$))
|
||||
@ -48,13 +51,12 @@ import Control.Exception (throw, throwIO)
|
||||
import Control.Monad (ap, MonadPlus(..), liftM)
|
||||
import Control.Monad.IO.Class (MonadIO(..))
|
||||
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.List (intersperse)
|
||||
import Data.Monoid (Monoid(..), (<>))
|
||||
import Data.Proxy (Proxy(..))
|
||||
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.Writer as W
|
||||
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.Lazy as TL
|
||||
import qualified Data.Text.Lazy.Builder as TLB
|
||||
import qualified Data.Text.Lazy.Builder.Int as TLBI
|
||||
import Data.Acquire (with, allocateAcquire, Acquire)
|
||||
import Control.Monad.Trans.Resource (MonadResource)
|
||||
|
||||
@ -256,6 +257,7 @@ data SqlExpr a where
|
||||
|
||||
-- A 'SqlExpr' accepted only by 'orderBy'.
|
||||
EOrderBy :: OrderByType -> SqlExpr (Value a) -> SqlExpr OrderBy
|
||||
EOrderRandom :: SqlExpr OrderBy
|
||||
|
||||
-- A 'SqlExpr' accepted only by 'set'.
|
||||
ESet :: (SqlExpr (Entity val) -> SqlExpr (Value ())) -> SqlExpr (Update val)
|
||||
@ -265,6 +267,10 @@ data SqlExpr a where
|
||||
|
||||
-- Used by 'insertSelect'.
|
||||
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
|
||||
|
||||
@ -318,6 +324,8 @@ instance Esqueleto SqlQuery SqlExpr SqlBackend where
|
||||
asc = EOrderBy ASC
|
||||
desc = EOrderBy DESC
|
||||
|
||||
rand = EOrderRandom
|
||||
|
||||
limit n = Q $ W.tell mempty { sdLimitClause = Limit (Just n) Nothing }
|
||||
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)
|
||||
|
||||
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 (conn, _) = TLB.fromText . connEscapeName conn
|
||||
@ -476,6 +484,19 @@ unsafeSqlFunction name arg =
|
||||
uncommas' $ map (\(ERaw _ f) -> f info) $ toArgList arg
|
||||
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
|
||||
toArgList :: a -> [SqlExpr (Value ())]
|
||||
instance (a ~ Value b) => UnsafeSqlFunctionArgument (SqlExpr a) where
|
||||
@ -500,6 +521,7 @@ instance ( UnsafeSqlFunctionArgument a
|
||||
toArgList = toArgList . from4
|
||||
|
||||
|
||||
|
||||
-- | (Internal) Coerce a value's type from 'SqlExpr (Value a)' to
|
||||
-- 'SqlExpr (Value b)'. You should /not/ use this function
|
||||
-- unless you know what you're doing!
|
||||
@ -536,7 +558,7 @@ rawSelectSource mode query =
|
||||
run conn =
|
||||
uncurry rawQueryRes $
|
||||
first builderToText $
|
||||
toRawSql mode pureQuery (conn, initialIdentState) query
|
||||
toRawSql mode (conn, initialIdentState) query
|
||||
|
||||
massage = do
|
||||
mrow <- C.await
|
||||
@ -649,15 +671,15 @@ runSource src = src C.$$ CL.consume
|
||||
|
||||
-- | (Internal) Execute an @esqueleto@ statement inside
|
||||
-- @persistent@'s 'SqlPersistT' monad.
|
||||
rawEsqueleto :: ( MonadIO m )
|
||||
rawEsqueleto :: ( MonadIO m, SqlSelect a r )
|
||||
=> Mode
|
||||
-> SqlQuery ()
|
||||
-> SqlQuery a
|
||||
-> SqlPersistT m Int64
|
||||
rawEsqueleto mode query = do
|
||||
conn <- R.ask
|
||||
uncurry rawExecuteCount $
|
||||
first builderToText $
|
||||
toRawSql mode pureQuery (conn, initialIdentState) query
|
||||
toRawSql mode (conn, initialIdentState) query
|
||||
|
||||
|
||||
-- | 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
|
||||
-- possible but tedious), you may just turn on query logging of
|
||||
-- @persistent@.
|
||||
toRawSql :: SqlSelect a r => Mode -> QueryType a -> IdentInfo -> SqlQuery a -> (TLB.Builder, [PersistValue])
|
||||
toRawSql mode qt (conn, firstIdentState) query =
|
||||
toRawSql :: SqlSelect a r => Mode -> IdentInfo -> SqlQuery a -> (TLB.Builder, [PersistValue])
|
||||
toRawSql mode (conn, firstIdentState) query =
|
||||
let ((ret, sd), finalIdentState) =
|
||||
flip S.runState firstIdentState $
|
||||
W.runWriterT $
|
||||
@ -756,36 +778,27 @@ toRawSql mode qt (conn, firstIdentState) query =
|
||||
-- appear on the expressions below.
|
||||
info = (conn, finalIdentState)
|
||||
in mconcat
|
||||
[ makeInsert qt ret
|
||||
, 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
|
||||
[ makeInsertInto info mode ret
|
||||
, 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 orderByClauses
|
||||
]
|
||||
|
||||
|
||||
-- | (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 = mconcat . intersperse ", " . filter (/= mempty)
|
||||
@ -794,14 +807,21 @@ uncommas' :: Monoid a => [(TLB.Builder, a)] -> (TLB.Builder, a)
|
||||
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 info mode ret =
|
||||
case mode of
|
||||
SELECT -> withCols "SELECT "
|
||||
SELECT_DISTINCT -> withCols "SELECT DISTINCT "
|
||||
DELETE -> plain "DELETE "
|
||||
UPDATE -> plain "UPDATE "
|
||||
makeSelect info mode_ ret = process mode_
|
||||
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)
|
||||
plain v = (v, [])
|
||||
|
||||
@ -873,27 +893,19 @@ makeOrderBy :: IdentInfo -> [OrderByClause] -> (TLB.Builder, [PersistValue])
|
||||
makeOrderBy _ [] = mempty
|
||||
makeOrderBy info os = first ("\nORDER BY " <>) $ uncommas' (map mk os)
|
||||
where
|
||||
mk :: OrderByClause -> (TLB.Builder, [PersistValue])
|
||||
mk (EOrderBy t (ERaw p f)) = first ((<> orderByType t) . parensM p) (f info)
|
||||
mk EOrderRandom = first ((<> "RANDOM()")) mempty
|
||||
orderByType ASC = " ASC"
|
||||
orderByType DESC = " DESC"
|
||||
|
||||
|
||||
makeLimit :: IdentInfo -> LimitClause -> (TLB.Builder, [PersistValue])
|
||||
makeLimit _ (Limit Nothing Nothing) = mempty
|
||||
makeLimit _ (Limit Nothing (Just 0)) = 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 $ fst info)
|
||||
|
||||
offsetTLB =
|
||||
case mo of
|
||||
Just o -> " OFFSET " <> TLBI.decimal o
|
||||
Nothing -> mempty
|
||||
makeLimit :: IdentInfo -> LimitClause -> [OrderByClause] -> (TLB.Builder, [PersistValue])
|
||||
makeLimit (conn,_) (Limit ml mo) orderByClauses =
|
||||
let limitRaw = connLimitOffset conn (v ml, v mo) hasOrderClause "\n"
|
||||
hasOrderClause = not (null orderByClauses)
|
||||
v = maybe 0 fromIntegral
|
||||
in (TLB.fromText limitRaw, mempty)
|
||||
|
||||
|
||||
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.
|
||||
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
|
||||
sqlSelectCols info (EInsert _ f) = f info
|
||||
sqlSelectColCount = const 0
|
||||
|
||||
-- | @INSERT INTO@ hack.
|
||||
instance SqlSelect (SqlExpr InsertFinal) InsertFinal where
|
||||
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))
|
||||
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'.
|
||||
@ -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.
|
||||
insertSelect :: (MonadIO m, SqlSelect (SqlExpr (Insertion a)) r, PersistEntity a) =>
|
||||
insertSelect :: (MonadIO m, PersistEntity a) =>
|
||||
SqlQuery (SqlExpr (Insertion a)) -> SqlPersistT m ()
|
||||
insertSelect = insertGeneralSelect SELECT
|
||||
|
||||
|
||||
-- | 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 ()
|
||||
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 ()
|
||||
insertGeneralSelect mode query = do
|
||||
conn <- R.ask
|
||||
uncurry rawExecute $ first builderToText $ toRawSql mode insertQuery (conn, initialIdentState) query
|
||||
insertGeneralSelect mode =
|
||||
liftM (const ()) . rawEsqueleto (INSERT_INTO mode) . fmap EInsertFinal
|
||||
|
||||
77
test/Test.hs
77
test/Test.hs
@ -21,7 +21,6 @@ import Control.Monad.Logger (MonadLogger(..), runStderrLoggingT, runNoLoggingT)
|
||||
import Control.Monad.Trans.Control (MonadBaseControl(..))
|
||||
import Control.Monad.Trans.Reader (ReaderT)
|
||||
import Database.Esqueleto
|
||||
import Database.Persist.Sqlite (withSqliteConn)
|
||||
#if defined (WITH_POSTGRESQL)
|
||||
import Database.Persist.Postgresql (withPostgresqlConn)
|
||||
#elif defined (WITH_MYSQL)
|
||||
@ -31,11 +30,13 @@ import Database.Persist.MySQL ( withMySQLConn
|
||||
, connectUser
|
||||
, connectPassword
|
||||
, defaultConnectInfo)
|
||||
#else
|
||||
import Database.Persist.Sqlite (withSqliteConn)
|
||||
#endif
|
||||
import Database.Persist.TH
|
||||
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.List as L
|
||||
|
||||
@ -122,8 +123,8 @@ main = do
|
||||
run $ do
|
||||
p1k <- insert p1
|
||||
p2k <- insert p2
|
||||
f1k <- insert (Follow p1k p2k)
|
||||
f2k <- insert (Follow p2k p1k)
|
||||
_f1k <- insert (Follow p1k p2k)
|
||||
_f2k <- insert (Follow p2k p1k)
|
||||
ret <- select $
|
||||
from $ \followA -> do
|
||||
let subquery =
|
||||
@ -138,8 +139,8 @@ main = do
|
||||
run $ do
|
||||
p1k <- insert p1
|
||||
p2k <- insert p2
|
||||
f1k <- insert (Follow p1k p2k)
|
||||
f2k <- insert (Follow p2k p1k)
|
||||
_f1k <- insert (Follow p1k p2k)
|
||||
_f2k <- insert (Follow p2k p1k)
|
||||
ret <- select $
|
||||
from $ \followA -> do
|
||||
where_ $ exists $
|
||||
@ -324,7 +325,13 @@ main = do
|
||||
ret <- select $
|
||||
from $ \p->
|
||||
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) ]
|
||||
#endif
|
||||
|
||||
it "works with avg_" $
|
||||
run $ do
|
||||
@ -362,9 +369,9 @@ main = do
|
||||
it "works with random_" $
|
||||
run $ do
|
||||
#if defined(WITH_POSTGRESQL) || defined(WITH_MYSQL)
|
||||
ret <- select $ return (random_ :: SqlExpr (Value Double))
|
||||
_ <- select $ return (random_ :: SqlExpr (Value Double))
|
||||
#else
|
||||
ret <- select $ return (random_ :: SqlExpr (Value Int))
|
||||
_ <- select $ return (random_ :: SqlExpr (Value Int))
|
||||
#endif
|
||||
return ()
|
||||
|
||||
@ -524,10 +531,10 @@ main = do
|
||||
|
||||
it "works with asc random_" $
|
||||
run $ do
|
||||
p1e <- insert' p1
|
||||
p2e <- insert' p2
|
||||
p3e <- insert' p3
|
||||
p4e <- insert' p4
|
||||
_p1e <- insert' p1
|
||||
_p2e <- insert' p2
|
||||
_p3e <- insert' p3
|
||||
_p4e <- insert' p4
|
||||
rets <-
|
||||
fmap S.fromList $
|
||||
replicateM 11 $
|
||||
@ -674,7 +681,7 @@ main = do
|
||||
it "GROUP BY works with HAVING" $
|
||||
run $ do
|
||||
p1k <- insert p1
|
||||
p2k <- insert p2
|
||||
_p2k <- insert p2
|
||||
p3k <- insert p3
|
||||
replicateM_ 3 (insert $ BlogPost "" p1k)
|
||||
replicateM_ 7 (insert $ BlogPost "" p3k)
|
||||
@ -694,7 +701,7 @@ main = do
|
||||
run $ do
|
||||
p1k <- insert p1
|
||||
p2k <- insert p2
|
||||
p3k <- insert p3
|
||||
_p3k <- insert p3
|
||||
ret <- select $
|
||||
from $ \p -> do
|
||||
where_ (p ^. PersonName `in_` valList (personName <$> [p1, p2]))
|
||||
@ -704,9 +711,9 @@ main = do
|
||||
|
||||
it "IN works for valList (null list)" $
|
||||
run $ do
|
||||
p1k <- insert p1
|
||||
p2k <- insert p2
|
||||
p3k <- insert p3
|
||||
_p1k <- insert p1
|
||||
_p2k <- insert p2
|
||||
_p3k <- insert p3
|
||||
ret <- select $
|
||||
from $ \p -> do
|
||||
where_ (p ^. PersonName `in_` valList [])
|
||||
@ -716,7 +723,7 @@ main = do
|
||||
it "IN works for subList_select" $
|
||||
run $ do
|
||||
p1k <- insert p1
|
||||
p2k <- insert p2
|
||||
_p2k <- insert p2
|
||||
p3k <- insert p3
|
||||
_ <- insert (BlogPost "" p1k)
|
||||
_ <- insert (BlogPost "" p3k)
|
||||
@ -750,7 +757,7 @@ main = do
|
||||
it "EXISTS works for subList_select" $
|
||||
run $ do
|
||||
p1k <- insert p1
|
||||
p2k <- insert p2
|
||||
_p2k <- insert p2
|
||||
p3k <- insert p3
|
||||
_ <- insert (BlogPost "" p1k)
|
||||
_ <- insert (BlogPost "" p3k)
|
||||
@ -786,9 +793,29 @@ main = do
|
||||
_ <- insert p3
|
||||
insertSelect $ from $ \p -> do
|
||||
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)]
|
||||
|
||||
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
|
||||
, C.MonadUnsafeIO m, C.MonadThrow m )
|
||||
, R.MonadThrow m )
|
||||
|
||||
#if defined (WITH_POSTGRESQL) || defined (WITH_MYSQL)
|
||||
-- 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...
|
||||
cleanDB
|
||||
:: (forall m. RunDbMonad m
|
||||
=> SqlPersistT (C.ResourceT m) ())
|
||||
=> SqlPersistT (R.ResourceT m) ())
|
||||
cleanDB = do
|
||||
delete $ from $ \(blogpost :: SqlExpr (Entity BlogPost))-> return ()
|
||||
delete $ from $ \(follow :: SqlExpr (Entity Follow)) -> return ()
|
||||
@ -819,7 +846,7 @@ cleanDB = do
|
||||
#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
|
||||
runVerbose act = runStderrLoggingT $ run_worker act
|
||||
run =
|
||||
@ -832,9 +859,9 @@ verbose :: Bool
|
||||
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 =
|
||||
C.runResourceT .
|
||||
R.runResourceT .
|
||||
#if defined(WITH_POSTGRESQL)
|
||||
withPostgresqlConn "host=localhost port=5432 user=test dbname=test" .
|
||||
#elif defined (WITH_MYSQL)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user