Merge branch 'master' of github.com:meteficha/esqueleto
This commit is contained in:
João Cristóvão
commit
0033050806
@ -1,5 +1,5 @@
|
||||
name: esqueleto
|
||||
version: 1.3.3
|
||||
version: 1.3.4.2
|
||||
synopsis: Bare bones, type-safe EDSL for SQL queries on persistent backends.
|
||||
homepage: https://github.com/meteficha/esqueleto
|
||||
license: BSD3
|
||||
@ -47,6 +47,14 @@ source-repository head
|
||||
type: git
|
||||
location: git://github.com/meteficha/esqueleto.git
|
||||
|
||||
Flag postgresql
|
||||
Description: test postgresql. default is to test sqlite.
|
||||
Default: False
|
||||
|
||||
Flag mysql
|
||||
Description: test MySQL/MariaDB. default is to test sqlite.
|
||||
Default: False
|
||||
|
||||
library
|
||||
exposed-modules:
|
||||
Database.Esqueleto
|
||||
@ -90,3 +98,20 @@ test-suite test
|
||||
|
||||
-- This library
|
||||
, esqueleto
|
||||
|
||||
if flag(postgresql)
|
||||
build-depends:
|
||||
postgresql-simple >= 0.2
|
||||
, postgresql-libpq >= 0.6
|
||||
, persistent-postgresql >= 1.2.0
|
||||
|
||||
cpp-options: -DWITH_POSTGRESQL
|
||||
|
||||
if flag(mysql)
|
||||
build-depends:
|
||||
mysql-simple >= 0.2.2.3
|
||||
, mysql >= 0.1.1.3
|
||||
, persistent-mysql >= 1.2.0
|
||||
|
||||
cpp-options: -DWITH_MYSQL
|
||||
|
||||
|
||||
@ -27,6 +27,7 @@ module Database.Esqueleto.Internal.Language
|
||||
, OnClauseWithoutMatchingJoinException(..)
|
||||
, OrderBy
|
||||
, Update
|
||||
, Insertion
|
||||
-- * The guts
|
||||
, JoinKind(..)
|
||||
, IsJoinKind(..)
|
||||
@ -307,6 +308,12 @@ class (Functor query, Applicative query, Monad query) =>
|
||||
(*=.) :: (PersistEntity val, PersistField a) => EntityField val a -> expr (Value a) -> expr (Update val)
|
||||
(/=.) :: (PersistEntity val, PersistField a) => EntityField val a -> expr (Value a) -> expr (Update val)
|
||||
|
||||
-- | Apply a 'PersistField' constructor to @expr Value@ arguments.
|
||||
(<#) :: (a -> b) -> expr (Value a) -> expr (Insertion b)
|
||||
|
||||
-- | Apply extra @expr Value@ arguments to a 'PersistField' constructor
|
||||
(<&>) :: expr (Insertion (a -> b)) -> expr (Value a) -> expr (Insertion b)
|
||||
|
||||
|
||||
-- Fixity declarations
|
||||
infixl 9 ^.
|
||||
@ -492,6 +499,10 @@ data OrderBy
|
||||
data Update typ
|
||||
|
||||
|
||||
-- | Phantom type used by 'insertSelect'.
|
||||
data Insertion a
|
||||
|
||||
|
||||
-- | @FROM@ clause: bring entities into scope.
|
||||
--
|
||||
-- This function internally uses two type classes in order to
|
||||
|
||||
@ -23,6 +23,8 @@ module Database.Esqueleto.Internal.Sql
|
||||
, deleteCount
|
||||
, update
|
||||
, updateCount
|
||||
, insertSelectDistinct
|
||||
, insertSelect
|
||||
-- * The guts
|
||||
, unsafeSqlBinOp
|
||||
, unsafeSqlValue
|
||||
@ -33,12 +35,11 @@ module Database.Esqueleto.Internal.Sql
|
||||
, rawEsqueleto
|
||||
, toRawSql
|
||||
, Mode(..)
|
||||
, IdentState
|
||||
, initialIdentState
|
||||
, IdentInfo
|
||||
, SqlSelect
|
||||
, veryUnsafeCoerceSqlExprValue
|
||||
, insertSelectDistinct
|
||||
, insertSelect
|
||||
, (<#)
|
||||
, (<&>)
|
||||
) where
|
||||
|
||||
import Control.Applicative (Applicative(..), (<$>), (<$))
|
||||
@ -221,27 +222,49 @@ newIdentFor = Q . lift . try . unDBName
|
||||
return (I t)
|
||||
|
||||
|
||||
-- | Information needed to escape and use identifiers.
|
||||
type IdentInfo = (Connection, IdentState)
|
||||
|
||||
|
||||
-- | Use an identifier.
|
||||
useIdent :: Connection -> Ident -> TLB.Builder
|
||||
useIdent conn (I ident) = fromDBName conn $ DBName ident
|
||||
useIdent :: IdentInfo -> Ident -> TLB.Builder
|
||||
useIdent info (I ident) = fromDBName info $ DBName ident
|
||||
|
||||
|
||||
----------------------------------------------------------------------
|
||||
|
||||
type Insertion = Proxy
|
||||
|
||||
-- | An expression on the SQL backend.
|
||||
data SqlExpr a where
|
||||
EInsert :: Proxy a -> (Connection -> (TLB.Builder, [PersistValue])) -> SqlExpr (Insertion a)
|
||||
-- An entity, created by 'from' (cf. 'fromStart').
|
||||
EEntity :: Ident -> SqlExpr (Entity val)
|
||||
|
||||
-- Just a tag stating that something is nullable.
|
||||
EMaybe :: SqlExpr a -> SqlExpr (Maybe a)
|
||||
ERaw :: NeedParens -> (Connection -> (TLB.Builder, [PersistValue])) -> SqlExpr (Value a)
|
||||
EList :: SqlExpr (Value a) -> SqlExpr (ValueList a)
|
||||
|
||||
-- Raw expression: states whether parenthesis are needed
|
||||
-- around this expression, and takes information about the SQL
|
||||
-- connection (mainly for escaping names) and returns both an
|
||||
-- string ('TLB.Builder') and a list of values to be
|
||||
-- interpolated by the SQL backend.
|
||||
ERaw :: NeedParens -> (IdentInfo -> (TLB.Builder, [PersistValue])) -> SqlExpr (Value a)
|
||||
|
||||
-- 'EList' and 'EEmptyList' are used by list operators.
|
||||
EList :: SqlExpr (Value a) -> SqlExpr (ValueList a)
|
||||
EEmptyList :: SqlExpr (ValueList a)
|
||||
|
||||
-- A 'SqlExpr' accepted only by 'orderBy'.
|
||||
EOrderBy :: OrderByType -> SqlExpr (Value a) -> SqlExpr OrderBy
|
||||
ESet :: (SqlExpr (Entity val) -> SqlExpr (Value ())) -> SqlExpr (Update val)
|
||||
|
||||
-- A 'SqlExpr' accepted only by 'set'.
|
||||
ESet :: (SqlExpr (Entity val) -> SqlExpr (Value ())) -> SqlExpr (Update val)
|
||||
|
||||
-- An internal 'SqlExpr' used by the 'from' hack.
|
||||
EPreprocessedFrom :: a -> FromClause -> SqlExpr (PreprocessedFrom a)
|
||||
|
||||
-- Used by 'insertSelect'.
|
||||
EInsert :: Proxy a -> (IdentInfo -> (TLB.Builder, [PersistValue])) -> SqlExpr (Insertion a)
|
||||
|
||||
data NeedParens = Parens | Never
|
||||
|
||||
parensM :: NeedParens -> TLB.Builder -> TLB.Builder
|
||||
@ -301,7 +324,7 @@ instance Esqueleto SqlQuery SqlExpr SqlBackend where
|
||||
sub_selectDistinct = sub SELECT_DISTINCT
|
||||
|
||||
EEntity ident ^. field =
|
||||
ERaw Never $ \conn -> (useIdent conn ident <> ("." <> fieldName conn field), [])
|
||||
ERaw Never $ \info -> (useIdent info ident <> ("." <> fieldName info field), [])
|
||||
|
||||
EMaybe r ?. field = maybelize (r ^. field)
|
||||
where
|
||||
@ -315,10 +338,10 @@ instance Esqueleto SqlQuery SqlExpr SqlBackend where
|
||||
nothing = unsafeSqlValue "NULL"
|
||||
joinV (ERaw p f) = ERaw p f
|
||||
countRows = unsafeSqlValue "COUNT(*)"
|
||||
count (ERaw _ f) = ERaw Never $ \conn -> let (b, vals) = f conn
|
||||
count (ERaw _ f) = ERaw Never $ \info -> let (b, vals) = f info
|
||||
in ("COUNT" <> parens b, vals)
|
||||
|
||||
not_ (ERaw p f) = ERaw Never $ \conn -> let (b, vals) = f conn
|
||||
not_ (ERaw p f) = ERaw Never $ \info -> let (b, vals) = f info
|
||||
in ("NOT " <> parensM p b, vals)
|
||||
|
||||
(==.) = unsafeSqlBinOp " = "
|
||||
@ -371,32 +394,39 @@ instance Esqueleto SqlQuery SqlExpr SqlBackend where
|
||||
field *=. expr = setAux field (\ent -> ent ^. field *. expr)
|
||||
field /=. expr = setAux field (\ent -> ent ^. field /. expr)
|
||||
|
||||
(<#) _ (ERaw _ f) = EInsert Proxy f
|
||||
|
||||
(EInsert _ f) <&> (ERaw _ g) = EInsert Proxy $ \x ->
|
||||
let (fb, fv) = f x
|
||||
(gb, gv) = g x
|
||||
in (fb <> ", " <> gb, fv ++ gv)
|
||||
|
||||
|
||||
instance ToSomeValues SqlExpr (SqlExpr (Value a)) where
|
||||
toSomeValues a = [SomeValue a]
|
||||
|
||||
fieldName :: (PersistEntity val, PersistField typ)
|
||||
=> Connection -> EntityField val typ -> TLB.Builder
|
||||
fieldName conn = fromDBName conn . fieldDB . persistFieldDef
|
||||
=> IdentInfo -> EntityField val typ -> TLB.Builder
|
||||
fieldName info = fromDBName info . 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 $ \conn -> (fieldName conn field, mempty)
|
||||
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 $ \conn -> toRawSql mode pureQuery conn query
|
||||
sub mode query = ERaw Parens $ \info -> toRawSql mode pureQuery info query
|
||||
|
||||
fromDBName :: Connection -> DBName -> TLB.Builder
|
||||
fromDBName conn = TLB.fromText . connEscapeName conn
|
||||
fromDBName :: IdentInfo -> DBName -> TLB.Builder
|
||||
fromDBName (conn, _) = TLB.fromText . connEscapeName conn
|
||||
|
||||
existsHelper :: SqlQuery () -> SqlExpr (Value a)
|
||||
existsHelper =
|
||||
ERaw Parens .
|
||||
flip (toRawSql SELECT pureQuery) .
|
||||
(>> return (val True :: SqlExpr (Value Bool)))
|
||||
existsHelper :: SqlQuery () -> SqlExpr (Value Bool)
|
||||
existsHelper = sub SELECT . (>> return true)
|
||||
where
|
||||
true :: SqlExpr (Value Bool)
|
||||
true = val True
|
||||
|
||||
ifNotEmptyList :: SqlExpr (ValueList a) -> Bool -> SqlExpr (Value Bool) -> SqlExpr (Value Bool)
|
||||
ifNotEmptyList EEmptyList b _ = val b
|
||||
@ -421,8 +451,8 @@ ifNotEmptyList (EList _) _ x = x
|
||||
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 conn = let (b1, vals1) = f1 conn
|
||||
(b2, vals2) = f2 conn
|
||||
f info = let (b1, vals1) = f1 info
|
||||
(b2, vals2) = f2 info
|
||||
in ( parensM p1 b1 <> op <> parensM p2 b2
|
||||
, vals1 <> vals2 )
|
||||
{-# INLINE unsafeSqlBinOp #-}
|
||||
@ -440,9 +470,9 @@ unsafeSqlValue v = ERaw Never $ \_ -> (v, mempty)
|
||||
unsafeSqlFunction :: UnsafeSqlFunctionArgument a =>
|
||||
TLB.Builder -> a -> SqlExpr (Value b)
|
||||
unsafeSqlFunction name arg =
|
||||
ERaw Never $ \conn ->
|
||||
ERaw Never $ \info ->
|
||||
let (argsTLB, argsVals) =
|
||||
uncommas' $ map (\(ERaw _ f) -> f conn) $ toArgList arg
|
||||
uncommas' $ map (\(ERaw _ f) -> f info) $ toArgList arg
|
||||
in (name <> parens argsTLB, argsVals)
|
||||
|
||||
class UnsafeSqlFunctionArgument a where
|
||||
@ -504,7 +534,7 @@ rawSelectSource mode query = src
|
||||
run conn =
|
||||
uncurry rawQuery $
|
||||
first builderToText $
|
||||
toRawSql mode pureQuery conn query
|
||||
toRawSql mode pureQuery (conn, initialIdentState) query
|
||||
|
||||
massage = do
|
||||
mrow <- C.await
|
||||
@ -616,7 +646,7 @@ rawEsqueleto mode query = do
|
||||
conn <- SqlPersistT R.ask
|
||||
uncurry rawExecuteCount $
|
||||
first builderToText $
|
||||
toRawSql mode pureQuery conn query
|
||||
toRawSql mode pureQuery (conn, initialIdentState) query
|
||||
|
||||
|
||||
-- | Execute an @esqueleto@ @DELETE@ query inside @persistent@'s
|
||||
@ -700,24 +730,37 @@ 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 -> Connection -> SqlQuery a -> (TLB.Builder, [PersistValue])
|
||||
toRawSql mode qt conn query =
|
||||
let (ret, SideData fromClauses setClauses whereClauses groupByClause havingClause orderByClauses limitClause) =
|
||||
flip S.evalState initialIdentState $
|
||||
toRawSql :: SqlSelect a r => Mode -> QueryType a -> IdentInfo -> SqlQuery a -> (TLB.Builder, [PersistValue])
|
||||
toRawSql mode qt (conn, firstIdentState) query =
|
||||
let ((ret, sd), finalIdentState) =
|
||||
flip S.runState firstIdentState $
|
||||
W.runWriterT $
|
||||
unQ query
|
||||
SideData fromClauses
|
||||
setClauses
|
||||
whereClauses
|
||||
groupByClause
|
||||
havingClause
|
||||
orderByClauses
|
||||
limitClause = sd
|
||||
-- Pass the finalIdentState (containing all identifiers
|
||||
-- that were used) to the subsequent calls. This ensures
|
||||
-- that no name clashes will occur on subqueries that may
|
||||
-- appear on the expressions below.
|
||||
info = (conn, finalIdentState)
|
||||
in mconcat
|
||||
[ makeInsert qt ret
|
||||
, makeSelect conn mode ret
|
||||
, makeFrom conn mode fromClauses
|
||||
, makeSet conn setClauses
|
||||
, makeWhere conn whereClauses
|
||||
, makeGroupBy conn groupByClause
|
||||
, makeHaving conn havingClause
|
||||
, makeOrderBy conn orderByClauses
|
||||
, makeLimit conn limitClause
|
||||
, 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
|
||||
]
|
||||
|
||||
|
||||
-- | (Internal) Mode of query being converted by 'toRawSql'.
|
||||
data Mode = SELECT | SELECT_DISTINCT | DELETE | UPDATE
|
||||
|
||||
@ -744,21 +787,21 @@ uncommas' :: Monoid a => [(TLB.Builder, a)] -> (TLB.Builder, a)
|
||||
uncommas' = (uncommas *** mconcat) . unzip
|
||||
|
||||
|
||||
makeSelect :: SqlSelect a r => Connection -> Mode -> a -> (TLB.Builder, [PersistValue])
|
||||
makeSelect conn mode ret =
|
||||
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 "
|
||||
where
|
||||
withCols v = first (v <>) (sqlSelectCols conn ret)
|
||||
withCols v = first (v <>) (sqlSelectCols info ret)
|
||||
plain v = (v, [])
|
||||
|
||||
|
||||
makeFrom :: Connection -> Mode -> [FromClause] -> (TLB.Builder, [PersistValue])
|
||||
makeFrom :: IdentInfo -> Mode -> [FromClause] -> (TLB.Builder, [PersistValue])
|
||||
makeFrom _ _ [] = mempty
|
||||
makeFrom conn mode fs = ret
|
||||
makeFrom info mode fs = ret
|
||||
where
|
||||
ret = case collectOnClauses fs of
|
||||
Left expr -> throw $ mkExc expr
|
||||
@ -779,8 +822,8 @@ makeFrom conn mode fs = ret
|
||||
base ident@(I identText) def =
|
||||
let db@(DBName dbText) = entityDB def
|
||||
in ( if dbText == identText
|
||||
then fromDBName conn db
|
||||
else fromDBName conn db <> (" AS " <> useIdent conn ident)
|
||||
then fromDBName info db
|
||||
else fromDBName info db <> (" AS " <> useIdent info ident)
|
||||
, mempty )
|
||||
|
||||
fromKind InnerJoinKind = " INNER JOIN "
|
||||
@ -789,56 +832,56 @@ makeFrom conn mode fs = ret
|
||||
fromKind RightOuterJoinKind = " RIGHT OUTER JOIN "
|
||||
fromKind FullOuterJoinKind = " FULL OUTER JOIN "
|
||||
|
||||
makeOnClause (ERaw _ f) = first (" ON " <>) (f conn)
|
||||
makeOnClause (ERaw _ f) = first (" ON " <>) (f info)
|
||||
|
||||
mkExc :: SqlExpr (Value Bool) -> OnClauseWithoutMatchingJoinException
|
||||
mkExc (ERaw _ f) =
|
||||
OnClauseWithoutMatchingJoinException $
|
||||
TL.unpack $ TLB.toLazyText $ fst (f conn)
|
||||
TL.unpack $ TLB.toLazyText $ fst (f info)
|
||||
|
||||
|
||||
makeSet :: Connection -> [SetClause] -> (TLB.Builder, [PersistValue])
|
||||
makeSet :: IdentInfo -> [SetClause] -> (TLB.Builder, [PersistValue])
|
||||
makeSet _ [] = mempty
|
||||
makeSet conn os = first ("\nSET " <>) $ uncommas' (map mk os)
|
||||
makeSet info os = first ("\nSET " <>) $ uncommas' (map mk os)
|
||||
where
|
||||
mk (SetClause (ERaw _ f)) = f conn
|
||||
mk (SetClause (ERaw _ f)) = f info
|
||||
|
||||
|
||||
makeWhere :: Connection -> WhereClause -> (TLB.Builder, [PersistValue])
|
||||
makeWhere :: IdentInfo -> WhereClause -> (TLB.Builder, [PersistValue])
|
||||
makeWhere _ NoWhere = mempty
|
||||
makeWhere conn (Where (ERaw _ f)) = first ("\nWHERE " <>) (f conn)
|
||||
makeWhere info (Where (ERaw _ f)) = first ("\nWHERE " <>) (f info)
|
||||
|
||||
|
||||
makeGroupBy :: Connection -> GroupByClause -> (TLB.Builder, [PersistValue])
|
||||
makeGroupBy :: IdentInfo -> GroupByClause -> (TLB.Builder, [PersistValue])
|
||||
makeGroupBy _ (GroupBy []) = (mempty, [])
|
||||
makeGroupBy conn (GroupBy fields) = first ("\nGROUP BY " <>) build
|
||||
makeGroupBy info (GroupBy fields) = first ("\nGROUP BY " <>) build
|
||||
where
|
||||
build = uncommas' $ map (\(SomeValue (ERaw _ f)) -> f conn) fields
|
||||
build = uncommas' $ map (\(SomeValue (ERaw _ f)) -> f info) fields
|
||||
|
||||
makeHaving :: Connection -> WhereClause -> (TLB.Builder, [PersistValue])
|
||||
makeHaving :: IdentInfo -> WhereClause -> (TLB.Builder, [PersistValue])
|
||||
makeHaving _ NoWhere = mempty
|
||||
makeHaving conn (Where (ERaw _ f)) = first ("\nHAVING " <>) (f conn)
|
||||
makeHaving info (Where (ERaw _ f)) = first ("\nHAVING " <>) (f info)
|
||||
|
||||
makeOrderBy :: Connection -> [OrderByClause] -> (TLB.Builder, [PersistValue])
|
||||
makeOrderBy :: IdentInfo -> [OrderByClause] -> (TLB.Builder, [PersistValue])
|
||||
makeOrderBy _ [] = mempty
|
||||
makeOrderBy conn os = first ("\nORDER BY " <>) $ uncommas' (map mk os)
|
||||
makeOrderBy info os = first ("\nORDER BY " <>) $ uncommas' (map mk os)
|
||||
where
|
||||
mk (EOrderBy t (ERaw p f)) = first ((<> orderByType t) . parensM p) (f conn)
|
||||
mk (EOrderBy t (ERaw p f)) = first ((<> orderByType t) . parensM p) (f info)
|
||||
orderByType ASC = " ASC"
|
||||
orderByType DESC = " DESC"
|
||||
|
||||
|
||||
makeLimit :: Connection -> LimitClause -> (TLB.Builder, [PersistValue])
|
||||
makeLimit :: IdentInfo -> LimitClause -> (TLB.Builder, [PersistValue])
|
||||
makeLimit _ (Limit Nothing Nothing) = mempty
|
||||
makeLimit _ (Limit Nothing (Just 0)) = mempty
|
||||
makeLimit conn (Limit ml mo) = (ret, 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 conn)
|
||||
Nothing -> TLB.fromText (connNoLimit $ fst info)
|
||||
|
||||
offsetTLB =
|
||||
case mo of
|
||||
@ -863,7 +906,7 @@ class SqlSelect a r | a -> r, r -> a where
|
||||
-- | Creates the variable part of the @SELECT@ query and
|
||||
-- returns the list of 'PersistValue's that will be given to
|
||||
-- 'rawQuery'.
|
||||
sqlSelectCols :: Connection -> a -> (TLB.Builder, [PersistValue])
|
||||
sqlSelectCols :: IdentInfo -> a -> (TLB.Builder, [PersistValue])
|
||||
|
||||
-- | Number of columns that will be consumed.
|
||||
sqlSelectColCount :: Proxy a -> Int
|
||||
@ -874,10 +917,11 @@ class SqlSelect a r | a -> r, r -> a where
|
||||
|
||||
-- | You may return an insertion of some PersistEntity
|
||||
instance PersistEntity a => SqlSelect (SqlExpr (Insertion a)) (Insertion a) where
|
||||
sqlSelectCols esc (EInsert _ f) = let (b, vals) = f esc
|
||||
in (b, vals)
|
||||
sqlSelectCols info (EInsert _ f) = f info
|
||||
sqlSelectColCount = const 0
|
||||
sqlSelectProcessRow = const (Right Proxy)
|
||||
sqlSelectProcessRow = const (Right (error msg))
|
||||
where
|
||||
msg = "sqlSelectProcessRow/SqlSelect (SqlExpr (Insertion a)) (Insertion a): never here"
|
||||
|
||||
|
||||
-- | Not useful for 'select', but used for 'update' and 'delete'.
|
||||
@ -889,10 +933,10 @@ instance SqlSelect () () where
|
||||
|
||||
-- | You may return an 'Entity' from a 'select' query.
|
||||
instance PersistEntity a => SqlSelect (SqlExpr (Entity a)) (Entity a) where
|
||||
sqlSelectCols conn expr@(EEntity ident) = ret
|
||||
sqlSelectCols info expr@(EEntity ident) = ret
|
||||
where
|
||||
process ed = uncommas $
|
||||
map ((name <>) . fromDBName conn) $
|
||||
map ((name <>) . fromDBName info) $
|
||||
(entityID ed:) $
|
||||
map fieldDB $
|
||||
entityFields ed
|
||||
@ -902,7 +946,7 @@ instance PersistEntity a => SqlSelect (SqlExpr (Entity a)) (Entity a) where
|
||||
-- clause), while 'rawSql' assumes that it's just the
|
||||
-- name of the table (which doesn't allow self-joins, for
|
||||
-- example).
|
||||
name = useIdent conn ident <> "."
|
||||
name = useIdent info ident <> "."
|
||||
ret = let ed = entityDef $ getEntityVal $ return expr
|
||||
in (process ed, mempty)
|
||||
sqlSelectColCount = (+1) . length . entityFields . entityDef . getEntityVal
|
||||
@ -917,7 +961,7 @@ getEntityVal = const Proxy
|
||||
|
||||
-- | You may return a possibly-@NULL@ 'Entity' from a 'select' query.
|
||||
instance PersistEntity a => SqlSelect (SqlExpr (Maybe (Entity a))) (Maybe (Entity a)) where
|
||||
sqlSelectCols conn (EMaybe ent) = sqlSelectCols conn ent
|
||||
sqlSelectCols info (EMaybe ent) = sqlSelectCols info ent
|
||||
sqlSelectColCount = sqlSelectColCount . fromEMaybe
|
||||
where
|
||||
fromEMaybe :: Proxy (SqlExpr (Maybe e)) -> Proxy (SqlExpr e)
|
||||
@ -930,8 +974,8 @@ instance PersistEntity a => SqlSelect (SqlExpr (Maybe (Entity a))) (Maybe (Entit
|
||||
-- | You may return any single value (i.e. a single column) from
|
||||
-- a 'select' query.
|
||||
instance PersistField a => SqlSelect (SqlExpr (Value a)) (Value a) where
|
||||
sqlSelectCols esc (ERaw p f) = let (b, vals) = f esc
|
||||
in (parensM p b, vals)
|
||||
sqlSelectCols info (ERaw p f) = let (b, vals) = f info
|
||||
in (parensM p b, vals)
|
||||
sqlSelectColCount = const 1
|
||||
sqlSelectProcessRow [pv] = Value <$> fromPersistValue pv
|
||||
sqlSelectProcessRow _ = Left "SqlSelect (Value a): wrong number of columns."
|
||||
@ -1427,23 +1471,14 @@ from16P = const Proxy
|
||||
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,l,m,n,o,p)
|
||||
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,l,m,n,o,p)
|
||||
|
||||
-- | Apply a 'PersistField' constructor to @SqlExpr Value@ arguments
|
||||
(<#) :: (a -> b) -> SqlExpr (Value a) -> SqlExpr (Insertion b)
|
||||
(<#) _ (ERaw _ f) = EInsert Proxy f
|
||||
|
||||
-- | Apply extra @SqlExpr Value@ arguments to a 'PersistField' constructor
|
||||
(<&>) :: SqlExpr (Insertion (a -> b)) -> SqlExpr (Value a) -> SqlExpr (Insertion b)
|
||||
(EInsert _ f) <&> (ERaw _ g) = EInsert Proxy $ \x->
|
||||
let (fb, fv) = f x
|
||||
(gb, gv) = g x
|
||||
in (fb <> ", " <> gb, fv ++ gv)
|
||||
|
||||
-- | Insert a 'PersistField' for every selected value
|
||||
-- | Insert a 'PersistField' for every selected value.
|
||||
insertSelect :: (MonadLogger m, MonadResourceBase m, SqlSelect (SqlExpr (Insertion a)) r, PersistEntity a) =>
|
||||
SqlQuery (SqlExpr (Insertion a)) -> SqlPersistT m ()
|
||||
insertSelect = insertGeneralSelect SELECT
|
||||
|
||||
-- | Insert a 'PersistField' for every unique selected value
|
||||
|
||||
-- | Insert a 'PersistField' for every unique selected value.
|
||||
insertSelectDistinct :: (MonadLogger m, MonadResourceBase m, SqlSelect (SqlExpr (Insertion a)) r, PersistEntity a) =>
|
||||
SqlQuery (SqlExpr (Insertion a)) -> SqlPersistT m ()
|
||||
insertSelectDistinct = insertGeneralSelect SELECT_DISTINCT
|
||||
@ -1453,4 +1488,4 @@ insertGeneralSelect :: (MonadLogger m, MonadResourceBase m, SqlSelect (SqlExpr (
|
||||
Mode -> SqlQuery (SqlExpr (Insertion a)) -> SqlPersistT m ()
|
||||
insertGeneralSelect mode query = do
|
||||
conn <- SqlPersistT R.ask
|
||||
uncurry rawExecute $ first builderToText $ toRawSql mode insertQuery conn query
|
||||
uncurry rawExecute $ first builderToText $ toRawSql mode insertQuery (conn, initialIdentState) query
|
||||
|
||||
122
test/Test.hs
122
test/Test.hs
@ -10,6 +10,7 @@
|
||||
, TemplateHaskell
|
||||
, TypeFamilies
|
||||
, ScopedTypeVariables
|
||||
, CPP
|
||||
#-}
|
||||
module Main (main) where
|
||||
|
||||
@ -20,11 +21,22 @@ import Control.Monad.Logger (MonadLogger(..), runStderrLoggingT, runNoLoggingT)
|
||||
import Control.Monad.Trans.Control (MonadBaseControl(..))
|
||||
import Database.Esqueleto
|
||||
import Database.Persist.Sqlite (withSqliteConn)
|
||||
#if defined (WITH_POSTGRESQL)
|
||||
import Database.Persist.Postgresql (withPostgresqlConn)
|
||||
#elif defined (WITH_MYSQL)
|
||||
import Database.Persist.MySQL ( withMySQLConn
|
||||
, connectHost
|
||||
, connectDatabase
|
||||
, connectUser
|
||||
, connectPassword
|
||||
, defaultConnectInfo)
|
||||
#endif
|
||||
import Database.Persist.TH
|
||||
import Test.Hspec
|
||||
|
||||
import qualified Data.Conduit as C
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.List as L
|
||||
|
||||
|
||||
-- Test schema
|
||||
@ -43,6 +55,10 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|
|
||||
deriving Eq Show
|
||||
|]
|
||||
|
||||
-- | this could be achieved with S.fromList, but not all lists
|
||||
-- have Ord instances
|
||||
sameElementsAs :: Eq a => [a] -> [a] -> Bool
|
||||
sameElementsAs l1 l2 = null (l1 L.\\ l2)
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
@ -96,10 +112,41 @@ main = do
|
||||
ret <- select $
|
||||
from $ \(person1, person2) ->
|
||||
return (person1, person2)
|
||||
liftIO $ ret `shouldBe` [ (p1e, p1e)
|
||||
, (p1e, p2e)
|
||||
, (p2e, p1e)
|
||||
, (p2e, p2e) ]
|
||||
liftIO $ ret `shouldSatisfy` sameElementsAs [ (p1e, p1e)
|
||||
, (p1e, p2e)
|
||||
, (p2e, p1e)
|
||||
, (p2e, p2e) ]
|
||||
|
||||
it "works for a self-join via sub_select" $
|
||||
run $ do
|
||||
p1k <- insert p1
|
||||
p2k <- insert p2
|
||||
f1k <- insert (Follow p1k p2k)
|
||||
f2k <- insert (Follow p2k p1k)
|
||||
ret <- select $
|
||||
from $ \followA -> do
|
||||
let subquery =
|
||||
from $ \followB -> do
|
||||
where_ $ followA ^. FollowFollower ==. followB ^. FollowFollowed
|
||||
return $ followB ^. FollowFollower
|
||||
where_ $ followA ^. FollowFollowed ==. sub_select subquery
|
||||
return followA
|
||||
liftIO $ length ret `shouldBe` 2
|
||||
|
||||
it "works for a self-join via exists" $
|
||||
run $ do
|
||||
p1k <- insert p1
|
||||
p2k <- insert p2
|
||||
f1k <- insert (Follow p1k p2k)
|
||||
f2k <- insert (Follow p2k p1k)
|
||||
ret <- select $
|
||||
from $ \followA -> do
|
||||
where_ $ exists $
|
||||
from $ \followB ->
|
||||
where_ $ followA ^. FollowFollower ==. followB ^. FollowFollowed
|
||||
return followA
|
||||
liftIO $ length ret `shouldBe` 2
|
||||
|
||||
|
||||
it "works for a simple projection" $
|
||||
run $ do
|
||||
@ -118,7 +165,8 @@ main = do
|
||||
ret <- select $
|
||||
from $ \(pa, pb) ->
|
||||
return (pa ^. PersonName, pb ^. PersonName)
|
||||
liftIO $ ret `shouldBe` [ (Value (personName p1), Value (personName p1))
|
||||
liftIO $ ret `shouldSatisfy` sameElementsAs
|
||||
[ (Value (personName p1), Value (personName p1))
|
||||
, (Value (personName p1), Value (personName p2))
|
||||
, (Value (personName p2), Value (personName p1))
|
||||
, (Value (personName p2), Value (personName p2)) ]
|
||||
@ -312,7 +360,11 @@ main = do
|
||||
|
||||
it "works with random_" $
|
||||
run $ do
|
||||
#if defined(WITH_POSTGRESQL) || defined(WITH_MYSQL)
|
||||
ret <- select $ return (random_ :: SqlExpr (Value Double))
|
||||
#else
|
||||
ret <- select $ return (random_ :: SqlExpr (Value Int))
|
||||
#endif
|
||||
return ()
|
||||
|
||||
it "works with round_" $
|
||||
@ -431,7 +483,13 @@ main = do
|
||||
from $ \p -> do
|
||||
orderBy [asc (p ^. PersonAge), asc (p ^. PersonName)]
|
||||
return p
|
||||
-- in PostgreSQL nulls are bigger than everything
|
||||
#ifdef WITH_POSTGRESQL
|
||||
liftIO $ ret `shouldBe` [ p4e, p3e, p1e , p2e ]
|
||||
#else
|
||||
-- in SQLite and MySQL, its the reverse
|
||||
liftIO $ ret `shouldBe` [ p2e, p4e, p3e, p1e ]
|
||||
#endif
|
||||
|
||||
it "works with one ASC and one DESC field" $
|
||||
run $ do
|
||||
@ -443,7 +501,11 @@ main = do
|
||||
from $ \p -> do
|
||||
orderBy [desc (p ^. PersonAge), asc (p ^. PersonName)]
|
||||
return p
|
||||
#ifdef WITH_POSTGRESQL
|
||||
liftIO $ ret `shouldBe` [ p2e, p1e, p4e, p3e ]
|
||||
#else
|
||||
liftIO $ ret `shouldBe` [ p1e, p4e, p3e, p2e ]
|
||||
#endif
|
||||
|
||||
it "works with a sub_select" $
|
||||
run $ do
|
||||
@ -547,10 +609,27 @@ main = do
|
||||
from $ \p -> do
|
||||
orderBy [ asc (p ^. PersonName), asc (p ^. PersonAge) ]
|
||||
return p
|
||||
-- PostgreSQL: nulls are bigger than data, and update returns
|
||||
-- matched rows, not actually changed rows.
|
||||
#if defined(WITH_POSTGRESQL)
|
||||
liftIO $ n `shouldBe` 2
|
||||
liftIO $ ret `shouldBe` [ Entity p1k (Person anon (Just 73))
|
||||
, Entity p2k (Person anon Nothing)
|
||||
, Entity p3k p3 ]
|
||||
-- MySQL: nulls appear first, and update returns actual number
|
||||
-- of changed rows
|
||||
#elif defined(WITH_MYSQL)
|
||||
liftIO $ n `shouldBe` 1
|
||||
liftIO $ ret `shouldBe` [ Entity p2k (Person anon Nothing)
|
||||
, Entity p1k (Person anon (Just 73))
|
||||
, Entity p3k p3 ]
|
||||
#else
|
||||
-- SQLite: nulls appear first, update returns matched rows.
|
||||
liftIO $ n `shouldBe` 2
|
||||
liftIO $ ret `shouldBe` [ Entity p2k (Person anon Nothing)
|
||||
, Entity p1k (Person anon (Just 73))
|
||||
, Entity p3k p3 ]
|
||||
#endif
|
||||
|
||||
it "works with a subexpression having COUNT(*)" $
|
||||
run $ do
|
||||
@ -724,6 +803,20 @@ insert' v = flip Entity v <$> insert v
|
||||
type RunDbMonad m = ( MonadBaseControl IO m, MonadIO m, MonadLogger m
|
||||
, C.MonadUnsafeIO m, C.MonadThrow m )
|
||||
|
||||
#if defined (WITH_POSTGRESQL) || defined (WITH_MYSQL)
|
||||
-- With SQLite and in-memory databases, a separate connection implies a
|
||||
-- separate database. With 'actual databases', the data is persistent and
|
||||
-- thus must be cleaned after each test.
|
||||
-- TODO: there is certainly a better way...
|
||||
cleanDB
|
||||
:: (forall m. RunDbMonad m
|
||||
=> SqlPersistT (C.ResourceT m) ())
|
||||
cleanDB = do
|
||||
delete $ from $ \(blogpost :: SqlExpr (Entity BlogPost))-> return ()
|
||||
delete $ from $ \(follow :: SqlExpr (Entity Follow)) -> return ()
|
||||
delete $ from $ \(person :: SqlExpr (Entity Person)) -> return ()
|
||||
#endif
|
||||
|
||||
|
||||
run, runSilent, runVerbose :: (forall m. RunDbMonad m => SqlPersistT (C.ResourceT m) a) -> IO a
|
||||
runSilent act = runNoLoggingT $ run_worker act
|
||||
@ -739,8 +832,23 @@ verbose = True
|
||||
|
||||
|
||||
run_worker :: RunDbMonad m => SqlPersistT (C.ResourceT m) a -> m a
|
||||
run_worker =
|
||||
run_worker act =
|
||||
C.runResourceT .
|
||||
#if defined(WITH_POSTGRESQL)
|
||||
withPostgresqlConn "host=localhost port=5432 user=test dbname=test" .
|
||||
#elif defined (WITH_MYSQL)
|
||||
withMySQLConn defaultConnectInfo
|
||||
{ connectHost = "localhost"
|
||||
, connectUser = "test"
|
||||
, connectPassword = "test"
|
||||
, connectDatabase = "test"
|
||||
} .
|
||||
#else
|
||||
withSqliteConn ":memory:" .
|
||||
#endif
|
||||
runSqlConn .
|
||||
(runMigrationSilent migrateAll >>)
|
||||
#if defined (WITH_POSTGRESQL) || defined (WITH_MYSQL)
|
||||
(runMigrationSilent migrateAll >>) $ (cleanDB >> act)
|
||||
#else
|
||||
(runMigrationSilent migrateAll >>) $ act
|
||||
#endif
|
||||
|
||||
Loading…
Reference in New Issue
Block a user