{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | This module contain PostgreSQL-specific functions.
--
-- @since: 2.2.8
module Database.Esqueleto.PostgreSQL
    ( AggMode(..)
    , arrayAggDistinct
    , arrayAgg
    , arrayAggWith
    , arrayRemove
    , arrayRemoveNull
    , stringAgg
    , stringAggWith
    , maybeArray
    , chr
    , now_
    , random_
    , upsert
    , upsertBy
    , insertSelectWithConflict
    , insertSelectWithConflictCount
    , filterWhere
    , values
    -- * Internal
    , unsafeSqlAggregateFunction
    ) where

#if __GLASGOW_HASKELL__ < 804
import Data.Semigroup
#endif
import Control.Arrow (first)
import Control.Exception (throw)
import Control.Monad (void)
import Control.Monad.IO.Class (MonadIO(..))
import qualified Control.Monad.Trans.Reader as R
import Data.Int (Int64)
import qualified Data.List.NonEmpty as NE
import Data.Maybe
import Data.Proxy (Proxy(..))
import qualified Data.Text.Internal.Builder as TLB
import qualified Data.Text.Lazy as TL
import Data.Time.Clock (UTCTime)
import qualified Database.Esqueleto.Experimental as Ex
import qualified Database.Esqueleto.Experimental.From as Ex
import Database.Esqueleto.Internal.Internal hiding (random_)
import Database.Esqueleto.Internal.PersistentImport hiding (upsert, upsertBy)
import Database.Persist.Class (OnlyOneUniqueKey)
import Database.Persist (ConstraintNameDB(..), EntityNameDB(..))
import Database.Persist.SqlBackend

-- | (@random()@) Split out into database specific modules
-- because MySQL uses `rand()`.
--
-- @since 2.6.0
random_ :: (PersistField a, Num a) => SqlExpr (Value a)
random_ :: SqlExpr (Value a)
random_ = Builder -> SqlExpr (Value a)
forall a. Builder -> SqlExpr (Value a)
unsafeSqlValue Builder
"RANDOM()"

-- | Empty array literal. (@val []@) does unfortunately not work
emptyArray :: SqlExpr (Value [a])
emptyArray :: SqlExpr (Value [a])
emptyArray = Builder -> SqlExpr (Value [a])
forall a. Builder -> SqlExpr (Value a)
unsafeSqlValue Builder
"'{}'"

-- | Coalesce an array with an empty default value
maybeArray ::
     (PersistField a, PersistField [a])
  => SqlExpr (Value (Maybe [a]))
  -> SqlExpr (Value [a])
maybeArray :: SqlExpr (Value (Maybe [a])) -> SqlExpr (Value [a])
maybeArray SqlExpr (Value (Maybe [a]))
x = [SqlExpr (Value (Maybe [a]))]
-> SqlExpr (Value [a]) -> SqlExpr (Value [a])
forall a.
PersistField a =>
[SqlExpr (Value (Maybe a))]
-> SqlExpr (Value a) -> SqlExpr (Value a)
coalesceDefault [SqlExpr (Value (Maybe [a]))
x] (SqlExpr (Value [a])
forall a. SqlExpr (Value [a])
emptyArray)

-- | Aggregate mode
data AggMode
    = AggModeAll -- ^ ALL
    | AggModeDistinct -- ^ DISTINCT
    deriving (Int -> AggMode -> ShowS
[AggMode] -> ShowS
AggMode -> String
(Int -> AggMode -> ShowS)
-> (AggMode -> String) -> ([AggMode] -> ShowS) -> Show AggMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AggMode] -> ShowS
$cshowList :: [AggMode] -> ShowS
show :: AggMode -> String
$cshow :: AggMode -> String
showsPrec :: Int -> AggMode -> ShowS
$cshowsPrec :: Int -> AggMode -> ShowS
Show)

-- | (Internal) Create a custom aggregate functions with aggregate mode
--
-- /Do/ /not/ use this function directly, instead define a new function and give
-- it a type (see `unsafeSqlBinOp`)
unsafeSqlAggregateFunction
    :: UnsafeSqlFunctionArgument a
    => TLB.Builder
    -> AggMode
    -> a
    -> [OrderByClause]
    -> SqlExpr (Value b)
unsafeSqlAggregateFunction :: Builder -> AggMode -> a -> [OrderByClause] -> SqlExpr (Value b)
unsafeSqlAggregateFunction Builder
name AggMode
mode a
args [OrderByClause]
orderByClauses = SqlExprMeta
-> (NeedParens -> IdentInfo -> (Builder, [PersistValue]))
-> SqlExpr (Value b)
forall a.
SqlExprMeta
-> (NeedParens -> IdentInfo -> (Builder, [PersistValue]))
-> SqlExpr a
ERaw SqlExprMeta
noMeta ((NeedParens -> IdentInfo -> (Builder, [PersistValue]))
 -> SqlExpr (Value b))
-> (NeedParens -> IdentInfo -> (Builder, [PersistValue]))
-> SqlExpr (Value b)
forall a b. (a -> b) -> a -> b
$ \NeedParens
_ IdentInfo
info ->
    let (Builder
orderTLB, [PersistValue]
orderVals) = IdentInfo -> [OrderByClause] -> (Builder, [PersistValue])
makeOrderByNoNewline IdentInfo
info [OrderByClause]
orderByClauses
        -- Don't add a space if we don't have order by clauses
        orderTLBSpace :: Builder
orderTLBSpace =
            case [OrderByClause]
orderByClauses of
                []    -> Builder
