module Database.Esqueleto.Internal.Sql
(
SqlQuery
, SqlExpr
, SqlEntity
, select
, selectSource
, selectDistinct
, selectDistinctSource
, delete
, deleteCount
, update
, updateCount
, insertSelectDistinct
, insertSelect
, unsafeSqlBinOp
, unsafeSqlValue
, unsafeSqlFunction
, unsafeSqlExtractSubField
, UnsafeSqlFunctionArgument
, rawSelectSource
, runSource
, rawEsqueleto
, toRawSql
, Mode(..)
, IdentState
, initialIdentState
, IdentInfo
, SqlSelect(..)
, veryUnsafeCoerceSqlExprValue
, veryUnsafeCoerceSqlExprValueList
) where
import Control.Applicative (Applicative(..), (<$>), (<$))
import Control.Arrow ((***), first)
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.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.State as S
import qualified Control.Monad.Trans.Writer as W
import qualified Data.Conduit as C
import qualified Data.Conduit.List as CL
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 Data.Acquire (with, allocateAcquire, Acquire)
import Control.Monad.Trans.Resource (MonadResource)
import Database.Esqueleto.Internal.Language
newtype SqlQuery a =
Q { unQ :: W.WriterT SideData (S.State IdentState) a }
instance Functor SqlQuery where
fmap f = Q . fmap f . unQ
instance Monad SqlQuery where
return = Q . return
m >>= f = Q (unQ m >>= unQ . f)
instance Applicative SqlQuery where
pure = return
(<*>) = ap
type SqlEntity ent = (PersistEntity ent, PersistEntityBackend ent ~ SqlBackend)
data SideData = SideData { sdFromClause :: ![FromClause]
, sdSetClause :: ![SetClause]
, sdWhereClause :: !WhereClause
, sdGroupByClause :: !GroupByClause
, sdHavingClause :: !HavingClause
, sdOrderByClause :: ![OrderByClause]
, sdLimitClause :: !LimitClause
}
instance Monoid SideData where
mempty = SideData mempty mempty mempty mempty mempty mempty mempty
SideData f s w g h o l `mappend` SideData f' s' w' g' h' o' l' =
SideData (f <> f') (s <> s') (w <> w') (g <> g') (h <> h') (o <> o') (l <> l')
data FromClause =
FromStart Ident EntityDef
| FromJoin FromClause JoinKind FromClause (Maybe (SqlExpr (Value Bool)))
| OnClause (SqlExpr (Value Bool))
newtype SetClause = SetClause (SqlExpr (Value ()))
collectOnClauses :: [FromClause] -> Either (SqlExpr (Value Bool)) [FromClause]
collectOnClauses = go []
where
go [] (f@(FromStart _ _):fs) = fmap (f:) (go [] fs)
go acc (OnClause expr :fs) = findMatching acc expr >>= flip go fs
go acc (f:fs) = go (f:acc) fs
go acc [] = return $ reverse acc
findMatching (f : acc) expr =
case tryMatch expr f of
Just f' -> return (f' : acc)
Nothing -> (f:) <$> findMatching acc expr
findMatching [] expr = Left expr
tryMatch expr (FromJoin l k r onClause) =
matchR `mplus` matchC `mplus` matchL
where
matchR = (\r' -> FromJoin l k r' onClause) <$> tryMatch expr r
matchL = (\l' -> FromJoin l' k r onClause) <$> tryMatch expr l
matchC = case onClause of
Nothing -> return (FromJoin l k r (Just expr))
Just _ -> mzero
tryMatch _ _ = mzero
data WhereClause = Where (SqlExpr (Value Bool))
| NoWhere
instance Monoid WhereClause where
mempty = NoWhere
NoWhere `mappend` w = w
w `mappend` NoWhere = w
Where e1 `mappend` Where e2 = Where (e1 &&. e2)
newtype GroupByClause = GroupBy [SomeValue SqlExpr]
instance Monoid GroupByClause where
mempty = GroupBy []
GroupBy fs `mappend` GroupBy fs' = GroupBy (fs <> fs')
type HavingClause = WhereClause
type OrderByClause = SqlExpr OrderBy
data LimitClause = Limit (Maybe Int64) (Maybe Int64)
instance Monoid LimitClause where
mempty = Limit mzero mzero
Limit l1 o1 `mappend` Limit l2 o2 =
Limit (l2 `mplus` l1) (o2 `mplus` o1)
newtype Ident = I T.Text
newtype IdentState = IdentState { inUse :: HS.HashSet T.Text }
initialIdentState :: IdentState
initialIdentState = IdentState mempty
newIdentFor :: DBName -> SqlQuery Ident
newIdentFor = Q . lift . try . unDBName
where
try orig = do
s <- S.get
let go (t:ts) | t `HS.member` inUse s = go ts
| otherwise = use t
go [] = error "Esqueleto/Sql/newIdentFor: never here"
go (possibilities orig)
possibilities t = t : map addNum [2..]
where
addNum :: Int -> T.Text
addNum = T.append t . T.pack . show
use t = do
S.modify (\s -> s { inUse = HS.insert t (inUse s) })
return (I t)
type IdentInfo = (Connection, IdentState)
useIdent :: IdentInfo -> Ident -> TLB.Builder
useIdent info (I ident) = fromDBName info $ DBName ident
data SqlExpr a where
EEntity :: Ident -> SqlExpr (Entity val)
EMaybe :: SqlExpr a -> SqlExpr (Maybe a)
ERaw :: NeedParens -> (IdentInfo -> (TLB.Builder, [PersistValue])) -> SqlExpr (Value a)
EList :: SqlExpr (Value a) -> SqlExpr (ValueList a)
EEmptyList :: SqlExpr (ValueList a)
EOrderBy :: OrderByType -> SqlExpr (Value a) -> SqlExpr OrderBy
EOrderRandom :: SqlExpr OrderBy
ESet :: (SqlExpr (Entity val) -> SqlExpr (Value ())) -> SqlExpr (Update val)
EPreprocessedFrom :: a -> FromClause -> SqlExpr (PreprocessedFrom a)
EInsert :: Proxy a -> (IdentInfo -> (TLB.Builder, [PersistValue])) -> SqlExpr (Insertion a)
EInsertFinal :: PersistEntity a => SqlExpr (Insertion a) -> SqlExpr InsertFinal
data InsertFinal
data NeedParens = Parens | Never
parensM :: NeedParens -> TLB.Builder -> TLB.Builder
parensM Never = id
parensM Parens = parens
data OrderByType = ASC | DESC
instance Esqueleto SqlQuery SqlExpr SqlBackend where
fromStart = x
where
x = do
let ed = entityDef (getVal x)
ident <- newIdentFor (entityDB ed)
let ret = EEntity ident
from_ = FromStart ident ed
return (EPreprocessedFrom ret from_)
getVal :: SqlQuery (SqlExpr (PreprocessedFrom (SqlExpr (Entity a)))) -> Proxy a
getVal = const Proxy
fromStartMaybe = maybelize <$> fromStart
where
maybelize :: SqlExpr (PreprocessedFrom (SqlExpr (Entity a)))
-> SqlExpr (PreprocessedFrom (SqlExpr (Maybe (Entity a))))
maybelize (EPreprocessedFrom ret from_) = EPreprocessedFrom (EMaybe ret) from_
fromJoin (EPreprocessedFrom lhsRet lhsFrom)
(EPreprocessedFrom rhsRet rhsFrom) = Q $ do
let ret = smartJoin lhsRet rhsRet
from_ = FromJoin lhsFrom
(reifyJoinKind ret)
rhsFrom
Nothing
return (EPreprocessedFrom ret from_)
fromFinish (EPreprocessedFrom ret from_) = Q $ do
W.tell mempty { sdFromClause = [from_] }
return ret
where_ expr = Q $ W.tell mempty { sdWhereClause = Where expr }
on expr = Q $ W.tell mempty { sdFromClause = [OnClause expr] }
groupBy expr = Q $ W.tell mempty { sdGroupByClause = GroupBy $ toSomeValues expr }
having expr = Q $ W.tell mempty { sdHavingClause = Where expr }
orderBy exprs = Q $ W.tell mempty { sdOrderByClause = exprs }
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) }
sub_select = sub SELECT
sub_selectDistinct = sub SELECT_DISTINCT
EEntity ident ^. field =
ERaw Never $ \info -> (useIdent info ident <> ("." <> fieldName info field), [])
EMaybe r ?. field = maybelize (r ^. field)
where
maybelize :: SqlExpr (Value a) -> SqlExpr (Value (Maybe a))
maybelize (ERaw p f) = ERaw p f
val = ERaw Never . const . (,) "?" . return . toPersistValue
isNothing (ERaw p f) = ERaw Parens $ first ((<> " IS NULL") . parensM p) . f
just (ERaw p f) = ERaw p f
nothing = unsafeSqlValue "NULL"
joinV (ERaw p f) = ERaw p f
countRows = unsafeSqlValue "COUNT(*)"
count (ERaw _ f) = ERaw Never $ \info -> let (b, vals) = f info
in ("COUNT" <> parens b, vals)
not_ (ERaw p f) = ERaw Never $ \info -> let (b, vals) = f info
in ("NOT " <> parensM p b, vals)
(==.) = unsafeSqlBinOp " = "
(>=.) = unsafeSqlBinOp " >= "
(>.) = unsafeSqlBinOp " > "
(<=.) = unsafeSqlBinOp " <= "
(<.) = unsafeSqlBinOp " < "
(!=.) = unsafeSqlBinOp " != "
(&&.) = unsafeSqlBinOp " AND "
(||.) = unsafeSqlBinOp " OR "
(+.) = unsafeSqlBinOp " + "
(-.) = unsafeSqlBinOp " - "
(/.) = unsafeSqlBinOp " / "
(*.) = unsafeSqlBinOp " * "
random_ = unsafeSqlValue "RANDOM()"
sum_ = unsafeSqlFunction "SUM"
round_ = unsafeSqlFunction "ROUND"
ceiling_ = unsafeSqlFunction "CEILING"
floor_ = unsafeSqlFunction "FLOOR"
avg_ = unsafeSqlFunction "AVG"
min_ = unsafeSqlFunction "MIN"
max_ = unsafeSqlFunction "MAX"
coalesce = unsafeSqlFunction "COALESCE"
coalesceDefault exprs = unsafeSqlFunction "COALESCE" . (exprs ++) . return . just
like = unsafeSqlBinOp " LIKE "
(%) = unsafeSqlValue "'%'"
concat_ = unsafeSqlFunction "CONCAT"
(++.) = unsafeSqlBinOp " || "
subList_select = EList . sub_select
subList_selectDistinct = EList . sub_selectDistinct
valList [] = EEmptyList
valList vals = EList $ ERaw Parens $ const ( uncommas ("?" <$ vals)
, map toPersistValue vals )
v `in_` e = ifNotEmptyList e False $ unsafeSqlBinOp " IN " v (veryUnsafeCoerceSqlExprValueList e)
v `notIn` e = ifNotEmptyList e True $ unsafeSqlBinOp " NOT IN " v (veryUnsafeCoerceSqlExprValueList e)
exists = unsafeSqlFunction "EXISTS " . existsHelper
notExists = unsafeSqlFunction "NOT EXISTS " . existsHelper
set ent upds = Q $ W.tell mempty { sdSetClause = map apply upds }
where
apply (ESet f) = SetClause (f ent)
field =. expr = setAux field (const 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)
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)
=> 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 $ \info -> (fieldName info field, mempty)
sub :: PersistField a => Mode -> SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a)
sub mode query = ERaw Parens $ \info -> toRawSql mode info query
fromDBName :: IdentInfo -> DBName -> TLB.Builder
fromDBName (conn, _) = TLB.fromText . connEscapeName conn
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
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 info = let (b1, vals1) = f1 info
(b2, vals2) = f2 info
in ( parensM p1 b1 <> op <> parensM p2 b2
, vals1 <> vals2 )
unsafeSqlValue :: TLB.Builder -> SqlExpr (Value a)
unsafeSqlValue v = ERaw Never $ \_ -> (v, mempty)
unsafeSqlFunction :: UnsafeSqlFunctionArgument a =>
TLB.Builder -> a -> SqlExpr (Value b)
unsafeSqlFunction name arg =
ERaw Never $ \info ->
let (argsTLB, argsVals) =
uncommas' $ map (\(ERaw _ f) -> f info) $ toArgList arg
in (name <> parens argsTLB, argsVals)
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
toArgList = (:[]) . veryUnsafeCoerceSqlExprValue
instance UnsafeSqlFunctionArgument a =>
UnsafeSqlFunctionArgument [a] where
toArgList = concatMap toArgList
instance ( UnsafeSqlFunctionArgument a
, UnsafeSqlFunctionArgument b
) => UnsafeSqlFunctionArgument (a, b) where
toArgList (a, b) = toArgList a ++ toArgList b
instance ( UnsafeSqlFunctionArgument a
, UnsafeSqlFunctionArgument b
, UnsafeSqlFunctionArgument c
) => UnsafeSqlFunctionArgument (a, b, c) where
toArgList = toArgList . from3
instance ( UnsafeSqlFunctionArgument a
, UnsafeSqlFunctionArgument b
, UnsafeSqlFunctionArgument c
, UnsafeSqlFunctionArgument d
) => UnsafeSqlFunctionArgument (a, b, c, d) where
toArgList = toArgList . from4
veryUnsafeCoerceSqlExprValue :: SqlExpr (Value a) -> SqlExpr (Value b)
veryUnsafeCoerceSqlExprValue (ERaw p f) = ERaw p f
veryUnsafeCoerceSqlExprValueList :: SqlExpr (ValueList a) -> SqlExpr (Value a)
veryUnsafeCoerceSqlExprValueList (EList v) = v
veryUnsafeCoerceSqlExprValueList EEmptyList =
error "veryUnsafeCoerceSqlExprValueList: empty list."
rawSelectSource :: ( SqlSelect a r
, MonadIO m1
, MonadIO m2 )
=> Mode
-> SqlQuery a
-> SqlPersistT m1 (Acquire (C.Source m2 r))
rawSelectSource mode query =
do
conn <- R.ask
res <- run conn
return $ (C.$= massage) `fmap` res
where
run conn =
uncurry rawQueryRes $
first builderToText $
toRawSql mode (conn, initialIdentState) query
massage = do
mrow <- C.await
case process <$> mrow of
Just (Right r) -> C.yield r >> massage
Just (Left err) -> liftIO $ throwIO $ PersistMarshalError err
Nothing -> return ()
process = sqlSelectProcessRow
selectSource :: ( SqlSelect a r
, MonadResource m )
=> SqlQuery a
-> C.Source (SqlPersistT m) r
selectSource query = do
src <- lift $ do
res <- rawSelectSource SELECT query
fmap snd $ allocateAcquire res
src
select :: ( SqlSelect a r
, MonadIO m )
=> SqlQuery a -> SqlPersistT m [r]
select query = do
res <- rawSelectSource SELECT query
conn <- R.ask
liftIO $ with res $ flip R.runReaderT conn . runSource
selectDistinctSource
:: ( SqlSelect a r
, MonadResource m )
=> SqlQuery a
-> C.Source (SqlPersistT m) r
selectDistinctSource query = do
src <- lift $ do
res <- rawSelectSource SELECT_DISTINCT query
fmap snd $ allocateAcquire res
src
selectDistinct :: ( SqlSelect a r
, MonadIO m )
=> SqlQuery a -> SqlPersistT m [r]
selectDistinct query = do
res <- rawSelectSource SELECT_DISTINCT query
conn <- R.ask
liftIO $ with res $ flip R.runReaderT conn . runSource
runSource :: Monad m =>
C.Source (SqlPersistT m) r
-> SqlPersistT m [r]
runSource src = src C.$$ CL.consume
rawEsqueleto :: ( MonadIO m, SqlSelect a r )
=> Mode
-> SqlQuery a
-> SqlPersistT m Int64
rawEsqueleto mode query = do
conn <- R.ask
uncurry rawExecuteCount $
first builderToText $
toRawSql mode (conn, initialIdentState) query
delete :: ( MonadIO m )
=> SqlQuery ()
-> SqlPersistT m ()
delete = liftM (const ()) . deleteCount
deleteCount :: ( MonadIO m )
=> SqlQuery ()
-> SqlPersistT m Int64
deleteCount = rawEsqueleto DELETE
update :: ( MonadIO m
, SqlEntity val )
=> (SqlExpr (Entity val) -> SqlQuery ())
-> SqlPersistT m ()
update = liftM (const ()) . updateCount
updateCount :: ( MonadIO m
, SqlEntity val )
=> (SqlExpr (Entity val) -> SqlQuery ())
-> SqlPersistT m Int64
updateCount = rawEsqueleto UPDATE . from
builderToText :: TLB.Builder -> T.Text
builderToText = TL.toStrict . TLB.toLazyTextWith defaultChunkSize
where
defaultChunkSize = 1024 32
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 $
unQ query
SideData fromClauses
setClauses
whereClauses
groupByClause
havingClause
orderByClauses
limitClause = sd
info = (conn, finalIdentState)
in mconcat
[ 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
]
data Mode =
SELECT
| SELECT_DISTINCT
| DELETE
| UPDATE
| INSERT_INTO Mode
uncommas :: [TLB.Builder] -> TLB.Builder
uncommas = mconcat . intersperse ", " . filter (/= mempty)
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 = 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, [])
makeFrom :: IdentInfo -> Mode -> [FromClause] -> (TLB.Builder, [PersistValue])
makeFrom _ _ [] = mempty
makeFrom info mode fs = ret
where
ret = case collectOnClauses fs of
Left expr -> throw $ mkExc expr
Right fs' -> keyword $ uncommas' (map (mk Never mempty) fs')
keyword = case mode of
UPDATE -> id
_ -> first ("\nFROM " <>)
mk _ onClause (FromStart i def) = base i def <> onClause
mk paren onClause (FromJoin lhs kind rhs monClause) =
first (parensM paren) $
mconcat [ mk Parens onClause lhs
, (fromKind kind, mempty)
, mk Never (maybe mempty makeOnClause monClause) rhs
]
mk _ _ (OnClause _) = error "Esqueleto/Sql/makeFrom: never here (is collectOnClauses working?)"
base ident@(I identText) def =
let db@(DBName dbText) = entityDB def
in ( if dbText == identText
then fromDBName info db
else fromDBName info db <> (" AS " <> useIdent info ident)
, mempty )
fromKind InnerJoinKind = " INNER JOIN "
fromKind CrossJoinKind = " CROSS JOIN "
fromKind LeftOuterJoinKind = " LEFT OUTER JOIN "
fromKind RightOuterJoinKind = " RIGHT OUTER JOIN "
fromKind FullOuterJoinKind = " FULL OUTER JOIN "
makeOnClause (ERaw _ f) = first (" ON " <>) (f info)
mkExc :: SqlExpr (Value Bool) -> OnClauseWithoutMatchingJoinException
mkExc (ERaw _ f) =
OnClauseWithoutMatchingJoinException $
TL.unpack $ TLB.toLazyText $ fst (f info)
makeSet :: IdentInfo -> [SetClause] -> (TLB.Builder, [PersistValue])
makeSet _ [] = mempty
makeSet info os = first ("\nSET " <>) $ uncommas' (map mk os)
where
mk (SetClause (ERaw _ f)) = f info
makeWhere :: IdentInfo -> WhereClause -> (TLB.Builder, [PersistValue])
makeWhere _ NoWhere = mempty
makeWhere info (Where (ERaw _ f)) = first ("\nWHERE " <>) (f info)
makeGroupBy :: IdentInfo -> GroupByClause -> (TLB.Builder, [PersistValue])
makeGroupBy _ (GroupBy []) = (mempty, [])
makeGroupBy info (GroupBy fields) = first ("\nGROUP BY " <>) build
where
build = uncommas' $ map (\(SomeValue (ERaw _ f)) -> f info) fields
makeHaving :: IdentInfo -> WhereClause -> (TLB.Builder, [PersistValue])
makeHaving _ NoWhere = mempty
makeHaving info (Where (ERaw _ f)) = first ("\nHAVING " <>) (f info)
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 -> [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
parens b = "(" <> (b <> ")")
class SqlSelect a r | a -> r, r -> a where
sqlSelectCols :: IdentInfo -> a -> (TLB.Builder, [PersistValue])
sqlSelectColCount :: Proxy a -> Int
sqlSelectProcessRow :: [PersistValue] -> Either T.Text r
sqlInsertInto :: IdentInfo -> a -> (TLB.Builder, [PersistValue])
sqlInsertInto = error "Type does not support sqlInsertInto."
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/InsertionFinal: never here"
instance SqlSelect () () where
sqlSelectCols _ _ = ("1", [])
sqlSelectColCount _ = 1
sqlSelectProcessRow _ = Right ()
instance PersistEntity a => SqlSelect (SqlExpr (Entity a)) (Entity a) where
sqlSelectCols info expr@(EEntity ident) = ret
where
process ed = uncommas $
map ((name <>) . fromDBName info) $
map fieldDB $
entityId ed :
entityFields ed
name = useIdent info ident <> "."
ret = let ed = entityDef $ getEntityVal $ return expr
in (process ed, mempty)
sqlSelectColCount = (+1) . length . entityFields . entityDef . getEntityVal
sqlSelectProcessRow (idCol:ent) =
Entity <$> fromPersistValue idCol
<*> fromPersistValues ent
sqlSelectProcessRow _ = Left "SqlSelect (Entity a): wrong number of columns."
getEntityVal :: Proxy (SqlExpr (Entity a)) -> Proxy a
getEntityVal = const Proxy
instance PersistEntity a => SqlSelect (SqlExpr (Maybe (Entity a))) (Maybe (Entity a)) where
sqlSelectCols info (EMaybe ent) = sqlSelectCols info ent
sqlSelectColCount = sqlSelectColCount . fromEMaybe
where
fromEMaybe :: Proxy (SqlExpr (Maybe e)) -> Proxy (SqlExpr e)
fromEMaybe = const Proxy
sqlSelectProcessRow cols
| all (== PersistNull) cols = return Nothing
| otherwise = Just <$> sqlSelectProcessRow cols
instance PersistField a => SqlSelect (SqlExpr (Value a)) (Value a) where
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."
instance ( SqlSelect a ra
, SqlSelect b rb
) => SqlSelect (a, b) (ra, rb) where
sqlSelectCols esc (a, b) =
uncommas'
[ sqlSelectCols esc a
, sqlSelectCols esc b
]
sqlSelectColCount = uncurry (+) . (sqlSelectColCount *** sqlSelectColCount) . fromTuple
where
fromTuple :: Proxy (a,b) -> (Proxy a, Proxy b)
fromTuple = const (Proxy, Proxy)
sqlSelectProcessRow =
let x = getType processRow
getType :: SqlSelect a r => (z -> Either y (r,x)) -> Proxy a
getType = const Proxy
colCountFst = sqlSelectColCount x
processRow row =
let (rowFst, rowSnd) = splitAt colCountFst row
in (,) <$> sqlSelectProcessRow rowFst
<*> sqlSelectProcessRow rowSnd
in colCountFst `seq` processRow
instance ( SqlSelect a ra
, SqlSelect b rb
, SqlSelect c rc
) => SqlSelect (a, b, c) (ra, rb, rc) where
sqlSelectCols esc (a, b, c) =
uncommas'
[ sqlSelectCols esc a
, sqlSelectCols esc b
, sqlSelectCols esc c
]
sqlSelectColCount = sqlSelectColCount . from3P
sqlSelectProcessRow = fmap to3 . sqlSelectProcessRow
from3P :: Proxy (a,b,c) -> Proxy ((a,b),c)
from3P = const Proxy
from3 :: (a,b,c) -> ((a,b),c)
from3 (a,b,c) = ((a,b),c)
to3 :: ((a,b),c) -> (a,b,c)
to3 ((a,b),c) = (a,b,c)
instance ( SqlSelect a ra
, SqlSelect b rb
, SqlSelect c rc
, SqlSelect d rd
) => SqlSelect (a, b, c, d) (ra, rb, rc, rd) where
sqlSelectCols esc (a, b, c, d) =
uncommas'
[ sqlSelectCols esc a
, sqlSelectCols esc b
, sqlSelectCols esc c
, sqlSelectCols esc d
]
sqlSelectColCount = sqlSelectColCount . from4P
sqlSelectProcessRow = fmap to4 . sqlSelectProcessRow
from4P :: Proxy (a,b,c,d) -> Proxy ((a,b),(c,d))
from4P = const Proxy
from4 :: (a,b,c,d) -> ((a,b),(c,d))
from4 (a,b,c,d) = ((a,b),(c,d))
to4 :: ((a,b),(c,d)) -> (a,b,c,d)
to4 ((a,b),(c,d)) = (a,b,c,d)
instance ( SqlSelect a ra
, SqlSelect b rb
, SqlSelect c rc
, SqlSelect d rd
, SqlSelect e re
) => SqlSelect (a, b, c, d, e) (ra, rb, rc, rd, re) where
sqlSelectCols esc (a, b, c, d, e) =
uncommas'
[ sqlSelectCols esc a
, sqlSelectCols esc b
, sqlSelectCols esc c
, sqlSelectCols esc d
, sqlSelectCols esc e
]
sqlSelectColCount = sqlSelectColCount . from5P
sqlSelectProcessRow = fmap to5 . sqlSelectProcessRow
from5P :: Proxy (a,b,c,d,e) -> Proxy ((a,b),(c,d),e)
from5P = const Proxy
to5 :: ((a,b),(c,d),e) -> (a,b,c,d,e)
to5 ((a,b),(c,d),e) = (a,b,c,d,e)
instance ( SqlSelect a ra
, SqlSelect b rb
, SqlSelect c rc
, SqlSelect d rd
, SqlSelect e re
, SqlSelect f rf
) => SqlSelect (a, b, c, d, e, f) (ra, rb, rc, rd, re, rf) where
sqlSelectCols esc (a, b, c, d, e, f) =
uncommas'
[ sqlSelectCols esc a
, sqlSelectCols esc b
, sqlSelectCols esc c
, sqlSelectCols esc d
, sqlSelectCols esc e
, sqlSelectCols esc f
]
sqlSelectColCount = sqlSelectColCount . from6P
sqlSelectProcessRow = fmap to6 . sqlSelectProcessRow
from6P :: Proxy (a,b,c,d,e,f) -> Proxy ((a,b),(c,d),(e,f))
from6P = const Proxy
to6 :: ((a,b),(c,d),(e,f)) -> (a,b,c,d,e,f)
to6 ((a,b),(c,d),(e,f)) = (a,b,c,d,e,f)
instance ( SqlSelect a ra
, SqlSelect b rb
, SqlSelect c rc
, SqlSelect d rd
, SqlSelect e re
, SqlSelect f rf
, SqlSelect g rg
) => SqlSelect (a, b, c, d, e, f, g) (ra, rb, rc, rd, re, rf, rg) where
sqlSelectCols esc (a, b, c, d, e, f, g) =
uncommas'
[ sqlSelectCols esc a
, sqlSelectCols esc b
, sqlSelectCols esc c
, sqlSelectCols esc d
, sqlSelectCols esc e
, sqlSelectCols esc f
, sqlSelectCols esc g
]
sqlSelectColCount = sqlSelectColCount . from7P
sqlSelectProcessRow = fmap to7 . sqlSelectProcessRow
from7P :: Proxy (a,b,c,d,e,f,g) -> Proxy ((a,b),(c,d),(e,f),g)
from7P = const Proxy
to7 :: ((a,b),(c,d),(e,f),g) -> (a,b,c,d,e,f,g)
to7 ((a,b),(c,d),(e,f),g) = (a,b,c,d,e,f,g)
instance ( SqlSelect a ra
, SqlSelect b rb
, SqlSelect c rc
, SqlSelect d rd
, SqlSelect e re
, SqlSelect f rf
, SqlSelect g rg
, SqlSelect h rh
) => SqlSelect (a, b, c, d, e, f, g, h) (ra, rb, rc, rd, re, rf, rg, rh) where
sqlSelectCols esc (a, b, c, d, e, f, g, h) =
uncommas'
[ sqlSelectCols esc a
, sqlSelectCols esc b
, sqlSelectCols esc c
, sqlSelectCols esc d
, sqlSelectCols esc e
, sqlSelectCols esc f
, sqlSelectCols esc g
, sqlSelectCols esc h
]
sqlSelectColCount = sqlSelectColCount . from8P
sqlSelectProcessRow = fmap to8 . sqlSelectProcessRow
from8P :: Proxy (a,b,c,d,e,f,g,h) -> Proxy ((a,b),(c,d),(e,f),(g,h))
from8P = const Proxy
to8 :: ((a,b),(c,d),(e,f),(g,h)) -> (a,b,c,d,e,f,g,h)
to8 ((a,b),(c,d),(e,f),(g,h)) = (a,b,c,d,e,f,g,h)
instance ( SqlSelect a ra
, SqlSelect b rb
, SqlSelect c rc
, SqlSelect d rd
, SqlSelect e re
, SqlSelect f rf
, SqlSelect g rg
, SqlSelect h rh
, SqlSelect i ri
) => SqlSelect (a, b, c, d, e, f, g, h, i) (ra, rb, rc, rd, re, rf, rg, rh, ri) where
sqlSelectCols esc (a, b, c, d, e, f, g, h, i) =
uncommas'
[ sqlSelectCols esc a
, sqlSelectCols esc b
, sqlSelectCols esc c
, sqlSelectCols esc d
, sqlSelectCols esc e
, sqlSelectCols esc f
, sqlSelectCols esc g
, sqlSelectCols esc h
, sqlSelectCols esc i
]
sqlSelectColCount = sqlSelectColCount . from9P
sqlSelectProcessRow = fmap to9 . sqlSelectProcessRow
from9P :: Proxy (a,b,c,d,e,f,g,h,i) -> Proxy ((a,b),(c,d),(e,f),(g,h),i)
from9P = const Proxy
to9 :: ((a,b),(c,d),(e,f),(g,h),i) -> (a,b,c,d,e,f,g,h,i)
to9 ((a,b),(c,d),(e,f),(g,h),i) = (a,b,c,d,e,f,g,h,i)
instance ( SqlSelect a ra
, SqlSelect b rb
, SqlSelect c rc
, SqlSelect d rd
, SqlSelect e re
, SqlSelect f rf
, SqlSelect g rg
, SqlSelect h rh
, SqlSelect i ri
, SqlSelect j rj
) => SqlSelect (a, b, c, d, e, f, g, h, i, j) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj) where
sqlSelectCols esc (a, b, c, d, e, f, g, h, i, j) =
uncommas'
[ sqlSelectCols esc a
, sqlSelectCols esc b
, sqlSelectCols esc c
, sqlSelectCols esc d
, sqlSelectCols esc e
, sqlSelectCols esc f
, sqlSelectCols esc g
, sqlSelectCols esc h
, sqlSelectCols esc i
, sqlSelectCols esc j
]
sqlSelectColCount = sqlSelectColCount . from10P
sqlSelectProcessRow = fmap to10 . sqlSelectProcessRow
from10P :: Proxy (a,b,c,d,e,f,g,h,i,j) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j))
from10P = const Proxy
to10 :: ((a,b),(c,d),(e,f),(g,h),(i,j)) -> (a,b,c,d,e,f,g,h,i,j)
to10 ((a,b),(c,d),(e,f),(g,h),(i,j)) = (a,b,c,d,e,f,g,h,i,j)
instance ( SqlSelect a ra
, SqlSelect b rb
, SqlSelect c rc
, SqlSelect d rd
, SqlSelect e re
, SqlSelect f rf
, SqlSelect g rg
, SqlSelect h rh
, SqlSelect i ri
, SqlSelect j rj
, SqlSelect k rk
) => SqlSelect (a, b, c, d, e, f, g, h, i, j, k) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj, rk) where
sqlSelectCols esc (a, b, c, d, e, f, g, h, i, j, k) =
uncommas'
[ sqlSelectCols esc a
, sqlSelectCols esc b
, sqlSelectCols esc c
, sqlSelectCols esc d
, sqlSelectCols esc e
, sqlSelectCols esc f
, sqlSelectCols esc g
, sqlSelectCols esc h
, sqlSelectCols esc i
, sqlSelectCols esc j
, sqlSelectCols esc k
]
sqlSelectColCount = sqlSelectColCount . from11P
sqlSelectProcessRow = fmap to11 . sqlSelectProcessRow
from11P :: Proxy (a,b,c,d,e,f,g,h,i,j,k) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),k)
from11P = const Proxy
to11 :: ((a,b),(c,d),(e,f),(g,h),(i,j),k) -> (a,b,c,d,e,f,g,h,i,j,k)
to11 ((a,b),(c,d),(e,f),(g,h),(i,j),k) = (a,b,c,d,e,f,g,h,i,j,k)
instance ( SqlSelect a ra
, SqlSelect b rb
, SqlSelect c rc
, SqlSelect d rd
, SqlSelect e re
, SqlSelect f rf
, SqlSelect g rg
, SqlSelect h rh
, SqlSelect i ri
, SqlSelect j rj
, SqlSelect k rk
, SqlSelect l rl
) => SqlSelect (a, b, c, d, e, f, g, h, i, j, k, l) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj, rk, rl) where
sqlSelectCols esc (a, b, c, d, e, f, g, h, i, j, k, l) =
uncommas'
[ sqlSelectCols esc a
, sqlSelectCols esc b
, sqlSelectCols esc c
, sqlSelectCols esc d
, sqlSelectCols esc e
, sqlSelectCols esc f
, sqlSelectCols esc g
, sqlSelectCols esc h
, sqlSelectCols esc i
, sqlSelectCols esc j
, sqlSelectCols esc k
, sqlSelectCols esc l
]
sqlSelectColCount = sqlSelectColCount . from12P
sqlSelectProcessRow = fmap to12 . sqlSelectProcessRow
from12P :: Proxy (a,b,c,d,e,f,g,h,i,j,k,l) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l))
from12P = const Proxy
to12 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l)) -> (a,b,c,d,e,f,g,h,i,j,k,l)
to12 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l)) = (a,b,c,d,e,f,g,h,i,j,k,l)
instance ( SqlSelect a ra
, SqlSelect b rb
, SqlSelect c rc
, SqlSelect d rd
, SqlSelect e re
, SqlSelect f rf
, SqlSelect g rg
, SqlSelect h rh
, SqlSelect i ri
, SqlSelect j rj
, SqlSelect k rk
, SqlSelect l rl
, SqlSelect m rm
) => SqlSelect (a, b, c, d, e, f, g, h, i, j, k, l, m) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj, rk, rl, rm) where
sqlSelectCols esc (a, b, c, d, e, f, g, h, i, j, k, l, m) =
uncommas'
[ sqlSelectCols esc a
, sqlSelectCols esc b
, sqlSelectCols esc c
, sqlSelectCols esc d
, sqlSelectCols esc e
, sqlSelectCols esc f
, sqlSelectCols esc g
, sqlSelectCols esc h
, sqlSelectCols esc i
, sqlSelectCols esc j
, sqlSelectCols esc k
, sqlSelectCols esc l
, sqlSelectCols esc m
]
sqlSelectColCount = sqlSelectColCount . from13P
sqlSelectProcessRow = fmap to13 . sqlSelectProcessRow
from13P :: Proxy (a,b,c,d,e,f,g,h,i,j,k,l,m) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),m)
from13P = const Proxy
to13 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),m) -> (a,b,c,d,e,f,g,h,i,j,k,l,m)
to13 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),m) = (a,b,c,d,e,f,g,h,i,j,k,l,m)
instance ( SqlSelect a ra
, SqlSelect b rb
, SqlSelect c rc
, SqlSelect d rd
, SqlSelect e re
, SqlSelect f rf
, SqlSelect g rg
, SqlSelect h rh
, SqlSelect i ri
, SqlSelect j rj
, SqlSelect k rk
, SqlSelect l rl
, SqlSelect m rm
, SqlSelect n rn
) => SqlSelect (a, b, c, d, e, f, g, h, i, j, k, l, m, n) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj, rk, rl, rm, rn) where
sqlSelectCols esc (a, b, c, d, e, f, g, h, i, j, k, l, m, n) =
uncommas'
[ sqlSelectCols esc a
, sqlSelectCols esc b
, sqlSelectCols esc c
, sqlSelectCols esc d
, sqlSelectCols esc e
, sqlSelectCols esc f
, sqlSelectCols esc g
, sqlSelectCols esc h
, sqlSelectCols esc i
, sqlSelectCols esc j
, sqlSelectCols esc k
, sqlSelectCols esc l
, sqlSelectCols esc m
, sqlSelectCols esc n
]
sqlSelectColCount = sqlSelectColCount . from14P
sqlSelectProcessRow = fmap to14 . sqlSelectProcessRow
from14P :: Proxy (a,b,c,d,e,f,g,h,i,j,k,l,m,n) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n))
from14P = const Proxy
to14 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n)) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n)
to14 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n)) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n)
instance ( SqlSelect a ra
, SqlSelect b rb
, SqlSelect c rc
, SqlSelect d rd
, SqlSelect e re
, SqlSelect f rf
, SqlSelect g rg
, SqlSelect h rh
, SqlSelect i ri
, SqlSelect j rj
, SqlSelect k rk
, SqlSelect l rl
, SqlSelect m rm
, SqlSelect n rn
, SqlSelect o ro
) => SqlSelect (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj, rk, rl, rm, rn, ro) where
sqlSelectCols esc (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) =
uncommas'
[ sqlSelectCols esc a
, sqlSelectCols esc b
, sqlSelectCols esc c
, sqlSelectCols esc d
, sqlSelectCols esc e
, sqlSelectCols esc f
, sqlSelectCols esc g
, sqlSelectCols esc h
, sqlSelectCols esc i
, sqlSelectCols esc j
, sqlSelectCols esc k
, sqlSelectCols esc l
, sqlSelectCols esc m
, sqlSelectCols esc n
, sqlSelectCols esc o
]
sqlSelectColCount = sqlSelectColCount . from15P
sqlSelectProcessRow = fmap to15 . sqlSelectProcessRow
from15P :: Proxy (a,b,c,d,e,f,g,h,i,j,k,l,m,n, o) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),o)
from15P = const Proxy
to15 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),o) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)
to15 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),o) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)
instance ( SqlSelect a ra
, SqlSelect b rb
, SqlSelect c rc
, SqlSelect d rd
, SqlSelect e re
, SqlSelect f rf
, SqlSelect g rg
, SqlSelect h rh
, SqlSelect i ri
, SqlSelect j rj
, SqlSelect k rk
, SqlSelect l rl
, SqlSelect m rm
, SqlSelect n rn
, SqlSelect o ro
, SqlSelect p rp
) => SqlSelect (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj, rk, rl, rm, rn, ro, rp) where
sqlSelectCols esc (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) =
uncommas'
[ sqlSelectCols esc a
, sqlSelectCols esc b
, sqlSelectCols esc c
, sqlSelectCols esc d
, sqlSelectCols esc e
, sqlSelectCols esc f
, sqlSelectCols esc g
, sqlSelectCols esc h
, sqlSelectCols esc i
, sqlSelectCols esc j
, sqlSelectCols esc k
, sqlSelectCols esc l
, sqlSelectCols esc m
, sqlSelectCols esc n
, sqlSelectCols esc o
, sqlSelectCols esc p
]
sqlSelectColCount = sqlSelectColCount . from16P
sqlSelectProcessRow = fmap to16 . sqlSelectProcessRow
from16P :: Proxy (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p))
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)
insertSelect :: (MonadIO m, PersistEntity a) =>
SqlQuery (SqlExpr (Insertion a)) -> SqlPersistT m ()
insertSelect = insertGeneralSelect SELECT
insertSelectDistinct :: (MonadIO m, PersistEntity a) =>
SqlQuery (SqlExpr (Insertion a)) -> SqlPersistT m ()
insertSelectDistinct = insertGeneralSelect SELECT_DISTINCT
insertGeneralSelect :: (MonadIO m, PersistEntity a) =>
Mode -> SqlQuery (SqlExpr (Insertion a)) -> SqlPersistT m ()
insertGeneralSelect mode =
liftM (const ()) . rawEsqueleto (INSERT_INTO mode) . fmap EInsertFinal