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

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

Browse Source
This commit is contained in:
João Cristóvão 2013-09-15 21:57:04 +01:00
commit 0033050806
4 changed files with 278 additions and 99 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
esqueleto.cabal
View File

@ -1,5 +1,5 @@
name: esqueleto name: esqueleto
version: 1.3.3 version: 1.3.4.2
synopsis: Bare bones, type-safe EDSL for SQL queries on persistent backends. synopsis: Bare bones, 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
@ -47,6 +47,14 @@ source-repository head
type: git type: git
location: git://github.com/meteficha/esqueleto.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 library
exposed-modules: exposed-modules:
Database.Esqueleto Database.Esqueleto
@ -90,3 +98,20 @@ test-suite test
-- This library -- This library
, esqueleto , 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

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

@ -27,6 +27,7 @@ module Database.Esqueleto.Internal.Language
, OnClauseWithoutMatchingJoinException(..) , OnClauseWithoutMatchingJoinException(..)
, OrderBy , OrderBy
, Update , Update
, Insertion
-- * The guts -- * The guts
, JoinKind(..) , JoinKind(..)
, IsJoinKind(..) , 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)
(/=.) :: (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 -- Fixity declarations
infixl 9 ^. infixl 9 ^.
@ -492,6 +499,10 @@ data OrderBy
data Update typ data Update typ
-- | Phantom type used by 'insertSelect'.
data Insertion a
-- | @FROM@ clause: bring entities into scope. -- | @FROM@ clause: bring entities into scope.
-- --
-- This function internally uses two type classes in order to -- This function internally uses two type classes in order to

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

@ -23,6 +23,8 @@ module Database.Esqueleto.Internal.Sql
, deleteCount , deleteCount
, update , update
, updateCount , updateCount
, insertSelectDistinct
, insertSelect
-- * The guts -- * The guts
, unsafeSqlBinOp , unsafeSqlBinOp
, unsafeSqlValue , unsafeSqlValue
@ -33,12 +35,11 @@ module Database.Esqueleto.Internal.Sql
, rawEsqueleto , rawEsqueleto
, toRawSql , toRawSql
, Mode(..) , Mode(..)
, IdentState
, initialIdentState
, IdentInfo
, SqlSelect , SqlSelect
, veryUnsafeCoerceSqlExprValue , veryUnsafeCoerceSqlExprValue
, insertSelectDistinct
, insertSelect
, (<#)
, (<&>)
) where ) where
import Control.Applicative (Applicative(..), (<$>), (<$)) import Control.Applicative (Applicative(..), (<$>), (<$))
@ -221,27 +222,49 @@ newIdentFor = Q . lift . try . unDBName
return (I t) return (I t)
-- | Information needed to escape and use identifiers.
type IdentInfo = (Connection, IdentState)
-- | Use an identifier. -- | Use an identifier.
useIdent :: Connection -> Ident -> TLB.Builder useIdent :: IdentInfo -> Ident -> TLB.Builder
useIdent conn (I ident) = fromDBName conn $ DBName ident useIdent info (I ident) = fromDBName info $ DBName ident
---------------------------------------------------------------------- ----------------------------------------------------------------------
type Insertion = Proxy
-- | An expression on the SQL backend. -- | An expression on the SQL backend.
data SqlExpr a where 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) EEntity :: Ident -> SqlExpr (Entity val)
-- Just a tag stating that something is nullable.
EMaybe :: SqlExpr a -> SqlExpr (Maybe a) 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) EEmptyList :: SqlExpr (ValueList a)
-- A 'SqlExpr' accepted only by 'orderBy'.
EOrderBy :: OrderByType -> SqlExpr (Value a) -> SqlExpr 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) EPreprocessedFrom :: a -> FromClause -> SqlExpr (PreprocessedFrom a)
-- Used by 'insertSelect'.
EInsert :: Proxy a -> (IdentInfo -> (TLB.Builder, [PersistValue])) -> SqlExpr (Insertion a)
data NeedParens = Parens | Never data NeedParens = Parens | Never
parensM :: NeedParens -> TLB.Builder -> TLB.Builder parensM :: NeedParens -> TLB.Builder -> TLB.Builder
@ -301,7 +324,7 @@ instance Esqueleto SqlQuery SqlExpr SqlBackend where
sub_selectDistinct = sub SELECT_DISTINCT sub_selectDistinct = sub SELECT_DISTINCT
EEntity ident ^. field = 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) EMaybe r ?. field = maybelize (r ^. field)
where where
@ -315,10 +338,10 @@ instance Esqueleto SqlQuery SqlExpr SqlBackend where
nothing = unsafeSqlValue "NULL" nothing = unsafeSqlValue "NULL"
joinV (ERaw p f) = ERaw p f joinV (ERaw p f) = ERaw p f
countRows = unsafeSqlValue "COUNT(*)" 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) 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) in ("NOT " <> parensM p b, vals)
(==.) = unsafeSqlBinOp " = " (==.) = 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)
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 instance ToSomeValues SqlExpr (SqlExpr (Value a)) where
toSomeValues a = [SomeValue a] toSomeValues a = [SomeValue a]
fieldName :: (PersistEntity val, PersistField typ) fieldName :: (PersistEntity val, PersistField typ)
=> Connection -> EntityField val typ -> TLB.Builder => IdentInfo -> EntityField val typ -> TLB.Builder
fieldName conn = fromDBName conn . fieldDB . persistFieldDef fieldName info = fromDBName info . fieldDB . persistFieldDef
setAux :: (PersistEntity val, PersistField typ) setAux :: (PersistEntity val, PersistField typ)
=> EntityField val typ => EntityField val typ
-> (SqlExpr (Entity val) -> SqlExpr (Value typ)) -> (SqlExpr (Entity val) -> SqlExpr (Value typ))
-> SqlExpr (Update val) -> SqlExpr (Update val)
setAux field mkVal = ESet $ \ent -> unsafeSqlBinOp " = " name (mkVal ent) 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 :: 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 :: IdentInfo -> DBName -> TLB.Builder
fromDBName conn = TLB.fromText . connEscapeName conn fromDBName (conn, _) = TLB.fromText . connEscapeName conn
existsHelper :: SqlQuery () -> SqlExpr (Value a) existsHelper :: SqlQuery () -> SqlExpr (Value Bool)
existsHelper = existsHelper = sub SELECT . (>> return true)
ERaw Parens . where
flip (toRawSql SELECT pureQuery) . true :: SqlExpr (Value Bool)
(>> return (val True :: SqlExpr (Value Bool))) true = val True
ifNotEmptyList :: SqlExpr (ValueList a) -> Bool -> SqlExpr (Value Bool) -> SqlExpr (Value Bool) ifNotEmptyList :: SqlExpr (ValueList a) -> Bool -> SqlExpr (Value Bool) -> SqlExpr (Value Bool)
ifNotEmptyList EEmptyList b _ = val b 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 :: TLB.Builder -> SqlExpr (Value a) -> SqlExpr (Value b) -> SqlExpr (Value c)
unsafeSqlBinOp op (ERaw p1 f1) (ERaw p2 f2) = ERaw Parens f unsafeSqlBinOp op (ERaw p1 f1) (ERaw p2 f2) = ERaw Parens f
where where
f conn = let (b1, vals1) = f1 conn f info = let (b1, vals1) = f1 info
(b2, vals2) = f2 conn (b2, vals2) = f2 info
in ( parensM p1 b1 <> op <> parensM p2 b2 in ( parensM p1 b1 <> op <> parensM p2 b2
, vals1 <> vals2 ) , vals1 <> vals2 )
{-# INLINE unsafeSqlBinOp #-} {-# INLINE unsafeSqlBinOp #-}
@ -440,9 +470,9 @@ unsafeSqlValue v = ERaw Never $ \_ -> (v, mempty)
unsafeSqlFunction :: UnsafeSqlFunctionArgument a => unsafeSqlFunction :: UnsafeSqlFunctionArgument a =>
TLB.Builder -> a -> SqlExpr (Value b) TLB.Builder -> a -> SqlExpr (Value b)
unsafeSqlFunction name arg = unsafeSqlFunction name arg =
ERaw Never $ \conn -> ERaw Never $ \info ->
let (argsTLB, argsVals) = let (argsTLB, argsVals) =
uncommas' $ map (\(ERaw _ f) -> f conn) $ toArgList arg uncommas' $ map (\(ERaw _ f) -> f info) $ toArgList arg
in (name <> parens argsTLB, argsVals) in (name <> parens argsTLB, argsVals)
class UnsafeSqlFunctionArgument a where class UnsafeSqlFunctionArgument a where
@ -504,7 +534,7 @@ rawSelectSource mode query = src
run conn = run conn =
uncurry rawQuery $ uncurry rawQuery $
first builderToText $ first builderToText $
toRawSql mode pureQuery conn query toRawSql mode pureQuery (conn, initialIdentState) query
massage = do massage = do
mrow <- C.await mrow <- C.await
@ -616,7 +646,7 @@ rawEsqueleto mode query = do
conn <- SqlPersistT R.ask conn <- SqlPersistT R.ask
uncurry rawExecuteCount $ uncurry rawExecuteCount $
first builderToText $ first builderToText $
toRawSql mode pureQuery conn query toRawSql mode pureQuery (conn, initialIdentState) query
-- | Execute an @esqueleto@ @DELETE@ query inside @persistent@'s -- | 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 -- @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 -> Connection -> SqlQuery a -> (TLB.Builder, [PersistValue]) toRawSql :: SqlSelect a r => Mode -> QueryType a -> IdentInfo -> SqlQuery a -> (TLB.Builder, [PersistValue])
toRawSql mode qt conn query = toRawSql mode qt (conn, firstIdentState) query =
let (ret, SideData fromClauses setClauses whereClauses groupByClause havingClause orderByClauses limitClause) = let ((ret, sd), finalIdentState) =
flip S.evalState initialIdentState $ flip S.runState firstIdentState $
W.runWriterT $ W.runWriterT $
unQ query 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 in mconcat
[ makeInsert qt ret [ makeInsert qt ret
, makeSelect conn mode ret , makeSelect info mode ret
, makeFrom conn mode fromClauses , makeFrom info mode fromClauses
, makeSet conn setClauses , makeSet info setClauses
, makeWhere conn whereClauses , makeWhere info whereClauses
, makeGroupBy conn groupByClause , makeGroupBy info groupByClause
, makeHaving conn havingClause , makeHaving info havingClause
, makeOrderBy conn orderByClauses , makeOrderBy info orderByClauses
, makeLimit conn limitClause , makeLimit info limitClause
] ]
-- | (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
@ -744,21 +787,21 @@ uncommas' :: Monoid a => [(TLB.Builder, a)] -> (TLB.Builder, a)
uncommas' = (uncommas *** mconcat) . unzip uncommas' = (uncommas *** mconcat) . unzip
makeSelect :: SqlSelect a r => Connection -> Mode -> a -> (TLB.Builder, [PersistValue]) makeSelect :: SqlSelect a r => IdentInfo -> Mode -> a -> (TLB.Builder, [PersistValue])
makeSelect conn mode ret = makeSelect info mode ret =
case mode of case mode of
SELECT -> withCols "SELECT " SELECT -> withCols "SELECT "
SELECT_DISTINCT -> withCols "SELECT DISTINCT " SELECT_DISTINCT -> withCols "SELECT DISTINCT "
DELETE -> plain "DELETE " DELETE -> plain "DELETE "
UPDATE -> plain "UPDATE " UPDATE -> plain "UPDATE "
where where
withCols v = first (v <>) (sqlSelectCols conn ret) withCols v = first (v <>) (sqlSelectCols info ret)
plain v = (v, []) plain v = (v, [])
makeFrom :: Connection -> Mode -> [FromClause] -> (TLB.Builder, [PersistValue]) makeFrom :: IdentInfo -> Mode -> [FromClause] -> (TLB.Builder, [PersistValue])
makeFrom _ _ [] = mempty makeFrom _ _ [] = mempty
makeFrom conn mode fs = ret makeFrom info mode fs = ret
where where
ret = case collectOnClauses fs of ret = case collectOnClauses fs of
Left expr -> throw $ mkExc expr Left expr -> throw $ mkExc expr
@ -779,8 +822,8 @@ makeFrom conn mode fs = ret
base ident@(I identText) def = base ident@(I identText) def =
let db@(DBName dbText) = entityDB def let db@(DBName dbText) = entityDB def
in ( if dbText == identText in ( if dbText == identText
then fromDBName conn db then fromDBName info db
else fromDBName conn db <> (" AS " <> useIdent conn ident) else fromDBName info db <> (" AS " <> useIdent info ident)
, mempty ) , mempty )
fromKind InnerJoinKind = " INNER JOIN " fromKind InnerJoinKind = " INNER JOIN "
@ -789,56 +832,56 @@ makeFrom conn mode fs = ret
fromKind RightOuterJoinKind = " RIGHT OUTER JOIN " fromKind RightOuterJoinKind = " RIGHT OUTER JOIN "
fromKind FullOuterJoinKind = " FULL 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 :: SqlExpr (Value Bool) -> OnClauseWithoutMatchingJoinException
mkExc (ERaw _ f) = mkExc (ERaw _ f) =
OnClauseWithoutMatchingJoinException $ 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 _ [] = mempty
makeSet conn os = first ("\nSET " <>) $ uncommas' (map mk os) makeSet info os = first ("\nSET " <>) $ uncommas' (map mk os)
where 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 _ 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 _ (GroupBy []) = (mempty, [])
makeGroupBy conn (GroupBy fields) = first ("\nGROUP BY " <>) build makeGroupBy info (GroupBy fields) = first ("\nGROUP BY " <>) build
where 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 _ 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 _ [] = mempty
makeOrderBy conn os = first ("\nORDER BY " <>) $ uncommas' (map mk os) makeOrderBy info os = first ("\nORDER BY " <>) $ uncommas' (map mk os)
where 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 ASC = " ASC"
orderByType DESC = " DESC" orderByType DESC = " DESC"
makeLimit :: Connection -> LimitClause -> (TLB.Builder, [PersistValue]) makeLimit :: IdentInfo -> LimitClause -> (TLB.Builder, [PersistValue])
makeLimit _ (Limit Nothing Nothing) = mempty makeLimit _ (Limit Nothing Nothing) = mempty
makeLimit _ (Limit Nothing (Just 0)) = mempty makeLimit _ (Limit Nothing (Just 0)) = mempty
makeLimit conn (Limit ml mo) = (ret, mempty) makeLimit info (Limit ml mo) = (ret, mempty)
where where
ret = TLB.singleton '\n' <> (limitTLB <> offsetTLB) ret = TLB.singleton '\n' <> (limitTLB <> offsetTLB)
limitTLB = limitTLB =
case ml of case ml of
Just l -> "LIMIT " <> TLBI.decimal l Just l -> "LIMIT " <> TLBI.decimal l
Nothing -> TLB.fromText (connNoLimit conn) Nothing -> TLB.fromText (connNoLimit $ fst info)
offsetTLB = offsetTLB =
case mo of 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 -- | Creates the variable part of the @SELECT@ query and
-- returns the list of 'PersistValue's that will be given to -- returns the list of 'PersistValue's that will be given to
-- 'rawQuery'. -- 'rawQuery'.
sqlSelectCols :: Connection -> a -> (TLB.Builder, [PersistValue]) sqlSelectCols :: IdentInfo -> a -> (TLB.Builder, [PersistValue])
-- | Number of columns that will be consumed. -- | Number of columns that will be consumed.
sqlSelectColCount :: Proxy a -> Int 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 -- | You may return an insertion of some PersistEntity
instance PersistEntity a => SqlSelect (SqlExpr (Insertion a)) (Insertion a) where instance PersistEntity a => SqlSelect (SqlExpr (Insertion a)) (Insertion a) where
sqlSelectCols esc (EInsert _ f) = let (b, vals) = f esc sqlSelectCols info (EInsert _ f) = f info
in (b, vals)
sqlSelectColCount = const 0 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'. -- | 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. -- | You may return an 'Entity' from a 'select' query.
instance PersistEntity a => SqlSelect (SqlExpr (Entity a)) (Entity a) where instance PersistEntity a => SqlSelect (SqlExpr (Entity a)) (Entity a) where
sqlSelectCols conn expr@(EEntity ident) = ret sqlSelectCols info expr@(EEntity ident) = ret
where where
process ed = uncommas $ process ed = uncommas $
map ((name <>) . fromDBName conn) $ map ((name <>) . fromDBName info) $
(entityID ed:) $ (entityID ed:) $
map fieldDB $ map fieldDB $
entityFields ed 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 -- clause), while 'rawSql' assumes that it's just the
-- name of the table (which doesn't allow self-joins, for -- name of the table (which doesn't allow self-joins, for
-- example). -- example).
name = useIdent conn ident <> "." name = useIdent info ident <> "."
ret = let ed = entityDef $ getEntityVal $ return expr ret = let ed = entityDef $ getEntityVal $ return expr
in (process ed, mempty) in (process ed, mempty)
sqlSelectColCount = (+1) . length . entityFields . entityDef . getEntityVal sqlSelectColCount = (+1) . length . entityFields . entityDef . getEntityVal
@ -917,7 +961,7 @@ getEntityVal = const Proxy
-- | You may return a possibly-@NULL@ 'Entity' from a 'select' query. -- | You may return a possibly-@NULL@ 'Entity' from a 'select' query.
instance PersistEntity a => SqlSelect (SqlExpr (Maybe (Entity a))) (Maybe (Entity a)) where 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 sqlSelectColCount = sqlSelectColCount . fromEMaybe
where where
fromEMaybe :: Proxy (SqlExpr (Maybe e)) -> Proxy (SqlExpr e) 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 -- | You may return any single value (i.e. a single column) from
-- a 'select' query. -- a 'select' query.
instance PersistField a => SqlSelect (SqlExpr (Value a)) (Value a) where instance PersistField a => SqlSelect (SqlExpr (Value a)) (Value a) where
sqlSelectCols esc (ERaw p f) = let (b, vals) = f esc sqlSelectCols info (ERaw p f) = let (b, vals) = f info
in (parensM p b, vals) in (parensM p b, vals)
sqlSelectColCount = const 1 sqlSelectColCount = const 1
sqlSelectProcessRow [pv] = Value <$> fromPersistValue pv sqlSelectProcessRow [pv] = Value <$> fromPersistValue pv
sqlSelectProcessRow _ = Left "SqlSelect (Value a): wrong number of columns." 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)
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 -- | Insert a 'PersistField' for every selected value.
(<&>) :: 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
insertSelect :: (MonadLogger m, MonadResourceBase m, SqlSelect (SqlExpr (Insertion a)) r, PersistEntity a) => insertSelect :: (MonadLogger m, MonadResourceBase m, SqlSelect (SqlExpr (Insertion a)) r, 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 :: (MonadLogger m, MonadResourceBase m, SqlSelect (SqlExpr (Insertion a)) r, PersistEntity a) => insertSelectDistinct :: (MonadLogger m, MonadResourceBase m, SqlSelect (SqlExpr (Insertion a)) r, PersistEntity a) =>
SqlQuery (SqlExpr (Insertion a)) -> SqlPersistT m () SqlQuery (SqlExpr (Insertion a)) -> SqlPersistT m ()
insertSelectDistinct = insertGeneralSelect SELECT_DISTINCT insertSelectDistinct = insertGeneralSelect SELECT_DISTINCT
@ -1453,4 +1488,4 @@ insertGeneralSelect :: (MonadLogger m, MonadResourceBase m, SqlSelect (SqlExpr (
Mode -> SqlQuery (SqlExpr (Insertion a)) -> SqlPersistT m () Mode -> SqlQuery (SqlExpr (Insertion a)) -> SqlPersistT m ()
insertGeneralSelect mode query = do insertGeneralSelect mode query = do
conn <- SqlPersistT R.ask 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
View File

@ -10,6 +10,7 @@
, TemplateHaskell , TemplateHaskell
, TypeFamilies , TypeFamilies
, ScopedTypeVariables , ScopedTypeVariables
, CPP
#-} #-}
module Main (main) where module Main (main) where
@ -20,11 +21,22 @@ import Control.Monad.Logger (MonadLogger(..), runStderrLoggingT, runNoLoggingT)
import Control.Monad.Trans.Control (MonadBaseControl(..)) import Control.Monad.Trans.Control (MonadBaseControl(..))
import Database.Esqueleto import Database.Esqueleto
import Database.Persist.Sqlite (withSqliteConn) 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 Database.Persist.TH
import Test.Hspec import Test.Hspec
import qualified Data.Conduit as C import qualified Data.Conduit as C
import qualified Data.Set as S import qualified Data.Set as S
import qualified Data.List as L
-- Test schema -- Test schema
@ -43,6 +55,10 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|
deriving Eq Show 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 :: IO ()
main = do main = do
@ -96,10 +112,41 @@ main = do
ret <- select $ ret <- select $
from $ \(person1, person2) -> from $ \(person1, person2) ->
return (person1, person2) return (person1, person2)
liftIO $ ret `shouldBe` [ (p1e, p1e) liftIO $ ret `shouldSatisfy` sameElementsAs [ (p1e, p1e)
, (p1e, p2e) , (p1e, p2e)
, (p2e, p1e) , (p2e, p1e)
, (p2e, p2e) ] , (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" $ it "works for a simple projection" $
run $ do run $ do
@ -118,7 +165,8 @@ main = do
ret <- select $ ret <- select $
from $ \(pa, pb) -> from $ \(pa, pb) ->
return (pa ^. PersonName, pb ^. PersonName) 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 p1), Value (personName p2))
, (Value (personName p2), Value (personName p1)) , (Value (personName p2), Value (personName p1))
, (Value (personName p2), Value (personName p2)) ] , (Value (personName p2), Value (personName p2)) ]
@ -312,7 +360,11 @@ main = do
it "works with random_" $ it "works with random_" $
run $ do run $ do
#if defined(WITH_POSTGRESQL) || defined(WITH_MYSQL)
ret <- select $ return (random_ :: SqlExpr (Value Double))
#else
ret <- select $ return (random_ :: SqlExpr (Value Int)) ret <- select $ return (random_ :: SqlExpr (Value Int))
#endif
return () return ()
it "works with round_" $ it "works with round_" $
@ -431,7 +483,13 @@ main = do
from $ \p -> do from $ \p -> do
orderBy [asc (p ^. PersonAge), asc (p ^. PersonName)] orderBy [asc (p ^. PersonAge), asc (p ^. PersonName)]
return p 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 ] liftIO $ ret `shouldBe` [ p2e, p4e, p3e, p1e ]
#endif
it "works with one ASC and one DESC field" $ it "works with one ASC and one DESC field" $
run $ do run $ do
@ -443,7 +501,11 @@ main = do
from $ \p -> do from $ \p -> do
orderBy [desc (p ^. PersonAge), asc (p ^. PersonName)] orderBy [desc (p ^. PersonAge), asc (p ^. PersonName)]
return p return p
#ifdef WITH_POSTGRESQL
liftIO $ ret `shouldBe` [ p2e, p1e, p4e, p3e ]
#else
liftIO $ ret `shouldBe` [ p1e, p4e, p3e, p2e ] liftIO $ ret `shouldBe` [ p1e, p4e, p3e, p2e ]
#endif
it "works with a sub_select" $ it "works with a sub_select" $
run $ do run $ do
@ -547,10 +609,27 @@ main = do
from $ \p -> do from $ \p -> do
orderBy [ asc (p ^. PersonName), asc (p ^. PersonAge) ] orderBy [ asc (p ^. PersonName), asc (p ^. PersonAge) ]
return p 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 $ n `shouldBe` 2
liftIO $ ret `shouldBe` [ Entity p2k (Person anon Nothing) liftIO $ ret `shouldBe` [ Entity p2k (Person anon Nothing)
, Entity p1k (Person anon (Just 73)) , Entity p1k (Person anon (Just 73))
, Entity p3k p3 ] , Entity p3k p3 ]
#endif
it "works with a subexpression having COUNT(*)" $ it "works with a subexpression having COUNT(*)" $
run $ do run $ do
@ -724,6 +803,20 @@ 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 ) , 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 run, runSilent, runVerbose :: (forall m. RunDbMonad m => SqlPersistT (C.ResourceT m) a) -> IO a
runSilent act = runNoLoggingT $ run_worker act 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 :: RunDbMonad m => SqlPersistT (C.ResourceT m) a -> m a
run_worker = run_worker act =
C.runResourceT . 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:" . withSqliteConn ":memory:" .
#endif
runSqlConn . runSqlConn .
(runMigrationSilent migrateAll >>) #if defined (WITH_POSTGRESQL) || defined (WITH_MYSQL)
(runMigrationSilent migrateAll >>) $ (cleanDB >> act)
#else
(runMigrationSilent migrateAll >>) $ act
#endif