""
                (OrderByClause
_:[OrderByClause]
_) -> Builder
" "
        (Builder
argsTLB, [PersistValue]
argsVals) =
            [(Builder, [PersistValue])] -> (Builder, [PersistValue])
forall a. Monoid a => [(Builder, a)] -> (Builder, a)
uncommas' ([(Builder, [PersistValue])] -> (Builder, [PersistValue]))
-> [(Builder, [PersistValue])] -> (Builder, [PersistValue])
forall a b. (a -> b) -> a -> b
$ (SqlExpr (Value ()) -> (Builder, [PersistValue]))
-> [SqlExpr (Value ())] -> [(Builder, [PersistValue])]
forall a b. (a -> b) -> [a] -> [b]
map (\(ERaw SqlExprMeta
_ NeedParens -> IdentInfo -> (Builder, [PersistValue])
f) -> NeedParens -> IdentInfo -> (Builder, [PersistValue])
f NeedParens
Never IdentInfo
info) ([SqlExpr (Value ())] -> [(Builder, [PersistValue])])
-> [SqlExpr (Value ())] -> [(Builder, [PersistValue])]
forall a b. (a -> b) -> a -> b
$ a -> [SqlExpr (Value ())]
forall a. UnsafeSqlFunctionArgument a => a -> [SqlExpr (Value ())]
toArgList a
args
        aggMode :: Builder
aggMode =
            case AggMode
mode of
                AggMode
AggModeAll      -> Builder
""
                -- ALL is the default, so we don't need to
                -- specify it
                AggMode
AggModeDistinct -> Builder
"DISTINCT "
    in ( Builder
name Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
parens (Builder
aggMode Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
argsTLB Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
orderTLBSpace Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
orderTLB)
       , [PersistValue]
argsVals [PersistValue] -> [PersistValue] -> [PersistValue]
forall a. Semigroup a => a -> a -> a
<> [PersistValue]
orderVals
       )

--- | (@array_agg@) Concatenate input values, including @NULL@s,
--- into an array.
arrayAggWith
    :: AggMode
    -> SqlExpr (Value a)
    -> [OrderByClause]
    -> SqlExpr (Value (Maybe [a]))
arrayAggWith :: AggMode
-> SqlExpr (Value a)
-> [OrderByClause]
-> SqlExpr (Value (Maybe [a]))
arrayAggWith = Builder
-> AggMode
-> SqlExpr (Value a)
-> [OrderByClause]
-> SqlExpr (Value (Maybe [a]))
forall a b.
UnsafeSqlFunctionArgument a =>
Builder -> AggMode -> a -> [OrderByClause] -> SqlExpr (Value b)
unsafeSqlAggregateFunction Builder
"array_agg"

--- | (@array_agg@) Concatenate input values, including @NULL@s,
--- into an array.
arrayAgg :: (PersistField a) => SqlExpr (Value a) -> SqlExpr (Value (Maybe [a]))
arrayAgg :: SqlExpr (Value a) -> SqlExpr (Value (Maybe [a]))
arrayAgg SqlExpr (Value a)
x = AggMode
-> SqlExpr (Value a)
-> [OrderByClause]
-> SqlExpr (Value (Maybe [a]))
forall a.
AggMode
-> SqlExpr (Value a)
-> [OrderByClause]
-> SqlExpr (Value (Maybe [a]))
arrayAggWith AggMode
AggModeAll SqlExpr (Value a)
x []

-- | (@array_agg@) Concatenate distinct input values, including @NULL@s, into
-- an array.
--
-- @since 2.5.3
arrayAggDistinct
    :: (PersistField a, PersistField [a])
    => SqlExpr (Value a)
    -> SqlExpr (Value (Maybe [a]))
arrayAggDistinct :: SqlExpr (Value a) -> SqlExpr (Value (Maybe [a]))
arrayAggDistinct SqlExpr (Value a)
x = AggMode
-> SqlExpr (Value a)
-> [OrderByClause]
-> SqlExpr (Value (Maybe [a]))
forall a.
AggMode
-> SqlExpr (Value a)
-> [OrderByClause]
-> SqlExpr (Value (Maybe [a]))
arrayAggWith AggMode
AggModeDistinct SqlExpr (Value a)
x []

