-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Steffen Jost ,Steffen Jost -- -- 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 , not__, parens , 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 "" -- | Workaround for Esqueleto-Bug not placing parenthesis after NOT, see #155 not__ :: E.SqlExpr (E.Value Bool) -> E.SqlExpr (E.Value Bool) not__ = E.not_ . parens -- 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, Ord 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, Ord a) => (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) 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) (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) 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) compulsories cond_optional = any (hasInfix (lenslike row) . E.val . cast) 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) 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 ()))))