{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings
, GADTs, CPP
#-}
module Database.Esqueleto.PostgreSQL
( AggMode(..)
, arrayAggDistinct
, arrayAgg
, arrayAggWith
, arrayRemove
, arrayRemoveNull
, stringAgg
, stringAggWith
, maybeArray
, chr
, now_
, random_
, upsert
, upsertBy
, unsafeSqlAggregateFunction
) where
#if __GLASGOW_HASKELL__ < 804
import Data.Semigroup
#endif
import qualified Data.Text.Internal.Builder as TLB
import Data.Time.Clock (UTCTime)
import Database.Esqueleto.Internal.Language hiding (random_)
import Database.Esqueleto.Internal.PersistentImport hiding (upsert, upsertBy)
import Database.Esqueleto.Internal.Sql
import Database.Esqueleto.Internal.Internal (EsqueletoError(..), CompositeKeyError(..),
UnexpectedCaseError(..), SetClause)
import Database.Persist.Class (OnlyOneUniqueKey)
import Data.List.NonEmpty ( NonEmpty( (:|) ) )
import Control.Arrow ((***), first)
import Control.Exception (Exception, throw, throwIO)
import Control.Monad.IO.Class (MonadIO (..))
import qualified Control.Monad.Trans.Reader as R
random_ :: (PersistField a, Num a) => SqlExpr (Value a)
random_ = unsafeSqlValue "RANDOM()"
emptyArray :: SqlExpr (Value [a])
emptyArray = unsafeSqlValue "'{}'"
maybeArray ::
(PersistField a, PersistField [a])
=> SqlExpr (Value (Maybe [a]))
-> SqlExpr (Value [a])
maybeArray x = coalesceDefault [x] (emptyArray)
data AggMode = AggModeAll
| AggModeDistinct
deriving (Show)
unsafeSqlAggregateFunction ::
UnsafeSqlFunctionArgument a
=> TLB.Builder
-> AggMode
-> a
-> [OrderByClause]
-> SqlExpr (Value b)
unsafeSqlAggregateFunction name mode args orderByClauses =
ERaw Never $ \info ->
let (orderTLB, orderVals) = makeOrderByNoNewline info orderByClauses
orderTLBSpace = case orderByClauses of
[] -> ""
(_:_) -> " "
(argsTLB, argsVals) =
uncommas' $ map (\(ERaw _ f) -> f info) $ toArgList args
aggMode = case mode of
AggModeAll -> ""
AggModeDistinct -> "DISTINCT "
in ( name <> parens (aggMode <> argsTLB <> orderTLBSpace <> orderTLB)
, argsVals <> orderVals
)
arrayAggWith ::
AggMode
-> SqlExpr (Value a)
-> [OrderByClause]
-> SqlExpr (Value (Maybe [a]))
arrayAggWith = unsafeSqlAggregateFunction "array_agg"
arrayAgg :: (PersistField a) => SqlExpr (Value a) -> SqlExpr (Value (Maybe [a]))
arrayAgg x = arrayAggWith AggModeAll x []
arrayAggDistinct ::
(PersistField a, PersistField [a])
=> SqlExpr (Value a)
-> SqlExpr (Value (Maybe [a]))
arrayAggDistinct x = arrayAggWith AggModeDistinct x []
arrayRemove :: SqlExpr (Value [a]) -> SqlExpr (Value a) -> SqlExpr (Value [a])
arrayRemove arr elem' = unsafeSqlFunction "array_remove" (arr, elem')
arrayRemoveNull :: SqlExpr (Value [Maybe a]) -> SqlExpr (Value [a])
arrayRemoveNull x = unsafeSqlFunction "array_remove" (x, unsafeSqlValue "NULL")
stringAggWith ::
SqlString s
=> AggMode
-> SqlExpr (Value s)
-> SqlExpr (Value s)
-> [OrderByClause]
-> SqlExpr (Value (Maybe s))
stringAggWith mode expr delim os =
unsafeSqlAggregateFunction "string_agg" mode (expr, delim) os
stringAgg ::
SqlString s
=> SqlExpr (Value s)
-> SqlExpr (Value s)
-> SqlExpr (Value (Maybe s))
stringAgg expr delim = stringAggWith AggModeAll expr delim []
chr :: SqlString s => SqlExpr (Value Int) -> SqlExpr (Value s)
chr = unsafeSqlFunction "chr"
now_ :: SqlExpr (Value UTCTime)
now_ = unsafeSqlValue "NOW()"
upsert :: (MonadIO m,
PersistEntity record,
OnlyOneUniqueKey record,
PersistRecordBackend record SqlBackend,
IsPersistBackend (PersistEntityBackend record))
=> record
-> [SqlExpr (Update record)]
-> R.ReaderT SqlBackend m (Entity record)
upsert record updates = do
uniqueKey <- onlyUnique record
upsertBy uniqueKey record updates
upsertBy :: (MonadIO m,
PersistEntity record,
IsPersistBackend (PersistEntityBackend record))
=> Unique record
-> record
-> [SqlExpr (Update record)]
-> R.ReaderT SqlBackend m (Entity record)
upsertBy uniqueKey record updates = do
sqlB <- R.ask
maybe
(throw (UnexpectedCaseErr OperationNotSupported))
(handler sqlB)
(connUpsertSql sqlB)
where
addVals l = map toPersistValue (toPersistFields record) ++ l ++ persistUniqueToValues uniqueKey
entDef = entityDef (Just record)
uDef = head $ filter ((==) (persistUniqueToFieldNames uniqueKey) . uniqueFields) $ entityUniques entDef
updatesText conn = first builderToText $ renderUpdates conn updates
handler conn f = fmap head $ uncurry rawSql $
(***) (f entDef (uDef :| [])) addVals $ updatesText conn
renderUpdates :: SqlBackend
-> [SqlExpr (Update val)]
-> (TLB.Builder, [PersistValue])
renderUpdates conn = uncommas' . concatMap renderUpdate
where
mk :: SqlExpr (Value ()) -> [(TLB.Builder, [PersistValue])]
mk (ERaw _ f) = [f info]
mk (ECompositeKey _) = throw (CompositeKeyErr MakeSetError)
renderUpdate :: SqlExpr (Update val) -> [(TLB.Builder, [PersistValue])]
renderUpdate (ESet f) = mk (f undefined)
info = (projectBackend conn, initialIdentState)