-- | (@array_remove@) Remove all elements equal to the given value from the
-- array.
--
-- @since 2.5.3
arrayRemove :: SqlExpr (Value [a]) -> SqlExpr (Value a) -> SqlExpr (Value [a])
arrayRemove :: SqlExpr (Value [a]) -> SqlExpr (Value a) -> SqlExpr (Value [a])
arrayRemove SqlExpr (Value [a])
arr SqlExpr (Value a)
elem' = Builder
-> (SqlExpr (Value [a]), SqlExpr (Value a)) -> SqlExpr (Value [a])
forall a b.
UnsafeSqlFunctionArgument a =>
Builder -> a -> SqlExpr (Value b)
unsafeSqlFunction Builder
"array_remove" (SqlExpr (Value [a])
arr, SqlExpr (Value a)
elem')

-- | Remove @NULL@ values from an array
arrayRemoveNull :: SqlExpr (Value [Maybe a]) -> SqlExpr (Value [a])
-- This can't be a call to arrayRemove because it changes the value type
arrayRemoveNull :: SqlExpr (Value [Maybe a]) -> SqlExpr (Value [a])
arrayRemoveNull SqlExpr (Value [Maybe a])
x = Builder
-> (SqlExpr (Value [Maybe a]), SqlExpr (Value Any))
-> SqlExpr (Value [a])
forall a b.
UnsafeSqlFunctionArgument a =>
Builder -> a -> SqlExpr (Value b)
unsafeSqlFunction Builder
"array_remove" (SqlExpr (Value [Maybe a])
x, Builder -> SqlExpr (Value Any)
forall a. Builder -> SqlExpr (Value a)
unsafeSqlValue Builder
"NULL")


-- | (@string_agg@) Concatenate input values separated by a
-- delimiter.
stringAggWith ::
     SqlString s
  => AggMode -- ^ Aggregate mode (ALL or DISTINCT)
  -> SqlExpr (Value s) -- ^ Input values.
  -> SqlExpr (Value s) -- ^ Delimiter.
  -> [OrderByClause] -- ^ ORDER BY clauses
  -> SqlExpr (Value (Maybe s)) -- ^ Concatenation.
stringAggWith :: AggMode
-> SqlExpr (Value s)
-> SqlExpr (Value s)
-> [OrderByClause]
-> SqlExpr (Value (Maybe s))
stringAggWith AggMode
mode SqlExpr (Value s)
expr SqlExpr (Value s)
delim [OrderByClause]
os =
  Builder
-> AggMode
-> (SqlExpr (Value s), SqlExpr (Value s))
-> [OrderByClause]
-> SqlExpr (Value (Maybe s))
forall a b.
UnsafeSqlFunctionArgument a =>
Builder -> AggMode -> a -> [OrderByClause] -> SqlExpr (Value b)
unsafeSqlAggregateFunction Builder
"string_agg" AggMode
mode (SqlExpr (Value s)
expr, SqlExpr (Value s)
delim) [OrderByClause]
os

-- | (@string_agg@) Concatenate input values separated by a
-- delimiter.
--
-- @since 2.2.8
stringAgg ::
     SqlString s
  => SqlExpr (Value s) -- ^ Input values.
  -> SqlExpr (Value s) -- ^ Delimiter.
  -> SqlExpr (Value (Maybe s)) -- ^ Concatenation.
stringAgg :: SqlExpr (Value s) -> SqlExpr (Value s) -> SqlExpr (Value (Maybe s))
stringAgg SqlExpr (Value s)
expr SqlExpr (Value s)
delim = AggMode
-> SqlExpr (Value s)
-> SqlExpr (Value s)
-> [OrderByClause]
-> SqlExpr (Value (Maybe s))
forall s.
SqlString s =>
AggMode
-> SqlExpr (Value s)
-> SqlExpr (Value s)
-> [OrderByClause]
-> SqlExpr (Value (Maybe s))
stringAggWith AggMode
AggModeAll SqlExpr (Value s)
expr SqlExpr (Value s)
delim []

-- | (@chr@) Translate the given integer to a character. (Note the result will
-- depend on the character set of your database.)
--
-- @since 2.2.11
chr :: SqlString s => SqlExpr (Value Int) -> SqlExpr (Value s)
chr :: SqlExpr (Value Int) -> SqlExpr (Value s)
chr = Builder -> SqlExpr (Value Int) -> SqlExpr (Value s)
forall a b.
UnsafeSqlFunctionArgument a =>
Builder -> a -> SqlExpr (Value b)
unsafeSqlFunction Builder
"chr"

now_ :: SqlExpr (Value UTCTime)
now_ :: SqlExpr (Value UTCTime)
now_ = Builder -> () -> SqlExpr (Value UTCTime)
forall a b.
UnsafeSqlFunctionArgument a =>
Builder -> a -> SqlExpr (Value b)
unsafeSqlFunction Builder
"NOW" ()

upsert
    ::
    ( MonadIO m
    , PersistEntity record
    , OnlyOneUniqueKey record
    , PersistRecordBackend record SqlBackend
    , IsPersistBackend (PersistEntityBackend record)
    )
    => record
    -- ^ new record to insert
    -> [SqlExpr (Entity record) -> SqlExpr Update]
    -- ^ updates to perform if the record already exists
    -> R.ReaderT SqlBackend m (Entity record)
    -- ^ the record in the database after the operation
upsert :: record
-> [SqlExpr (Entity record) -> SqlExpr Update]
-> ReaderT SqlBackend m (Entity record)
upsert record
record [SqlExpr (Entity record) -> SqlExpr Update]
updates = do
    Unique record
uniqueKey <- record -> ReaderT SqlBackend m (Unique record)
forall record backend (m :: * -> *).
(MonadIO m, PersistUniqueWrite backend,
 PersistRecordBackend record backend, OnlyOneUniqueKey record) =>
record -> ReaderT backend m (Unique record)
onlyUnique record
record
    Unique record
-> record
-> [SqlExpr (Entity record) -> SqlExpr Update]
-> ReaderT SqlBackend m (Entity record)
forall (m :: * -> *) record.
(MonadIO m, PersistEntity record,
 IsPersistBackend (PersistEntityBackend record)) =>
Unique record
-> record
-> [SqlExpr (Entity record) -> SqlExpr Update]
-> ReaderT SqlBackend m (Entity record)
upsertBy Unique record
uniqueKey record
record [SqlExpr (Entity record) -> SqlExpr Update]
updates

upsertBy
    ::
    (MonadIO m
    , PersistEntity record
    , IsPersistBackend (PersistEntityBackend record)
    )
    => Unique record
    -- ^ uniqueness constraint to find by
    -> record
    -- ^ new record to insert
    -> [SqlExpr (Entity record) -> SqlExpr Update]
    -- ^ updates to perform if the record already exists
    -> R.ReaderT SqlBackend m (Entity record)
    -- ^ the record in the database after the operation
upsertBy :: Unique record
-> record
-> [SqlExpr (Entity record) -> SqlExpr Update]
-> ReaderT SqlBackend m (Entity record)
upsertBy Unique record
uniqueKey record
record [SqlExpr (Entity record) -> SqlExpr Update]
updates = do
    SqlBackend
sqlB <- ReaderT SqlBackend m SqlBackend
forall (m :: * -> *) r. Monad m => ReaderT r m r
R.ask
    case SqlBackend
-> Maybe
     (EntityDef -> NonEmpty (FieldNameHS, FieldNameDB) -> Text -> Text)
forall backend (m :: * -> *).
(BackendCompatible SqlBackend backend, MonadReader backend m) =>
m (Maybe
     (EntityDef -> NonEmpty (FieldNameHS, FieldNameDB) -> Text -> Text))
getConnUpsertSql SqlBackend
sqlB of
        Maybe
  (EntityDef -> NonEmpty (FieldNameHS, FieldNameDB) -> Text -> Text)
Nothing ->
            -- Postgres backend should have connUpsertSql, if this error is
            -- thrown, check changes on persistent
            EsqueletoError -> ReaderT SqlBackend m (Entity record)
forall a e. Exception e => e -> a
throw (UnexpectedCaseError -> EsqueletoError
UnexpectedCaseErr UnexpectedCaseError
OperationNotSupported)
        Just EntityDef -> NonEmpty (FieldNameHS, FieldNameDB) -> Text -> Text
upsertSql ->
            SqlBackend
-> (EntityDef
    -> NonEmpty (FieldNameHS, FieldNameDB) -> Text -> Text)
-> ReaderT SqlBackend m (Entity record)
handler SqlBackend
sqlB EntityDef -> NonEmpty (FieldNameHS, FieldNameDB) -> Text -> Text
upsertSql
  where
    addVals :: [PersistValue] -> [PersistValue]
addVals [PersistValue]
l = (SomePersistField -> PersistValue)
-> [SomePersistField] -> [PersistValue]
forall a b. (a -> b) -> [a] -> [b]
map SomePersistField -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue (record -> [SomePersistField]
forall record. PersistEntity record => record -> [SomePersistField]
toPersistFields record
record) [PersistValue] -> [PersistValue] -> [PersistValue]
forall a. [a] -> [a] -> [a]
++ [PersistValue]
l [PersistValue] -> [PersistValue] -> [PersistValue]
forall a. [a] -> [a] -> [a]
++ Unique record -> [PersistValue]
forall record.
PersistEntity record =>
Unique record -> [PersistValue]
persistUniqueToValues Unique record
uniqueKey
    entDef :: EntityDef
entDef = Maybe record -> EntityDef
forall record (proxy :: * -> *).
PersistEntity record =>
proxy record -> EntityDef
entityDef (record -> Maybe record
forall a. a -> Maybe a
Just record
record)
    updatesText :: SqlBackend -> (Text, [PersistValue])
updatesText SqlBackend
conn = (Builder -> Text)
-> (Builder, [PersistValue]) -> (Text, [PersistValue])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first Builder -> Text
builderToText ((Builder, [PersistValue]) -> (Text, [PersistValue]))
-> (Builder, [PersistValue]) -> (Text, [PersistValue])
forall a b. (a -> b) -> a -> b
$ SqlBackend
-> [SqlExpr (Entity record) -> SqlExpr Update]
-> (Builder, [PersistValue])
forall backend val.
BackendCompatible SqlBackend backend =>
backend
-> [SqlExpr (Entity val) -> SqlExpr Update]
-> (Builder, [PersistValue])
renderUpdates SqlBackend
conn [SqlExpr (Entity record) -> SqlExpr Update]
updates
#if MIN_VERSION_persistent(2,11,0)
    uniqueFields :: NonEmpty (FieldNameHS, FieldNameDB)
uniqueFields = Unique record -> NonEmpty (FieldNameHS, FieldNameDB)
forall record.
PersistEntity record =>
Unique record -> NonEmpty (FieldNameHS, FieldNameDB)
persistUniqueToFieldNames Unique record
uniqueKey
    handler :: SqlBackend
-> (EntityDef
    -> NonEmpty (FieldNameHS, FieldNameDB) -> Text -> Text)
-> ReaderT SqlBackend m (Entity record)
handler SqlBackend
sqlB EntityDef -> NonEmpty (FieldNameHS, FieldNameDB) -> Text -> Text
upsertSql = do
        let (Text
updateText, [PersistValue]
updateVals) =
                SqlBackend -> (Text, [PersistValue])
updatesText SqlBackend
sqlB
            queryText :: Text
queryText =
                EntityDef -> NonEmpty (FieldNameHS, FieldNameDB) -> Text -> Text
upsertSql EntityDef
entDef NonEmpty (FieldNameHS, FieldNameDB)
uniqueFields Text
updateText
            queryVals :: [PersistValue]
queryVals =
                [PersistValue] -> [PersistValue]
addVals [PersistValue]
updateVals
        [Entity record]
xs <- Text -> [PersistValue] -> ReaderT SqlBackend m [Entity record]
forall a (m :: * -> *) backend.
(RawSql a, MonadIO m, BackendCompatible SqlBackend backend) =>
Text -> [PersistValue] -> ReaderT backend m [a]
rawSql Text
queryText [PersistValue]
queryVals
        Entity record -> ReaderT SqlBackend m (Entity record)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Entity record] -> Entity record
