750 lines
30 KiB
Haskell
750 lines
30 KiB
Haskell
-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
|
|
|
module Database.Esqueleto.Utils
|
|
( true, false
|
|
, vals, justVal, justValList, toValues
|
|
, isJust, alt
|
|
, isInfixOf, hasInfix
|
|
, isPrefixOf_, hasPrefix_
|
|
, strConcat, substring
|
|
, (=?.), (?=.)
|
|
, (=~.), (~=.)
|
|
, (>~.), (<~.)
|
|
, or, and
|
|
, any, all
|
|
, subSelectAnd, subSelectOr
|
|
, mkExactFilter, mkExactFilterWith, mkExactFilterWithComma
|
|
, mkExactFilterLast, mkExactFilterLastWith
|
|
, mkExactFilterMaybeLast, mkExactFilterMaybeLast'
|
|
, mkContainsFilter, mkContainsFilterWith
|
|
, mkContainsFilterWithSet, mkContainsFilterWithComma, mkContainsFilterWithCommaPlus
|
|
, mkDayFilter, mkDayFilterFrom, mkDayFilterTo
|
|
, mkExistsFilter, mkExistsFilterWithComma
|
|
, anyFilter, allFilter
|
|
, ascNullsFirst, descNullsLast
|
|
, orderByList
|
|
, orderByOrd, orderByEnum
|
|
, strip, lower, ciEq
|
|
, selectExists, selectNotExists
|
|
, SqlHashable
|
|
, sha256
|
|
, isTrue, isFalse
|
|
, maybe, maybe2, maybeEq, guardMaybe, unsafeCoalesce
|
|
, bool
|
|
, max, min
|
|
, greatest, least
|
|
, abs
|
|
, SqlProject(..)
|
|
, (->.), (->>.), (#>>.)
|
|
, fromSqlKey
|
|
, unKey
|
|
, subSelectCountDistinct
|
|
, selectCountRows, selectCountDistinct
|
|
, selectMaybe
|
|
, num2text
|
|
, day, day', dayMaybe, interval, diffDays, diffTimes
|
|
, exprLift
|
|
, explicitUnsafeCoerceSqlExprValue
|
|
, module Database.Esqueleto.Utils.TH
|
|
) where
|
|
|
|
|
|
import ClassyPrelude.Yesod hiding (isInfixOf, any, all, or, and, isJust, maybe, bool, max, min, abs)
|
|
import Data.Universe
|
|
import qualified Data.Set as Set
|
|
import qualified Data.List as List
|
|
import qualified Data.Foldable as F
|
|
import Data.List.NonEmpty (NonEmpty(..))
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
import qualified Database.Esqueleto.Experimental as Ex
|
|
import qualified Database.Esqueleto.PostgreSQL as E
|
|
import qualified Database.Esqueleto.Internal.Internal as E
|
|
import Database.Esqueleto.Utils.TH
|
|
|
|
import qualified Data.Text as Text
|
|
import qualified Data.Text.Lazy as Lazy (Text)
|
|
import qualified Data.ByteString.Lazy as Lazy (ByteString)
|
|
|
|
import Crypto.Hash (Digest, SHA256)
|
|
|
|
import Data.Coerce (Coercible)
|
|
|
|
import Data.Time.Clock (NominalDiffTime)
|
|
import Data.Time.Calendar (CalendarDiffDays)
|
|
import Data.Time.Format.ISO8601 (iso8601Show)
|
|
|
|
import qualified Data.Text.Lazy.Builder as Text.Builder
|
|
|
|
import Data.Monoid (Last(..))
|
|
|
|
import Utils (commaSeparatedText)
|
|
-- import Utils.Set (concatMapSet)
|
|
|
|
|
|
{-# ANN any ("HLint: ignore Use any" :: String) #-}
|
|
{-# ANN all ("HLint: ignore Use all" :: String) #-}
|
|
|
|
|
|
{-# ANN any ("HLint: ignore Use any" :: String) #-}
|
|
{-# ANN all ("HLint: ignore Use all" :: String) #-}
|
|
|
|
|
|
--
|
|
-- Description : Convenience for using `Esqueleto`,
|
|
-- intended to be imported qualified
|
|
-- just like @Esqueleto@
|
|
|
|
|
|
-- ezero = E.val (0 :: Int64)
|
|
|
|
-- | Often needed with this concrete type
|
|
true :: E.SqlExpr (E.Value Bool)
|
|
true = E.val True
|
|
|
|
-- | Often needed with this concrete type
|
|
false :: E.SqlExpr (E.Value Bool)
|
|
false = E.val False
|
|
|
|
-- Timestamp larger than any other; not sure if this is a good idea to use
|
|
-- infinity :: E.SqlExpr (E.Value UTCTime)
|
|
-- infinity = unsafeSqlValue "'infinity'"
|
|
|
|
vals :: (MonoFoldable mono, PersistField (Element mono)) => mono -> E.SqlExpr (E.ValueList (Element mono))
|
|
vals = E.valList . toList
|
|
|
|
justVal :: PersistField typ => typ -> E.SqlExpr (E.Value (Maybe typ))
|
|
-- justVal = E.val . Just
|
|
justVal = E.just . E.val
|
|
|
|
justValList :: PersistField typ => [typ] -> E.SqlExpr (E.ValueList (Maybe typ))
|
|
-- justValList = E.valList . map Just
|
|
justValList = E.justList . E.valList
|
|
|
|
toValues :: PersistField typ => NonEmpty typ -> Ex.From (Ex.SqlExpr (Ex.Value typ)) -- E.From invalid here, requires Esqueleto.Experimental
|
|
toValues = E.values . fmap Ex.val
|
|
|
|
infixl 4 =?.
|
|
(=?.) :: PersistField typ => E.SqlExpr (E.Value typ) -> E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool)
|
|
(=?.) = (E.==.) . E.just
|
|
|
|
infixl 4 ?=.
|
|
(?=.) :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value typ) -> E.SqlExpr (E.Value Bool)
|
|
(?=.) a b = a E.==. E.just b
|
|
|
|
-- | like (=?.) but also succeeds if the right-hand side is NULL. Can often be avoided by moving from where- to join-condition!
|
|
infixl 4 =~.
|
|
(=~.) :: PersistField typ => E.SqlExpr (E.Value typ) -> E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool)
|
|
(=~.) a b = E.isNothing b E.||. (E.just a E.==. b)
|
|
|
|
infixl 4 ~=.
|
|
(~=.) :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value typ) -> E.SqlExpr (E.Value Bool)
|
|
(~=.) a b = E.isNothing a E.||. (a E.==. E.just b)
|
|
|
|
-- | like (>.), but also succeeds if the right-hand side is NULL
|
|
infixl 4 >~.
|
|
(>~.) :: PersistField typ => E.SqlExpr (E.Value typ) -> E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool)
|
|
(>~.) a b = E.isNothing b E.||. (E.just a E.>. b)
|
|
|
|
-- | like (<.), but also succeeds if the right-hand side is NULL
|
|
infixl 4 <~.
|
|
(<~.) :: PersistField typ => E.SqlExpr (E.Value typ) -> E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool)
|
|
(<~.) a b = E.isNothing b E.||. (E.just a E.<. b)
|
|
|
|
|
|
-- | Negation of `isNothing` which is missing
|
|
isJust :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool)
|
|
isJust = E.not_ . E.isNothing
|
|
|
|
-- | Deprecated, use coalesce directly
|
|
alt :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value (Maybe typ))
|
|
-- alt a b = E.case_ [(isJust a, a), (isJust b, b)] b
|
|
alt a b = E.coalesce [a,b]
|
|
|
|
infix 4 `isInfixOf`, `hasInfix`, `isPrefixOf_`, `hasPrefix_`
|
|
|
|
-- | Check if the first string is contained in the text derived from the second argument (case-insensitive)
|
|
isInfixOf :: ( E.SqlString s1
|
|
, E.SqlString s2
|
|
)
|
|
=> E.SqlExpr (E.Value s1) -> E.SqlExpr (E.Value s2) -> E.SqlExpr (E.Value Bool)
|
|
isInfixOf needle strExpr = E.castString strExpr `E.ilike` (E.%) E.++. needle E.++. (E.%)
|
|
|
|
hasInfix :: ( E.SqlString s1
|
|
, E.SqlString s2
|
|
)
|
|
=> E.SqlExpr (E.Value s2) -> E.SqlExpr (E.Value s1) -> E.SqlExpr (E.Value Bool)
|
|
hasInfix = flip isInfixOf
|
|
|
|
-- | Check if the first string is a prefix of the text derived from the second argument (case-insensitive)
|
|
isPrefixOf_ :: ( E.SqlString s1
|
|
, E.SqlString s2
|
|
)
|
|
=> E.SqlExpr (E.Value s1) -> E.SqlExpr (E.Value s2) -> E.SqlExpr (E.Value Bool)
|
|
isPrefixOf_ needle strExpr = E.castString strExpr `E.ilike` needle E.++. (E.%)
|
|
|
|
hasPrefix_ :: ( E.SqlString s1
|
|
, E.SqlString s2
|
|
)
|
|
=> E.SqlExpr (E.Value s2) -> E.SqlExpr (E.Value s1) -> E.SqlExpr (E.Value Bool)
|
|
hasPrefix_ = flip isPrefixOf_
|
|
|
|
|
|
infixl 6 `strConcat`
|
|
|
|
strConcat :: E.SqlString s
|
|
=> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s)
|
|
strConcat = E.unsafeSqlBinOp " || "
|
|
|
|
substring :: ( E.SqlString str
|
|
, Num from, Num for
|
|
)
|
|
=> E.SqlExpr (E.Value str)
|
|
-> E.SqlExpr (E.Value from)
|
|
-> E.SqlExpr (E.Value for)
|
|
-> E.SqlExpr (E.Value str)
|
|
substring (E.ERaw _m1 f1) (E.ERaw _m2 f2) (E.ERaw _m3 f3)
|
|
= E.ERaw E.noMeta $ \_nParens info ->
|
|
let (strTLB, strVals) = f1 E.Parens info
|
|
(fromiTLB, fromiVals) = f2 E.Parens info
|
|
(foriTLB, foriVals) = f3 E.Parens info
|
|
in ( "SUBSTRING" <> E.parens (E.parens strTLB <> " FROM " <> E.parens fromiTLB <> " FOR " <> E.parens foriTLB)
|
|
, strVals <> fromiVals <> foriVals
|
|
)
|
|
|
|
explicitUnsafeCoerceSqlExprValue :: forall b a.
|
|
Text
|
|
-> E.SqlExpr (E.Value a)
|
|
-> E.SqlExpr (E.Value b)
|
|
explicitUnsafeCoerceSqlExprValue typ (E.ERaw _m1 f1) = E.ERaw E.noMeta $ \_nParens info ->
|
|
let (valTLB, valVals) = f1 E.Parens info
|
|
in ( E.parens valTLB <> " :: " <> Text.Builder.fromText typ
|
|
, valVals
|
|
)
|
|
|
|
and, or :: Foldable f => f (E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool)
|
|
-- and = F.foldl' (E.&&.) true -- we can use foldl' since PostgreSQL reorders conditions anyway
|
|
-- or = F.foldl' (E.||.) false
|
|
-- Maybe this help the PostgreSQL query optimizer, though I doubt it?
|
|
and f | F.null f = true
|
|
| otherwise = F.foldl1 (E.&&.) f
|
|
or f | F.null f = false
|
|
| otherwise = F.foldl1 (E.||.) f
|
|
|
|
-- | Given a test and a set of values, check whether anyone succeeds the test
|
|
-- WARNING: SQL leaves it explicitely unspecified whether `||` is short curcuited (i.e. lazily evaluated)
|
|
any :: MonoFoldable f => (Element f -> E.SqlExpr (E.Value Bool)) -> f -> E.SqlExpr (E.Value Bool)
|
|
any test = or . map test . otoList
|
|
|
|
-- | Given a test and a set of values, check whether all succeeds the test
|
|
-- WARNING: SQL leaves it explicitely unspecified whether `&&` is short curcuited (i.e. lazily evaluated)
|
|
all :: MonoFoldable f => (Element f -> E.SqlExpr (E.Value Bool)) -> f -> E.SqlExpr (E.Value Bool)
|
|
all test = and . map test . otoList
|
|
|
|
subSelectAnd, subSelectOr :: E.SqlQuery (E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool)
|
|
subSelectAnd q = parens . E.subSelectUnsafe $ flip (E.unsafeSqlAggregateFunction "bool_and" E.AggModeAll) [] <$> q
|
|
subSelectOr q = parens . E.subSelectUnsafe $ flip (E.unsafeSqlAggregateFunction "bool_or" E.AggModeAll) [] <$> q
|
|
|
|
parens :: E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a)
|
|
parens = E.unsafeSqlFunction ""
|
|
|
|
|
|
-- Allow usage of Tuples as DbtRowKey, i.e. SqlIn instances for tuples
|
|
$(sqlInTuples [2..16])
|
|
|
|
-- | Example for usage of unValueN
|
|
_exampleUnValueN :: (E.Value a, E.Value b, E.Value c) -> (a,b,c)
|
|
_exampleUnValueN = $(unValueN 3)
|
|
|
|
-- | Example for usage of unValueNIs
|
|
_exampleUnValueNIs :: (E.Value a, b, E.Value c) -> (a,b,c)
|
|
_exampleUnValueNIs = $(unValueNIs 3 [1,3])
|
|
|
|
-- | Example for usage of sqlIJproj
|
|
_queryFeaturesDegree :: (a `E.InnerJoin` b `E.InnerJoin` c) -> b
|
|
_queryFeaturesDegree = $(sqlIJproj 3 2)
|
|
|
|
|
|
-- | generic filter creation for dbTable
|
|
-- Given a lens-like function, make filter for exact matches in a collection
|
|
-- (Generalizing from Set to Foldable ok here, but gives ambigouus types elsewhere)
|
|
mkExactFilter :: (PersistField a)
|
|
=> (t -> E.SqlExpr (E.Value a)) -- ^ getter from query to searched element
|
|
-> t -- ^ query row
|
|
-> Set.Set a -- ^ needle collection
|
|
-> E.SqlExpr (E.Value Bool)
|
|
mkExactFilter = mkExactFilterWith id
|
|
|
|
-- | like `mkExactFilter` but allows for conversion; convenient in conjunction with `anyFilter` and `allFilter`
|
|
mkExactFilterWith :: (PersistField b)
|
|
=> (a -> b) -- ^ type conversion
|
|
-> (t -> E.SqlExpr (E.Value b)) -- ^ getter from query to searched element
|
|
-> t -- ^ query row
|
|
-> Set.Set a -- ^ needle collection
|
|
-> E.SqlExpr (E.Value Bool)
|
|
mkExactFilterWith cast lenslike row criterias
|
|
| Set.null criterias = true
|
|
| otherwise = lenslike row `E.in_` E.valList (cast <$> Set.toList criterias)
|
|
|
|
-- | like `mkExactFilterWith` but splits comma separared Texts into multiple criteria
|
|
mkExactFilterWithComma :: (PersistField b)
|
|
=> (Text -> Maybe b) -- ^ type conversion
|
|
-> (t -> E.SqlExpr (E.Value b)) -- ^ getter from query to searched element
|
|
-> t -- ^ query row
|
|
-> Set.Set Text -- ^ needle collection
|
|
-> E.SqlExpr (E.Value Bool)
|
|
mkExactFilterWithComma cast lenslike row (foldMap commaSeparatedText -> criterias)
|
|
| Set.null criterias = true
|
|
| otherwise = lenslike row `E.in_` E.valList (mapMaybe cast $ Set.toList criterias)
|
|
|
|
-- | generic filter creation for dbTable
|
|
-- Given a lens-like function, make filter for exact matches against last element of a collection
|
|
mkExactFilterLast :: (PersistField a)
|
|
=> (t -> E.SqlExpr (E.Value a)) -- ^ getter from query to searched element
|
|
-> t -- ^ query row
|
|
-> Last a -- ^ needle
|
|
-> E.SqlExpr (E.Value Bool)
|
|
mkExactFilterLast = mkExactFilterLastWith id
|
|
|
|
-- | like `mkExactFilterLast` but allows for conversion; convenient in conjunction with `anyFilter` and `allFilter`
|
|
mkExactFilterLastWith :: (PersistField b)
|
|
=> (a -> b) -- ^ type conversion
|
|
-> (t -> E.SqlExpr (E.Value b)) -- ^ getter from query to searched element
|
|
-> t -- ^ query row
|
|
-> Last a -- ^ needle
|
|
-> E.SqlExpr (E.Value Bool)
|
|
mkExactFilterLastWith cast lenslike row criterias
|
|
| Last (Just crit) <- criterias = lenslike row E.==. E.val (cast crit)
|
|
| otherwise = true
|
|
|
|
-- | like `mkExactFilterLast` but deals with Nothing being a filter criterion as well
|
|
mkExactFilterMaybeLast :: PersistField a
|
|
=> (t -> E.SqlExpr (E.Value (Maybe a))) -- ^ getter from query to searched element
|
|
-> t -- ^ query row
|
|
-> Last (Maybe a) -- ^ needle
|
|
-> E.SqlExpr (E.Value Bool)
|
|
mkExactFilterMaybeLast lenslike row criterias
|
|
| Last (Just Nothing) <- criterias = E.isNothing $ lenslike row
|
|
| Last (Just crit) <- criterias = lenslike row E.==. E.val crit
|
|
| otherwise = true
|
|
|
|
-- | like `mkExactFilterMaybeLast` but for doubly wrapped Maybes
|
|
mkExactFilterMaybeLast' :: (PersistField a, PersistField b)
|
|
=> (t -> E.SqlExpr (E.Value (Maybe b))) -- ^ getter from query ensure entity exists at all
|
|
-> (t -> E.SqlExpr (E.Value (Maybe (Maybe a)))) -- ^ getter from query to searched element
|
|
-> t -- ^ query row
|
|
-> Last (Maybe a) -- ^ needle
|
|
-> E.SqlExpr (E.Value Bool)
|
|
mkExactFilterMaybeLast' lensexists lenslike row criterias
|
|
| Last (Just Nothing) <- criterias = isJust (lensexists row) E.&&. E.isNothing (E.joinV $ lenslike row)
|
|
| Last (Just crit) <- criterias = lenslike row E.==. E.val (Just crit)
|
|
| otherwise = true
|
|
|
|
-- | generic filter creation for dbTable
|
|
-- Given a lens-like function, make filter searching for needles in String-like elements
|
|
-- (Keep Set here to ensure that there are no duplicates)
|
|
mkContainsFilter :: E.SqlString a
|
|
=> (t -> E.SqlExpr (E.Value a)) -- ^ getter from query to searched element
|
|
-> t -- ^ query row
|
|
-> Set.Set a -- ^ needle collection
|
|
-> E.SqlExpr (E.Value Bool)
|
|
mkContainsFilter = mkContainsFilterWith id
|
|
|
|
-- | like `mkContainsFilter` but allows for conversion; convenient in conjunction with `anyFilter` and `allFilter`
|
|
mkContainsFilterWith :: E.SqlString b
|
|
=> (a -> b)
|
|
-> (t -> E.SqlExpr (E.Value b)) -- ^ getter from query to searched element
|
|
-> t -- ^ query row
|
|
-> Set.Set a -- ^ needle collection
|
|
-> E.SqlExpr (E.Value Bool)
|
|
mkContainsFilterWith cast lenslike row criterias
|
|
| Set.null criterias = true
|
|
| otherwise = any (hasInfix $ lenslike row) (E.val . cast <$> Set.toList criterias)
|
|
|
|
-- | like `mkContainsFilterWith` but allows conversion to produce multiple needles
|
|
mkContainsFilterWithSet :: (E.SqlString b, Ord b, Ord a)
|
|
=> (a -> Set.Set b)
|
|
-> (t -> E.SqlExpr (E.Value b)) -- ^ getter from query to searched element
|
|
-> t -- ^ query row
|
|
-> Set.Set a -- ^ needle collection
|
|
-> E.SqlExpr (E.Value Bool)
|
|
mkContainsFilterWithSet cast lenslike row criterias
|
|
| Set.null criterias = true
|
|
| otherwise = any (hasInfix $ lenslike row) (E.val <$> Set.toList (foldMap cast criterias))
|
|
|
|
-- | like `mkContainsFilterWithSet` but fixed to comma separated Texts
|
|
mkContainsFilterWithComma :: (E.SqlString b, Ord b)
|
|
=> (Text -> b)
|
|
-> (t -> E.SqlExpr (E.Value b)) -- ^ getter from query to searched element
|
|
-> t -- ^ query row
|
|
-> Set.Set Text -- ^ needle collection
|
|
-> E.SqlExpr (E.Value Bool)
|
|
mkContainsFilterWithComma cast lenslike row (foldMap commaSeparatedText -> criterias)
|
|
| Set.null criterias = true
|
|
| otherwise = any (hasInfix $ lenslike row) (E.val . cast <$> Set.toList criterias)
|
|
|
|
-- | like `mkContainsFilterWithComma` but enforced the existence of all Texts prefixed with +
|
|
mkContainsFilterWithCommaPlus :: (E.SqlString b, Ord b)
|
|
=> (Text -> b)
|
|
-> (t -> E.SqlExpr (E.Value b)) -- ^ getter from query to searched element
|
|
-> t -- ^ query row
|
|
-> Set.Set Text -- ^ needle collection
|
|
-> E.SqlExpr (E.Value Bool)
|
|
mkContainsFilterWithCommaPlus cast lenslike row (foldMap commaSeparatedText -> criterias)
|
|
| Set.null criterias = true
|
|
| Set.null compulsories = cond_optional
|
|
| Set.null alternatives = cond_compulsory
|
|
| otherwise = cond_compulsory E.&&. cond_optional
|
|
where
|
|
(Set.mapMonotonic (Text.stripStart . Text.drop 1) -> compulsories, alternatives) = Set.partition (Text.isPrefixOf "+") criterias
|
|
cond_compulsory = all (hasInfix $ lenslike row) (E.val . cast <$> Set.toList compulsories)
|
|
cond_optional = any (hasInfix $ lenslike row) (E.val . cast <$> Set.toList alternatives)
|
|
|
|
mkDayFilter :: (t -> E.SqlExpr (E.Value UTCTime)) -- ^ getter from query to searched element
|
|
-> t -- ^ query row
|
|
-> Last Day -- ^ a day to filter for
|
|
-> E.SqlExpr (E.Value Bool)
|
|
mkDayFilter lenslike row criterias
|
|
| Last (Just crit) <- criterias = day (lenslike row) E.==. E.val crit
|
|
| otherwise = true
|
|
|
|
|
|
mkDayFilterFrom :: (t -> E.SqlExpr (E.Value UTCTime)) -- ^ getter from query to searched element
|
|
-> t -- ^ query row
|
|
-> Last Day -- ^ a day range to filter for
|
|
-> E.SqlExpr (E.Value Bool)
|
|
mkDayFilterFrom lenslike row criterias
|
|
| Last (Just crit) <- criterias = day (lenslike row) E.>=. E.val crit
|
|
| otherwise = true
|
|
|
|
mkDayFilterTo :: (t -> E.SqlExpr (E.Value UTCTime)) -- ^ getter from query to searched element
|
|
-> t -- ^ query row
|
|
-> Last Day -- ^ a day range to filter for
|
|
-> E.SqlExpr (E.Value Bool)
|
|
mkDayFilterTo lenslike row criterias
|
|
| Last (Just crit) <- criterias = day (lenslike row) E.<=. E.val crit
|
|
| otherwise = true
|
|
|
|
|
|
mkExistsFilter :: PathPiece a
|
|
=> (t -> a -> E.SqlQuery ())
|
|
-> t
|
|
-> Set.Set a
|
|
-> E.SqlExpr (E.Value Bool)
|
|
mkExistsFilter query row criterias
|
|
| Set.null criterias = true
|
|
| otherwise = any (E.exists . query row) $ Set.toList criterias
|
|
|
|
mkExistsFilterWithComma :: PathPiece a
|
|
=> (Text -> a)
|
|
-> (t -> a -> E.SqlQuery ())
|
|
-> t
|
|
-> Set.Set Text
|
|
-> E.SqlExpr (E.Value Bool)
|
|
mkExistsFilterWithComma cast query row (foldMap commaSeparatedText -> criterias)
|
|
| Set.null criterias = true
|
|
| otherwise = any (E.exists . query row) (cast <$> Set.toList criterias)
|
|
|
|
|
|
-- | Combine several filters, using logical or
|
|
anyFilter :: Foldable f
|
|
=> f (t -> cs -> E.SqlExpr (E.Value Bool))
|
|
-> (t -> cs -> E.SqlExpr (E.Value Bool))
|
|
anyFilter fltrs needle criterias = F.foldr aux false fltrs
|
|
where
|
|
aux fltr acc = fltr needle criterias E.||. acc
|
|
|
|
-- | Combine several filters, using logical and
|
|
allFilter :: Foldable f
|
|
=> f (t -> cs -> E.SqlExpr (E.Value Bool))
|
|
-> (t -> cs -> E.SqlExpr (E.Value Bool))
|
|
allFilter fltrs needle criterias = F.foldr aux true fltrs
|
|
where
|
|
aux fltr acc = fltr needle criterias E.&&. acc
|
|
|
|
-- | Descending order of this field or SqlExpression, but with NULLS at the end.
|
|
ascNullsFirst :: PersistField a => E.SqlExpr (E.Value a) -> E.SqlExpr E.OrderBy
|
|
ascNullsFirst = E.orderByExpr " ASC NULLS FIRST"
|
|
|
|
descNullsLast :: PersistField a => E.SqlExpr (E.Value a) -> E.SqlExpr E.OrderBy
|
|
descNullsLast = E.orderByExpr " DESC NULLS LAST"
|
|
|
|
|
|
orderByList :: PersistField a => [a] -> E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Int)
|
|
orderByList valus
|
|
= let sortUni = zip [1..] valus -- memoize this, might not work due to polymorphism
|
|
in \x -> E.case_ [ (x E.==. E.val u, E.val i) | (i,u) <- sortUni ] (E.val . succ $ List.length valus)
|
|
|
|
orderByOrd :: (Ord a, Finite a, PersistField a) => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Int)
|
|
orderByOrd = orderByList $ List.sort universeF
|
|
|
|
orderByEnum :: (Enum a, Finite a, PersistField a) => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Int)
|
|
orderByEnum = orderByList $ List.sortOn fromEnum universeF
|
|
|
|
lower :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s)
|
|
lower = E.unsafeSqlFunction "LOWER"
|
|
|
|
strip :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s)
|
|
strip = E.unsafeSqlFunction "TRIM"
|
|
|
|
infix 4 `ciEq`
|
|
|
|
ciEq :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool)
|
|
ciEq a b = lower a E.==. lower b
|
|
|
|
|
|
selectExists, selectNotExists :: forall m a. MonadIO m => E.SqlQuery a -> E.SqlReadT m Bool
|
|
selectExists query = do
|
|
res <- E.select . return . E.exists $ void query
|
|
|
|
case res of
|
|
[E.Value b] -> return b
|
|
_other -> error "SELECT EXISTS ... returned zero or more than one rows"
|
|
selectNotExists = fmap not . selectExists
|
|
|
|
|
|
class SqlHashable a
|
|
instance SqlHashable Text
|
|
instance SqlHashable ByteString
|
|
instance SqlHashable Lazy.Text
|
|
instance SqlHashable Lazy.ByteString
|
|
|
|
|
|
sha256 :: SqlHashable a => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value (Digest SHA256))
|
|
sha256 = E.unsafeSqlFunction "digest" . (, E.val "sha256" :: E.SqlExpr (E.Value Text))
|
|
|
|
|
|
isTrue :: E.SqlExpr (E.Value (Maybe Bool)) -> E.SqlExpr (E.Value Bool)
|
|
isTrue expr = E.unsafeSqlBinOp "IS TRUE" expr $ E.unsafeSqlValue ""
|
|
|
|
isFalse :: E.SqlExpr (E.Value (Maybe Bool)) -> E.SqlExpr (E.Value Bool)
|
|
isFalse expr = E.unsafeSqlBinOp "IS FALSE" expr $ E.unsafeSqlValue ""
|
|
|
|
maybe :: (PersistField a, PersistField b)
|
|
=> E.SqlExpr (E.Value b)
|
|
-> (E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value b))
|
|
-> E.SqlExpr (E.Value (Maybe a))
|
|
-> E.SqlExpr (E.Value b)
|
|
maybe onNothing onJust val = E.case_
|
|
[ E.when_
|
|
(E.not_ $ E.isNothing val)
|
|
E.then_
|
|
(onJust $ E.veryUnsafeCoerceSqlExprValue val)
|
|
]
|
|
(E.else_ onNothing)
|
|
|
|
maybe2 :: (PersistField a, PersistField b, PersistField c)
|
|
=> E.SqlExpr (E.Value c)
|
|
-> (E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value b) -> E.SqlExpr (E.Value c))
|
|
-> E.SqlExpr (E.Value (Maybe a))
|
|
-> E.SqlExpr (E.Value (Maybe b))
|
|
-> E.SqlExpr (E.Value c)
|
|
maybe2 onNothing onJust val1 val2 = E.case_
|
|
[ E.when_
|
|
(isJust val1 E.&&. isJust val2)
|
|
E.then_
|
|
(onJust (E.veryUnsafeCoerceSqlExprValue val1) (E.veryUnsafeCoerceSqlExprValue val2))
|
|
]
|
|
(E.else_ onNothing)
|
|
|
|
infix 4 `maybeEq`
|
|
|
|
maybeEq :: PersistField a
|
|
=> E.SqlExpr (E.Value (Maybe a))
|
|
-> E.SqlExpr (E.Value (Maybe a))
|
|
-> E.SqlExpr (E.Value Bool)
|
|
-- ^ `E.==.` but treat `E.nothing` as identical
|
|
maybeEq a b = E.case_
|
|
[ E.when_
|
|
(E.isNothing a)
|
|
E.then_
|
|
(E.isNothing b)
|
|
, E.when_
|
|
(E.isNothing b)
|
|
E.then_
|
|
false -- (E.isNothing a)
|
|
]
|
|
(E.else_ $ a E.==. b)
|
|
|
|
guardMaybe :: PersistField a
|
|
=> E.SqlExpr (E.Value (Maybe a))
|
|
-> E.SqlQuery (E.SqlExpr (E.Value a))
|
|
guardMaybe mVal = do
|
|
E.where_ $ isJust mVal
|
|
return $ E.veryUnsafeCoerceSqlExprValue mVal
|
|
|
|
bool :: PersistField a
|
|
=> E.SqlExpr (E.Value a)
|
|
-> E.SqlExpr (E.Value a)
|
|
-> E.SqlExpr (E.Value Bool)
|
|
-> E.SqlExpr (E.Value a)
|
|
bool onFalse onTrue val = E.case_
|
|
[ E.when_
|
|
val
|
|
E.then_
|
|
onTrue
|
|
]
|
|
(E.else_ onFalse)
|
|
|
|
-- called see greatest and least within postgresql
|
|
-- TODO: this is buggy! Both return always the first argument if any argument is NULL!
|
|
max, min :: PersistField a
|
|
=> E.SqlExpr (E.Value a)
|
|
-> E.SqlExpr (E.Value a)
|
|
-> E.SqlExpr (E.Value a)
|
|
max a b = bool a b $ b E.>. a
|
|
min a b = bool a b $ b E.<. a
|
|
|
|
-- these alternatives for max/min ought to be more efficient; note that NULL is avoided by PostgreSQL greatest/least
|
|
greatest :: PersistField a => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a)
|
|
greatest a b = E.unsafeSqlFunction "GREATEST" $ E.toArgList (a,b)
|
|
|
|
least :: PersistField a => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a)
|
|
least a b = E.unsafeSqlFunction "LEAST" $ E.toArgList (a,b)
|
|
|
|
abs :: (PersistField a, Num a)
|
|
=> E.SqlExpr (E.Value a)
|
|
-> E.SqlExpr (E.Value a)
|
|
abs x = bool (E.val 0 E.-. x) x $ x E.>. E.val 0
|
|
|
|
unsafeCoalesce :: E.PersistField a => [E.SqlExpr (E.Value (Maybe a))] -> E.SqlExpr (E.Value a)
|
|
unsafeCoalesce = E.veryUnsafeCoerceSqlExprValue . E.coalesce
|
|
|
|
|
|
class (PersistEntity entity, PersistField value, PersistField value') => SqlProject entity value entity' value' | entity value entity' -> value', entity value value' -> entity' where
|
|
sqlProject :: E.SqlExpr entity' -> EntityField entity value -> E.SqlExpr (E.Value value')
|
|
unSqlProject :: forall p1 p2. p1 entity -> p2 entity' -> value -> value'
|
|
unSqlProjectExpr :: forall p1 p2. p1 entity -> p2 entity' -> E.SqlExpr (E.Value value) -> E.SqlExpr (E.Value value')
|
|
|
|
instance (PersistEntity val, PersistField typ) => SqlProject val typ (E.Entity val) typ where
|
|
sqlProject = (E.^.)
|
|
unSqlProject _ _ = id
|
|
unSqlProjectExpr _ _ = id
|
|
|
|
instance (PersistEntity val, PersistField typ) => SqlProject val typ (Maybe (E.Entity val)) (Maybe typ) where
|
|
sqlProject = (E.?.)
|
|
unSqlProject _ _ = Just
|
|
unSqlProjectExpr _ _ = E.just
|
|
|
|
infixl 8 ->.
|
|
|
|
(->.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value b)
|
|
(->.) expr t = E.unsafeSqlBinOp "->" expr $ E.val t
|
|
|
|
|
|
infixl 8 ->>.
|
|
|
|
(->>.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value Text)
|
|
(->>.) expr t = E.unsafeSqlBinOp "->>" expr $ E.val t
|
|
|
|
infixl 8 #>>.
|
|
|
|
(#>>.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value (Maybe Text))
|
|
(#>>.) expr t = E.unsafeSqlBinOp "#>>" expr $ E.val t
|
|
|
|
|
|
fromSqlKey :: (ToBackendKey SqlBackend entity, PersistField (Key entity)) => E.SqlExpr (E.Value (Key entity)) -> E.SqlExpr (E.Value Int64)
|
|
fromSqlKey = E.veryUnsafeCoerceSqlExprValue
|
|
|
|
unKey :: ( Coercible (Key entity) a
|
|
, PersistField (Key entity), PersistField a
|
|
)
|
|
=> E.SqlExpr (E.Value (Key entity)) -> E.SqlExpr (E.Value a)
|
|
unKey = E.veryUnsafeCoerceSqlExprValue
|
|
|
|
-- | distinct version of `Database.Esqueleto.subSelectCount`
|
|
subSelectCountDistinct :: (Num a, PersistField a) => Ex.SqlQuery (Ex.SqlExpr (Ex.Value typ)) -> Ex.SqlExpr (Ex.Value a)
|
|
subSelectCountDistinct query = Ex.subSelectUnsafe (Ex.countDistinct <$> query)
|
|
|
|
-- PersistField a => SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a)
|
|
-- countDistinct :: Num a => SqlExpr (Value typ) -> SqlExpr (Value a)
|
|
|
|
selectCountRows :: (Num a, PersistField a, MonadIO m) => E.SqlQuery ignored -> E.SqlReadT m a
|
|
selectCountRows q = do
|
|
res <- E.select $ E.countRows <$ q
|
|
case res of
|
|
[E.Value res']
|
|
-> return res'
|
|
_other
|
|
-> error "E.countRows did not return exactly one result"
|
|
|
|
selectCountDistinct :: (Num a, PersistField a, MonadIO m) => E.SqlQuery (E.SqlExpr (E.Value typ)) -> E.SqlReadT m a
|
|
selectCountDistinct q = do
|
|
res <- E.select $ E.countDistinct <$> q
|
|
case res of
|
|
[E.Value res']
|
|
-> return res'
|
|
_other
|
|
-> error "E.countDistinct did not return exactly one result"
|
|
|
|
selectMaybe :: (E.SqlSelect a r, MonadIO m) => E.SqlQuery a -> E.SqlReadT m (Maybe r)
|
|
selectMaybe = fmap listToMaybe . E.select . (<* E.limit 1)
|
|
|
|
-- | cast numeric type to text, which is safe and allows for an inefficient but safe comparison of numbers stored as text and numbers
|
|
num2text :: Num n => E.SqlExpr (E.Value n) -> E.SqlExpr (E.Value Text)
|
|
num2text = E.unsafeSqlCastAs "text"
|
|
|
|
day :: E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Day)
|
|
day = E.unsafeSqlCastAs "date"
|
|
|
|
-- | cast text to day, truly unsafe
|
|
day' :: E.SqlExpr (E.Value Text) -> E.SqlExpr (E.Value Day)
|
|
day' = E.unsafeSqlCastAs "date"
|
|
|
|
dayMaybe :: E.SqlExpr (E.Value (Maybe UTCTime)) -> E.SqlExpr (E.Value (Maybe Day))
|
|
dayMaybe = E.unsafeSqlCastAs "date"
|
|
|
|
interval :: CalendarDiffDays -> E.SqlExpr (E.Value Day) -- E.+=. requires both types to be the same, so we use Day
|
|
-- interval _ = E.unsafeSqlCastAs "interval" $ E.unsafeSqlValue "'P2Y'" -- tested working example
|
|
interval = E.unsafeSqlCastAs "interval". E.unsafeSqlValue . wrapSqlString . Text.Builder.fromString . iso8601Show
|
|
where
|
|
singleQuote = Text.Builder.singleton '\''
|
|
wrapSqlString b = singleQuote <> b <> singleQuote
|
|
|
|
|
|
infixl 6 `diffDays`, `diffTimes`
|
|
|
|
diffDays :: E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Int)
|
|
-- ^ PostgreSQL is weird.
|
|
diffDays a b = E.veryUnsafeCoerceSqlExprValue $ a E.-. b
|
|
|
|
diffTimes :: E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value NominalDiffTime)
|
|
diffTimes a b = unsafeExtract "EPOCH" $ a E.-. b
|
|
|
|
unsafeExtract :: String -> E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value b)
|
|
unsafeExtract extr (E.ERaw _mF vF) = E.ERaw E.noMeta $ \_nParens info ->
|
|
let (vTLB, vVals) = vF E.Parens info
|
|
in ( "EXTRACT" <> E.parens (fromString extr <> " FROM " <> E.parens vTLB)
|
|
, vVals
|
|
)
|
|
|
|
|
|
class ExprLift e a | e -> a where
|
|
exprLift :: a -> e
|
|
|
|
instance PersistField a => ExprLift (E.SqlExpr (E.Value a)) a where
|
|
exprLift = E.val
|
|
|
|
instance (PersistField a, PersistField b, Finite a) => ExprLift (E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value b)) (a -> b) where
|
|
exprLift f v = E.case_
|
|
[ E.when_ (v E.==. E.val v') E.then_ (E.val $ f v')
|
|
| v' <- universeF
|
|
]
|
|
(E.else_ $ E.veryUnsafeCoerceSqlExprValue (E.nothing :: E.SqlExpr (E.Value (Maybe ()))))
|
|
|
|
instance (PersistField a1, PersistField a2, PersistField b, Finite a1, Finite a2) => ExprLift (E.SqlExpr (E.Value a1) -> E.SqlExpr (E.Value a2) -> E.SqlExpr (E.Value b)) (a1 -> a2 -> b) where
|
|
exprLift f v1 v2 = E.case_
|
|
[ E.when_ ( v1 E.==. E.val v1'
|
|
E.&&. v2 E.==. E.val v2'
|
|
)
|
|
E.then_ (E.val $ f v1' v2')
|
|
| v1' <- universeF
|
|
, v2' <- universeF
|
|
]
|
|
(E.else_ $ E.else_ $ E.veryUnsafeCoerceSqlExprValue (E.nothing :: E.SqlExpr (E.Value (Maybe ()))))
|
|
|