persistent-2.18.1.0: Database/Persist/Sql/Orphan/PersistQuery.hs
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | TODO: delete this module and get it in with SqlBackend.Internal
module Database.Persist.Sql.Orphan.PersistQuery
( deleteWhereCount
, updateWhereCount
, filterClause
, filterClauseHelper
, filterClauseWithVals
, orderClause
, FilterTablePrefix (..)
, decorateSQLWithLimitOffset
) where
import Control.Exception (throwIO)
import Control.Monad.IO.Class
import Control.Monad.Trans.Reader (ReaderT, ask)
import Data.ByteString.Char8 (readInteger)
import Data.Conduit
import qualified Data.Conduit.List as CL
import Data.Foldable (toList)
import Data.Int (Int64)
import Data.List (find, inits, transpose)
import Data.Maybe (isJust)
import Data.Monoid (Monoid (..))
import Data.Text (Text)
import qualified Data.Text as T
import Database.Persist hiding (updateField)
import Database.Persist.Sql.Orphan.PersistStore (withRawQuery)
import Database.Persist.Sql.Raw
import Database.Persist.Sql.Types.Internal
( SqlBackend (..)
, SqlReadBackend
, SqlWriteBackend
)
import Database.Persist.Sql.Util
( commaSeparated
, dbIdColumns
, isIdField
, keyAndEntityColumnNames
, mkUpdateText
, parseEntityValues
, parseExistsResult
, updatePersistValue
)
-- orphaned instance for convenience of modularity
instance PersistQueryRead SqlBackend where
count filts = do
conn <- ask
let
wher =
if null filts
then ""
else filterClause Nothing conn filts
let
sql =
mconcat
[ "SELECT COUNT(*) FROM "
, connEscapeTableName conn t
, wher
]
withRawQuery sql (getFiltsValues conn filts) $ do
mm <- CL.head
case mm of
Just [PersistInt64 i] -> return $ fromIntegral i
Just [PersistDouble i] -> return $ fromIntegral (truncate i :: Int64) -- gb oracle
Just [PersistByteString i] -> case readInteger i of -- gb mssql
Just (ret, "") -> return $ fromIntegral ret
xs -> error $ "invalid number i[" ++ show i ++ "] xs[" ++ show xs ++ "]"
Just xs ->
error $
"count:invalid sql return xs[" ++ show xs ++ "] sql[" ++ show sql ++ "]"
Nothing -> error $ "count:invalid sql returned nothing sql[" ++ show sql ++ "]"
where
t = entityDef $ dummyFromFilts filts
exists filts = do
conn <- ask
let
wher =
if null filts
then ""
else filterClause Nothing conn filts
let
sql =
mconcat
[ "SELECT EXISTS(SELECT 1 FROM "
, connEscapeTableName conn t
, wher
, ")"
]
withRawQuery sql (getFiltsValues conn filts) $ do
mm <- CL.head
return $ parseExistsResult mm sql "PersistQuery.exists"
where
t = entityDef $ dummyFromFilts filts
selectSourceRes filts opts = do
conn <- ask
srcRes <- rawQueryRes (sql conn) (getFiltsValues conn filts)
return $ fmap (.| CL.mapM parse) srcRes
where
(limit, offset, orders) = limitOffsetOrder opts
parse vals =
case parseEntityValues t vals of
Left s ->
liftIO $
throwIO $
PersistMarshalError
("selectSourceRes: " <> s <> ", vals: " <> T.pack (show vals))
Right row ->
return row
t = entityDef $ dummyFromFilts filts
wher conn =
if null filts
then ""
else filterClause Nothing conn filts
ord conn = orderClause Nothing conn orders
cols = commaSeparated . toList . keyAndEntityColumnNames t
sql conn =
connLimitOffset conn (limit, offset) $
mconcat
[ "SELECT "
, cols conn
, " FROM "
, connEscapeTableName conn t
, wher conn
, ord conn
]
selectKeysRes filts opts = do
conn <- ask
srcRes <- rawQueryRes (sql conn) (getFiltsValues conn filts)
return $ fmap (.| CL.mapM parse) srcRes
where
t = entityDef $ dummyFromFilts filts
cols conn = T.intercalate "," $ toList $ dbIdColumns conn t
wher conn =
if null filts
then ""
else filterClause Nothing conn filts
sql conn =
connLimitOffset conn (limit, offset) $
mconcat
[ "SELECT "
, cols conn
, " FROM "
, connEscapeTableName conn t
, wher conn
, ord conn
]
(limit, offset, orders) = limitOffsetOrder opts
ord conn = orderClause Nothing conn orders
parse xs = do
keyvals <- case entityPrimary t of
Nothing ->
case xs of
[PersistInt64 x] -> return [PersistInt64 x]
[PersistDouble x] -> return [PersistInt64 (truncate x)] -- oracle returns Double
_ -> return xs
Just pdef ->
let
pks = map fieldHaskell $ toList $ compositeFields pdef
keyvals =
map snd $
filter (\(a, _) -> let ret = isJust (find (== a) pks) in ret) $
zip (map fieldHaskell $ getEntityFields t) xs
in
return keyvals
case keyFromValues keyvals of
Right k -> return k
Left err -> error $ "selectKeysImpl: keyFromValues failed" <> show err
instance PersistQueryRead SqlReadBackend where
count filts = withBaseBackend $ count filts
exists filts = withBaseBackend $ exists filts
selectSourceRes filts opts = withBaseBackend $ selectSourceRes filts opts
selectKeysRes filts opts = withBaseBackend $ selectKeysRes filts opts
instance PersistQueryRead SqlWriteBackend where
count filts = withBaseBackend $ count filts
exists filts = withBaseBackend $ exists filts
selectSourceRes filts opts = withBaseBackend $ selectSourceRes filts opts
selectKeysRes filts opts = withBaseBackend $ selectKeysRes filts opts
instance PersistQueryWrite SqlBackend where
deleteWhere filts = do
_ <- deleteWhereCount filts
return ()
updateWhere filts upds = do
_ <- updateWhereCount filts upds
return ()
instance PersistQueryWrite SqlWriteBackend where
deleteWhere filts = withBaseBackend $ deleteWhere filts
updateWhere filts upds = withBaseBackend $ updateWhere filts upds
-- | Same as 'deleteWhere', but returns the number of rows affected.
--
-- @since 1.1.5
deleteWhereCount
:: ( PersistEntity val
, MonadIO m
, PersistEntityBackend val ~ SqlBackend
, BackendCompatible SqlBackend backend
)
=> [Filter val]
-> ReaderT backend m Int64
deleteWhereCount filts = withCompatibleBackend $ do
conn <- ask
let
t = entityDef $ dummyFromFilts filts
let
wher =
if null filts
then ""
else filterClause Nothing conn filts
sql =
mconcat
[ "DELETE FROM "
, connEscapeTableName conn t
, wher
]
rawExecuteCount sql $ getFiltsValues conn filts
-- | Same as 'updateWhere', but returns the number of rows affected.
--
-- @since 1.1.5
updateWhereCount
:: ( PersistEntity val
, MonadIO m
, SqlBackend ~ PersistEntityBackend val
, BackendCompatible SqlBackend backend
)
=> [Filter val]
-> [Update val]
-> ReaderT backend m Int64
updateWhereCount _ [] = return 0
updateWhereCount filts upds = withCompatibleBackend $ do
conn <- ask
let
wher =
if null filts
then ""
else filterClause Nothing conn filts
let
sql =
mconcat
[ "UPDATE "
, connEscapeTableName conn t
, " SET "
, T.intercalate "," $ map (mkUpdateText conn) upds
, wher
]
let
dat =
map updatePersistValue upds
`Data.Monoid.mappend` getFiltsValues conn filts
rawExecuteCount sql dat
where
t = entityDef $ dummyFromFilts filts
fieldName
:: forall record typ
. (PersistEntity record) => EntityField record typ -> FieldNameDB
fieldName f = fieldDB $ persistFieldDef f
dummyFromFilts :: [Filter v] -> Maybe v
dummyFromFilts _ = Nothing
getFiltsValues
:: forall val
. (PersistEntity val)
=> SqlBackend -> [Filter val] -> [PersistValue]
getFiltsValues conn = snd . filterClauseHelper Nothing False conn OrNullNo
data OrNull = OrNullYes | OrNullNo
-- | Used when determining how to prefix a column name in a @WHERE@ clause.
--
-- @since 2.12.1.0
data FilterTablePrefix
= -- | Prefix the column with the table name. This is useful if the column
-- name might be ambiguous.
--
-- @since 2.12.1.0
PrefixTableName
| -- | Prefix the column name with the @EXCLUDED@ keyword. This is used with
-- the Postgresql backend when doing @ON CONFLICT DO UPDATE@ clauses - see
-- the documentation on @upsertWhere@ and @upsertManyWhere@.
--
-- @since 2.12.1.0
PrefixExcluded
prefixByTable
:: Maybe FilterTablePrefix
-> Text
-- ^ Table name
-> (Text -> Text)
-- ^ Prefixing function
prefixByTable tablePrefix tableName =
case tablePrefix of
Just PrefixTableName -> ((tableName <> ".") <>)
Just PrefixExcluded -> (("EXCLUDED.") <>)
_ -> id
filterClauseHelper
:: (PersistEntity val)
=> Maybe FilterTablePrefix
-- ^ include table name or PostgresSQL EXCLUDED
-> Bool
-- ^ include WHERE
-> SqlBackend
-> OrNull
-> [Filter val]
-> (Text, [PersistValue])
filterClauseHelper tablePrefix includeWhere conn orNull filters =
( if not (T.null sql) && includeWhere
then " WHERE " <> sql
else sql
, vals
)
where
(sql, vals) = combineAND filters
combineAND = combine " AND "
combine s fs =
(T.intercalate s $ map wrapP a, mconcat b)
where
(a, b) = unzip $ map go fs
wrapP x = T.concat ["(", x, ")"]
go (BackendFilter _) = error "BackendFilter not expected"
go (FilterAnd []) = ("1=1", [])
go (FilterAnd fs) = combineAND fs
go (FilterOr []) = ("1=0", [])
go (FilterOr fs) = combine " OR " fs
go (Filter field value pfilter) =
let
t = entityDef $ dummyFromFilts [Filter field value pfilter]
in
case (isIdField field, entityPrimary t, allVals) of
(True, Just pdef, PersistList ys : _) ->
let
cfields = toList $ compositeFields pdef
in
if length cfields /= length ys
then
error $
"wrong number of entries in compositeFields vs PersistList allVals="
++ show allVals
else case (allVals, pfilter, isCompFilter pfilter) of
([PersistList xs], Eq, _) ->
let
sqlcl =
T.intercalate
" and "
( map
(\a -> connEscapeFieldName conn (fieldDB a) <> showSqlFilter pfilter <> "? ")
cfields
)
in
(wrapSql sqlcl, xs)
([PersistList xs], Ne, _) ->
let
sqlcl =
T.intercalate
" or "
( map
(\a -> connEscapeFieldName conn (fieldDB a) <> showSqlFilter pfilter <> "? ")
cfields
)
in
(wrapSql sqlcl, xs)
(_, In, _) ->
let
xxs = transpose (map fromPersistList allVals)
sqls =
map
( \(a, xs) ->
connEscapeFieldName conn (fieldDB a)
<> showSqlFilter pfilter
<> "("
<> T.intercalate "," (replicate (length xs) " ?")
<> ") "
)
(zip cfields xxs)
in
(wrapSql (T.intercalate " and " (map wrapSql sqls)), concat xxs)
(_, NotIn, _) ->
let
xxs = transpose (map fromPersistList allVals)
sqls =
map
( \(a, xs) ->
connEscapeFieldName conn (fieldDB a)
<> showSqlFilter pfilter
<> "("
<> T.intercalate "," (replicate (length xs) " ?")
<> ") "
)
(zip cfields xxs)
in
(wrapSql (T.intercalate " or " (map wrapSql sqls)), concat xxs)
([PersistList xs], _, True) ->
let
zs = tail (inits (toList $ compositeFields pdef))
sql1 =
map
( \b ->
wrapSql
(T.intercalate " and " (map (\(i, a) -> sql2 (i == length b) a) (zip [1 ..] b)))
)
zs
sql2 islast a =
connEscapeFieldName conn (fieldDB a)
<> (if islast then showSqlFilter pfilter else showSqlFilter Eq)
<> "? "
sqlcl = T.intercalate " or " sql1
in
(wrapSql sqlcl, concat (tail (inits xs)))
(_, BackendSpecificFilter _, _) ->
error "unhandled type BackendSpecificFilter for composite/non id primary keys"
_ ->
error $
"unhandled type/filter for composite/non id primary keys pfilter="
++ show pfilter
++ " persistList="
++ show allVals
(True, Just pdef, []) ->
error $
"empty list given as filter value filter="
++ show pfilter
++ " persistList="
++ show allVals
++ " pdef="
++ show pdef
(True, Just pdef, _) ->
error $
"unhandled error for composite/non id primary keys filter="
++ show pfilter
++ " persistList="
++ show allVals
++ " pdef="
++ show pdef
_ -> case (isNull, pfilter, length notNullVals) of
(True, Eq, _) -> (name <> " IS NULL", [])
(True, Ne, _) -> (name <> " IS NOT NULL", [])
(False, Ne, _) ->
( T.concat
[ "("
, name
, " IS NULL OR "
, name
, " <> "
, qmarks
, ")"
]
, notNullVals
)
-- We use 1=2 (and below 1=1) to avoid using TRUE and FALSE, since
-- not all databases support those words directly.
(_, In, 0) -> ("1=2" <> orNullSuffix, [])
(False, In, _) -> (name <> " IN " <> qmarks <> orNullSuffix, allVals)
(True, In, _) ->
( T.concat
[ "("
, name
, " IS NULL OR "
, name
, " IN "
, qmarks
, ")"
]
, notNullVals
)
(False, NotIn, 0) -> ("1=1", [])
(True, NotIn, 0) -> (name <> " IS NOT NULL", [])
(False, NotIn, _) ->
( T.concat
[ "("
, name
, " IS NULL OR "
, name
, " NOT IN "
, qmarks
, ")"
]
, notNullVals
)
(True, NotIn, _) ->
( T.concat
[ "("
, name
, " IS NOT NULL AND "
, name
, " NOT IN "
, qmarks
, ")"
]
, notNullVals
)
_ -> (name <> showSqlFilter pfilter <> "?" <> orNullSuffix, allVals)
where
isCompFilter Lt = True
isCompFilter Le = True
isCompFilter Gt = True
isCompFilter Ge = True
isCompFilter _ = False
wrapSql sqlcl = "(" <> sqlcl <> ")"
fromPersistList (PersistList xs) = xs
fromPersistList other = error $ "expected PersistList but found " ++ show other
filterValueToPersistValues
:: forall a. (PersistField a) => FilterValue a -> [PersistValue]
filterValueToPersistValues = \case
FilterValue a -> [toPersistValue a]
FilterValues as -> toPersistValue <$> as
UnsafeValue x -> [toPersistValue x]
orNullSuffix =
case orNull of
OrNullYes ->
mconcat
[ " OR "
, name
, " IS NULL"
]
OrNullNo -> ""
isNull = PersistNull `elem` allVals
notNullVals = filter (/= PersistNull) allVals
allVals = filterValueToPersistValues value
tn =
connEscapeTableName conn $
entityDef $
dummyFromFilts [Filter field value pfilter]
name = prefixByTable tablePrefix tn $ connEscapeFieldName conn (fieldName field)
qmarks = case value of
FilterValue{} -> "(?)"
UnsafeValue{} -> "(?)"
FilterValues xs ->
let
parens a = "(" <> a <> ")"
commas = T.intercalate ","
toQs = fmap $ const "?"
nonNulls = filter (/= PersistNull) $ map toPersistValue xs
in
parens . commas . toQs $ nonNulls
showSqlFilter Eq = "="
showSqlFilter Ne = "<>"
showSqlFilter Gt = ">"
showSqlFilter Lt = "<"
showSqlFilter Ge = ">="
showSqlFilter Le = "<="
showSqlFilter In = " IN "
showSqlFilter NotIn = " NOT IN "
showSqlFilter (BackendSpecificFilter s) = s
-- | Render a @['Filter' record]@ into a 'Text' value suitable for inclusion
-- into a SQL query.
--
-- @since 2.12.1.0
filterClause
:: (PersistEntity val)
=> Maybe FilterTablePrefix
-- ^ include table name or EXCLUDED
-> SqlBackend
-> [Filter val]
-> Text
filterClause b c = fst . filterClauseHelper b True c OrNullNo
-- | Render a @['Filter' record]@ into a 'Text' value suitable for inclusion
-- into a SQL query, as well as the @['PersistValue']@ to properly fill in the
-- @?@ place holders.
--
-- @since 2.12.1.0
filterClauseWithVals
:: (PersistEntity val)
=> Maybe FilterTablePrefix
-- ^ include table name or EXCLUDED
-> SqlBackend
-> [Filter val]
-> (Text, [PersistValue])
filterClauseWithVals b c = filterClauseHelper b True c OrNullNo
-- | Render a @['SelectOpt' record]@ made up *only* of 'Asc' and 'Desc' constructors
-- into a 'Text' value suitable for inclusion into a SQL query.
--
-- @since 2.13.2.0
orderClause
:: (PersistEntity val)
=> Maybe FilterTablePrefix
-- ^ include table name or EXCLUDED
-> SqlBackend
-> [SelectOpt val]
-> Text
orderClause includeTable conn orders =
if null orders
then ""
else
" ORDER BY "
<> T.intercalate
","
( map
( \case
Asc x -> name x
Desc x -> name x <> " DESC"
_ -> error "orderClause: expected Asc or Desc, not limit or offset"
)
orders
)
where
dummyFromOrder :: [SelectOpt a] -> Maybe a
dummyFromOrder _ = Nothing
tn = connEscapeTableName conn (entityDef $ dummyFromOrder orders)
name
:: (PersistEntity record)
=> EntityField record typ -> Text
name x =
prefixByTable includeTable tn $
connEscapeFieldName conn (fieldName x)
-- | Generates sql for limit and offset for postgres, sqlite and mysql.
decorateSQLWithLimitOffset
:: Text
-> (Int, Int)
-> Text
-> Text
decorateSQLWithLimitOffset nolimit (limit, offset) sql =
let
lim = case (limit, offset) of
(0, 0) -> ""
(0, _) -> T.cons ' ' nolimit
(_, _) -> " LIMIT " <> T.pack (show limit)
off =
if offset == 0
then ""
else " OFFSET " <> T.pack (show offset)
in
mconcat
[ sql
, lim
, off
]