forall a. [a] -> a
head [Entity record]
xs)
#else
    uDef = toUniqueDef uniqueKey
    handler conn f = fmap head $ uncurry rawSql $
        (***) (f entDef (uDef :| [])) addVals $ updatesText conn
#endif

-- | Inserts into a table the results of a query similar to 'insertSelect' but allows
-- to update values that violate a constraint during insertions.
--
-- Example of usage:
--
-- @
-- share [ mkPersist sqlSettings
--       , mkDeleteCascade sqlSettings
--       , mkMigrate "migrate"
--       ] [persistLowerCase|
--   Bar
--     num Int
--     deriving Eq Show
--   Foo
--     num Int
--     UniqueFoo num
--     deriving Eq Show
-- |]
--
-- insertSelectWithConflict
--   UniqueFoo -- (UniqueFoo undefined) or (UniqueFoo anyNumber) would also work
--   (from $ \b ->
--     return $ Foo <# (b ^. BarNum)
--   )
--   (\current excluded ->
--     [FooNum =. (current ^. FooNum) +. (excluded ^. FooNum)]
--   )
-- @
--
-- Inserts to table Foo all Bar.num values and in case of conflict SomeFooUnique,
-- the conflicting value is updated to the current plus the excluded.
--
-- @since 3.1.3
insertSelectWithConflict
    :: forall a m val
     . (FinalResult a, KnowResult a ~ Unique val, MonadIO m, PersistEntity val)
    => a
    -- ^ Unique constructor or a unique, this is used just to get the name of
    -- the postgres constraint, the value(s) is(are) never used, so if you have
    -- a unique "MyUnique 0", "MyUnique undefined" would work as well.
    -> SqlQuery (SqlExpr (Insertion val))
    -- ^ Insert query.
    -> (SqlExpr (Entity val) -> SqlExpr (Entity val) -> [SqlExpr (Entity val) -> SqlExpr Update])
    -- ^ A list of updates to be applied in case of the constraint being
    -- violated. The expression takes the current and excluded value to produce
    -- the updates.
    -> SqlWriteT m ()
insertSelectWithConflict :: a
-> SqlQuery (SqlExpr (Insertion val))
-> (SqlExpr (Entity val)
    -> SqlExpr (Entity val)
    -> [SqlExpr (Entity val) -> SqlExpr Update])
-> SqlWriteT m ()
insertSelectWithConflict a
unique SqlQuery (SqlExpr (Insertion val))
query SqlExpr (Entity val)
-> SqlExpr (Entity val) -> [SqlExpr (Entity val) -> SqlExpr Update]
a =
    ReaderT backend m Int64 -> ReaderT backend m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT backend m Int64 -> ReaderT backend m ())
-> ReaderT backend m Int64 -> ReaderT backend m ()
forall a b. (a -> b) -> a -> b
$ a
-> SqlQuery (SqlExpr (Insertion val))
-> (SqlExpr (Entity val)
    -> SqlExpr (Entity val)
    -> [SqlExpr (Entity val) -> SqlExpr Update])
-> SqlWriteT m Int64
forall a val (m :: * -> *).
(FinalResult a, KnowResult a ~ Unique val, MonadIO m,
 PersistEntity val) =>
a
-> SqlQuery (SqlExpr (Insertion val))
-> (SqlExpr (Entity val)
    -> SqlExpr (Entity val)
    -> [SqlExpr (Entity val) -> SqlExpr Update])
-> SqlWriteT m Int64
insertSelectWithConflictCount a
unique SqlQuery (SqlExpr (Insertion val))
query SqlExpr (Entity val)
-> SqlExpr (Entity val) -> [SqlExpr (Entity val) -> SqlExpr Update]
a

-- | Same as 'insertSelectWithConflict' but returns the number of rows affected.
--
-- @since 3.1.3
insertSelectWithConflictCount
    :: forall a val m
     . (FinalResult a, KnowResult a ~ Unique val, MonadIO m, PersistEntity val)
    => a
    -> SqlQuery (SqlExpr (Insertion val))
    -> (SqlExpr (Entity val) -> SqlExpr (Entity val) -> [SqlExpr (Entity val) -> SqlExpr Update])
    -> SqlWriteT m Int64
insertSelectWithConflictCount :: a
-> SqlQuery (SqlExpr (Insertion val))
-> (SqlExpr (Entity val)
    -> SqlExpr (Entity val)
    -> [SqlExpr (Entity val) -> SqlExpr Update])
-> SqlWriteT m Int64
insertSelectWithConflictCount a
unique SqlQuery (SqlExpr (Insertion val))
query SqlExpr (Entity val)
-> SqlExpr (Entity val) -> [SqlExpr (Entity val) -> SqlExpr Update]
conflictQuery = do
    backend
conn <- ReaderT backend m backend
forall (m :: * -> *) r. Monad m => ReaderT r m r
R.ask
    (Text -> [PersistValue] -> ReaderT backend m Int64)
-> (Text, [PersistValue]) -> ReaderT backend m Int64
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> [PersistValue] -> ReaderT backend m Int64
forall (m :: * -> *) backend.
(MonadIO m, BackendCompatible SqlBackend backend) =>
Text -> [PersistValue] -> ReaderT backend m Int64
rawExecuteCount ((Text, [PersistValue]) -> ReaderT backend m Int64)
-> (Text, [PersistValue]) -> ReaderT backend m Int64
forall a b. (a -> b) -> a -> b
$
        (Builder, [PersistValue])
-> (Builder, [PersistValue]) -> (Text, [PersistValue])
forall a. (Builder, [a]) -> (Builder, [a]) -> (Text, [a])
combine
            (Mode
-> (backend, IdentState)
-> SqlQuery (SqlExpr (Insertion val))
-> (Builder, [PersistValue])
forall a r backend.
(SqlSelect a r, BackendCompatible SqlBackend backend) =>
Mode
-> (backend, IdentState) -> SqlQuery a -> (Builder, [PersistValue])
toRawSql Mode
INSERT_INTO (backend
conn, IdentState
initialIdentState) SqlQuery (SqlExpr (Insertion val))
query)
            (backend -> (Builder, [PersistValue])
conflict backend
conn)
  where
    proxy :: Proxy val
    proxy :: Proxy val
proxy = Proxy val
forall k (t :: k). Proxy t
Proxy
    updates :: [SqlExpr (Entity val) -> SqlExpr Update]
updates = SqlExpr (Entity val)
-> SqlExpr (Entity val) -> [SqlExpr (Entity val) -> SqlExpr Update]
conflictQuery SqlExpr (Entity val)
entCurrent SqlExpr (Entity val)
entExcluded
    combine :: (Builder, [a]) -> (Builder, [a]) -> (Text, [a])
combine (Builder
tlb1,[a]
vals1) (Builder
tlb2,[a]
vals2) = (Builder -> Text
builderToText (Builder
tlb1 Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
tlb2), [a]
vals1 [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
vals2)
    entExcluded :: SqlExpr (Entity val)
entExcluded = Ident -> SqlExpr (Entity val)
forall ent. PersistEntity ent => Ident -> SqlExpr (Entity ent)
unsafeSqlEntity (Text -> Ident
I Text
"excluded")
    tableName :: proxy val -> Text
tableName = EntityNameDB -> Text
unEntityNameDB (EntityNameDB -> Text)
-> (proxy val -> EntityNameDB) -> proxy val -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> EntityNameDB
getEntityDBName (EntityDef -> EntityNameDB)
-> (proxy val -> EntityDef) -> proxy val -> EntityNameDB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. proxy val -> EntityDef
forall record (proxy :: * -> *).
PersistEntity record =>
proxy record -> EntityDef
entityDef
    entCurrent :: SqlExpr (Entity val)
entCurrent = Ident -> SqlExpr (Entity val)
forall ent. PersistEntity ent => Ident -> SqlExpr (Entity ent)
unsafeSqlEntity (Text -> Ident
I (Proxy val -> Text
forall (proxy :: * -> *). proxy val -> Text
tableName Proxy val
proxy))
    uniqueDef :: UniqueDef
uniqueDef = a -> UniqueDef
forall a val.
(KnowResult a ~ Unique val, PersistEntity val, FinalResult a) =>
a -> UniqueDef
toUniqueDef a
unique
    constraint :: Builder
constraint = Text -> Builder
TLB.fromText (Text -> Builder) -> (UniqueDef -> Text) -> UniqueDef -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstraintNameDB -> Text
unConstraintNameDB (ConstraintNameDB -> Text)
-> (UniqueDef -> ConstraintNameDB) -> UniqueDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UniqueDef -> ConstraintNameDB
uniqueDBName (UniqueDef -> Builder) -> UniqueDef -> Builder
forall a b. (a -> b) -> a -> b
$ UniqueDef
uniqueDef
    renderedUpdates :: (BackendCompatible SqlBackend backend) => backend -> (TLB.Builder, [PersistValue])
    renderedUpdates :: backend -> (Builder, [PersistValue])
renderedUpdates backend
conn = backend
-> [SqlExpr (Entity val) -> SqlExpr Update]
-> (Builder, [PersistValue])
forall backend val.
BackendCompatible SqlBackend backend =>
backend
-> [SqlExpr (Entity val) -> SqlExpr Update]
-> (Builder, [PersistValue])
renderUpdates backend
conn [SqlExpr (Entity val) -> SqlExpr Update]
updates
    conflict :: backend -> (Builder, [PersistValue])
conflict backend
conn = ([Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([
        Text -> Builder
TLB.fromText Text
"ON CONFLICT ON CONSTRAINT \"",
        Builder
constraint,
        Text -> Builder
TLB.fromText Text
"\" DO "
      ] [Builder] -> [Builder] -> [Builder]
forall a. [a] -> [a] -> [a]
++ if [SqlExpr (Entity val) -> SqlExpr Update] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SqlExpr (Entity val) -> SqlExpr Update]
updates then [Text -> Builder
TLB.fromText Text
"NOTHING"] else [
        Text -> Builder
TLB.fromText Text
"UPDATE SET ",
        Builder
updatesTLB
      ]),[PersistValue]
values)
      where
        (Builder
updatesTLB,[PersistValue]
values) = backend -> (Builder, [PersistValue])
forall backend.
BackendCompatible SqlBackend backend =>
backend -> (Builder, [PersistValue])
renderedUpdates backend
conn

-- | Allow aggregate functions to take a filter clause.
--
-- Example of usage:
--
-- @
-- share [mkPersist sqlSettings] [persistLowerCase|
--   User
--     name Text
--     deriving Eq Show
--   Task
--     userId UserId
--     completed Bool
--     deriving Eq Show
-- |]
--
-- select $ from $ \(users `InnerJoin` tasks) -> do
--   on $ users ^. UserId ==. tasks ^. TaskUserId
--   groupBy $ users ^. UserId
--   return
--    ( users ^. UserId
--    , count (tasks ^. TaskId) `filterWhere` (tasks ^. TaskCompleted ==. val True)
--    , count (tasks ^. TaskId) `filterWhere` (tasks ^. TaskCompleted ==. val False)
--    )
-- @
--
-- @since 3.3.3.3
filterWhere
    :: SqlExpr (Value a)
    -- ^ Aggregate function
    -> SqlExpr (Value Bool)
    -- ^ Filter clause
    -> SqlExpr (Value a)
filterWhere :: SqlExpr (Value a) -> SqlExpr (Value Bool) -> SqlExpr (Value a)
filterWhere SqlExpr (Value a)
aggExpr SqlExpr (Value Bool)
clauseExpr = SqlExprMeta
-> (NeedParens -> IdentInfo -> (Builder, [PersistValue]))
-> SqlExpr (Value a)
forall a.
SqlExprMeta
-> (NeedParens -> IdentInfo -> (Builder, [PersistValue]))
-> SqlExpr a
ERaw SqlExprMeta
noMeta ((NeedParens -> IdentInfo -> (Builder, [PersistValue]))
 -> SqlExpr (Value a))
-> (NeedParens -> IdentInfo -> (Builder, [PersistValue]))
-> SqlExpr (Value a)
forall a b. (a -> b) -> a -> b
$ \NeedParens
_ IdentInfo
info ->
    let (Builder
aggBuilder, [PersistValue]
aggValues) = case SqlExpr (Value a)
aggExpr of
            ERaw SqlExprMeta
_ NeedParens -> IdentInfo -> (Builder, [PersistValue])
aggF     -> NeedParens -> IdentInfo -> (Builder, [PersistValue])
aggF NeedParens
Never IdentInfo
info
        (Builder
clauseBuilder, [PersistValue]
clauseValues) = case SqlExpr (Value Bool)
clauseExpr of
            ERaw SqlExprMeta
_ NeedParens -> IdentInfo -> (Builder, [PersistValue])
clauseF  -> NeedParens -> IdentInfo -> (Builder, [PersistValue])
clauseF NeedParens
Never IdentInfo
info
    in ( Builder
aggBuilder Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" FILTER (WHERE " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
clauseBuilder Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
")"
       , [PersistValue]
aggValues [PersistValue] -> [PersistValue] -> [PersistValue]
forall a. Semigroup a => a -> a -> a
<> [PersistValue]
clauseValues
       )


-- | Allows to use `VALUES (..)` in-memory set of values
-- in RHS of `from` expressions. Useful for JOIN's on
-- known values which also can be additionally preprocessed
-- somehow on db side with usage of inner PostgreSQL capabilities.
--
--
-- Example of usage:
--
-- @
-- share [mkPersist sqlSettings] [persistLowerCase|
--   User
--     name Text
--     age Int
--     deriving Eq Show
--
-- select $ do
--  bound :& user <- from $
--      values (   (val (10 :: Int), val ("ten" :: Text))
--            :| [ (val 20, val "twenty")
--               , (val 30, val "thirty") ]
--            )
--      `InnerJoin` table User
--      `on` (\((bound, _boundName) :& user) -> user^.UserAge >=. bound)
--  groupBy bound
--  pure (bound, count @Int $ user^.UserName)
-- @
--
-- @since 3.5.2.3
values :: (ToSomeValues a, Ex.ToAliasReference a, Ex.ToAlias a) => NE.NonEmpty a -> Ex.From a
values :: NonEmpty a -> From a
values NonEmpty a
exprs = SqlQuery (a, NeedParens -> IdentInfo -> (Builder, [PersistValue]))
-> From a
forall a.
SqlQuery (a, NeedParens -> IdentInfo -> (Builder, [PersistValue]))
-> From a
Ex.From (SqlQuery (a, NeedParens -> IdentInfo -> (Builder, [PersistValue]))
 -> From a)
-> SqlQuery
     (a, NeedParens -> IdentInfo -> (Builder, [PersistValue]))
-> From a
forall a b. (a -> b) -> a -> b
$ do
    Ident
ident <- DBName -> SqlQuery Ident
newIdentFor (DBName -> SqlQuery Ident) -> DBName -> SqlQuery Ident
forall a b. (a -> b) -> a -> b
$ Text -> DBName
DBName Text
"vq"
    a
alias <- a -> SqlQuery a
forall a. ToAlias a => a -> SqlQuery a
Ex.toAlias (a -> SqlQuery a) -> a -> SqlQuery a
forall a b. (a -> b) -> a -> b
$ NonEmpty a -> a
forall a. NonEmpty a -> a
NE.head NonEmpty a
exprs
    a
ref   <- Ident -> a -> SqlQuery a
forall a. ToAliasReference a => Ident -> a -> SqlQuery a
Ex.toAliasReference Ident
ident a
alias
    let aliasIdents :: [Ident]
aliasIdents = (SomeValue -> Maybe Ident) -> [SomeValue] -> [Ident]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\SomeValue
someVal -> case SomeValue
someVal of
            SomeValue (ERaw SqlExprMeta
aliasMeta NeedParens -> IdentInfo -> (Builder, [PersistValue])
_) -> SqlExprMeta -> Maybe Ident
sqlExprMetaAlias SqlExprMeta
aliasMeta
            ) ([SomeValue] -> [Ident]) -> [SomeValue] -> [Ident]
forall a b. (a -> b) -> a -> b
$ a -> [SomeValue]
forall a. ToSomeValues a => a -> [SomeValue]
toSomeValues a
ref
    (a, NeedParens -> IdentInfo -> (Builder, [PersistValue]))
-> SqlQuery
     (a, NeedParens -> IdentInfo -> (Builder, [PersistValue]))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
ref, (IdentInfo -> (Builder, [PersistValue]))
-> NeedParens -> IdentInfo -> (Builder, [PersistValue])
forall a b. a -> b -> a
const ((IdentInfo -> (Builder, [PersistValue]))
 -> NeedParens -> IdentInfo -> (Builder, [PersistValue]))
-> (IdentInfo -> (Builder, [PersistValue]))
-> NeedParens
-> IdentInfo
-> (Builder, [PersistValue])
forall a b. (a -> b) -> a -> b
$ Ident -> [Ident] -> IdentInfo -> (Builder, [PersistValue])
mkExpr Ident
ident [Ident]
aliasIdents)
  where
    someValueToSql :: IdentInfo -> SomeValue -> (TLB.Builder, [PersistValue])
    someValueToSql :: IdentInfo -> SomeValue -> (Builder, [PersistValue])
someValueToSql IdentInfo
info (SomeValue SqlExpr (Value a)
expr) = IdentInfo -> SqlExpr (Value a) -> (Builder, [PersistValue])
forall a.
IdentInfo -> SqlExpr (Value a) -> (Builder, [PersistValue])
materializeExpr IdentInfo
info SqlExpr (Value a)
expr

    mkValuesRowSql :: IdentInfo -> [SomeValue] -> (TLB.Builder, [PersistValue])
    mkValuesRowSql :: IdentInfo -> [SomeValue] -> (Builder, [PersistValue])
mkValuesRowSql IdentInfo
info [SomeValue]
vs =
        let materialized :: [(Builder, [PersistValue])]
materialized = IdentInfo -> SomeValue -> (Builder, [PersistValue])
someValueToSql IdentInfo
info (SomeValue -> (Builder, [PersistValue]))
-> [SomeValue] -> [(Builder, [PersistValue])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SomeValue]
vs
            valsSql :: [Text]
valsSql = Builder -> Text
TLB.toLazyText (Builder -> Text)
-> ((Builder, [PersistValue]) -> Builder)
-> (Builder, [PersistValue])
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Builder, [PersistValue]) -> Builder
forall a b. (a, b) -> a
fst ((Builder, [PersistValue]) -> Text)
-> [(Builder, [PersistValue])] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Builder, [PersistValue])]
materialized
            params :: [PersistValue]
params = ((Builder, [PersistValue]) -> [PersistValue])
-> [(Builder, [PersistValue])] -> [PersistValue]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Builder, [PersistValue]) -> [PersistValue]
forall a b. (a, b) -> b
snd [(Builder, [PersistValue])]
materialized
        in (Text -> Builder
TLB.fromLazyText (Text -> Builder) -> Text -> Builder
forall a b. (a -> b) -> a -> b
$ Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
TL.intercalate Text
"," [Text]
valsSql Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")", [PersistValue]
params)

    -- (VALUES (v11, v12,..), (v21, v22,..)) as "vq"("v1", "v2",..)
    mkExpr :: Ident -> [Ident] -> IdentInfo -> (TLB.Builder, [PersistValue])
    mkExpr :: Ident -> [Ident] -> IdentInfo -> (Builder, [PersistValue])
mkExpr Ident
valsIdent [Ident]
colIdents IdentInfo
info =
        let materialized :: [(Builder, [PersistValue])]
materialized = IdentInfo -> [SomeValue] -> (Builder, [PersistValue])
mkValuesRowSql IdentInfo
info ([SomeValue] -> (Builder, [PersistValue]))
-> (a -> [SomeValue]) -> a -> (Builder, [PersistValue])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [SomeValue]
forall a. ToSomeValues a => a -> [SomeValue]
toSomeValues (a -> (Builder, [PersistValue]))
-> [a] -> [(Builder, [PersistValue])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty a -> [a]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty a
exprs
            (Text
valsSql, [PersistValue]
params) =
                ( Text -> [Text] -> Text
TL.intercalate Text
"," ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ ((Builder, [PersistValue]) -> Text)
-> [(Builder, [PersistValue])] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Builder -> Text
TLB.toLazyText (Builder -> Text)
-> ((Builder, [PersistValue]) -> Builder)
-> (Builder, [PersistValue])
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Builder, [PersistValue]) -> Builder
forall a b. (a, b) -> a
fst) [(Builder, [PersistValue])]
materialized
                , ((Builder, [PersistValue]) -> [PersistValue])
-> [(Builder, [PersistValue])] -> [PersistValue]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Builder, [PersistValue]) -> [PersistValue]
forall a b. (a, b) -> b
snd [(Builder, [PersistValue])]
materialized
                )
            colsAliases :: Text
colsAliases = Text -> [Text] -> Text
TL.intercalate Text
"," ((Ident -> Text) -> [Ident] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Builder -> Text
TLB.toLazyText (Builder -> Text) -> (Ident -> Builder) -> Ident -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdentInfo -> Ident -> Builder
useIdent IdentInfo
info) [Ident]
colIdents)
        in
            ( Builder
"(VALUES " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
TLB.fromLazyText Text
valsSql Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
") AS "
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> IdentInfo -> Ident -> Builder
useIdent IdentInfo
info Ident
valsIdent
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"(" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
TLB.fromLazyText Text
colsAliases Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
")"
            , [PersistValue]
params
            )