441 lines
16 KiB
Haskell
441 lines
16 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
|
|
|
module Database.Esqueleto.Utils
|
|
( true, false
|
|
, justVal, justValList
|
|
, isJust, alt
|
|
, isInfixOf, hasInfix
|
|
, strConcat, substring
|
|
, or, and
|
|
, any, all
|
|
, subSelectAnd, subSelectOr
|
|
, mkExactFilter, mkExactFilterWith
|
|
, mkContainsFilter, mkContainsFilterWith
|
|
, mkExistsFilter
|
|
, anyFilter, allFilter
|
|
, orderByList
|
|
, orderByOrd, orderByEnum
|
|
, strip, lower, ciEq
|
|
, selectExists, selectNotExists
|
|
, SqlHashable
|
|
, sha256
|
|
, maybe, maybe2, maybeEq, unsafeCoalesce
|
|
, bool
|
|
, max, min
|
|
, abs
|
|
, SqlProject(..)
|
|
, (->.), (#>>.)
|
|
, fromSqlKey
|
|
, selectCountRows
|
|
, selectMaybe
|
|
, day, diffDays
|
|
, exprLift
|
|
, 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 qualified Database.Esqueleto as E
|
|
import qualified Database.Esqueleto.PostgreSQL as E
|
|
import qualified Database.Esqueleto.Internal.Internal as E
|
|
import Database.Esqueleto.Utils.TH
|
|
|
|
import qualified Data.Text.Lazy as Lazy (Text)
|
|
import qualified Data.ByteString.Lazy as Lazy (ByteString)
|
|
|
|
import Crypto.Hash (Digest, SHA256)
|
|
|
|
{-# 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
|
|
|
|
justVal :: PersistField typ => typ -> E.SqlExpr (E.Value (Maybe typ))
|
|
justVal = E.val . Just
|
|
|
|
justValList :: PersistField typ => [typ] -> E.SqlExpr (E.ValueList (Maybe typ))
|
|
justValList = E.valList . map Just
|
|
|
|
-- | 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
|
|
|
|
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
|
|
|
|
infix 4 `isInfixOf`, `hasInfix`
|
|
|
|
-- | Check if the first string is contained in the text derived from the second argument
|
|
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
|
|
|
|
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 p1 f1) (E.ERaw p2 f2) (E.ERaw p3 f3)
|
|
= E.ERaw E.Never $ \info ->
|
|
let (strTLB, strVals) = f1 info
|
|
(fromiTLB, fromiVals) = f2 info
|
|
(foriTLB, foriVals) = f3 info
|
|
in ( "SUBSTRING" <> E.parens (E.parensM p1 strTLB <> " FROM " <> E.parensM p2 fromiTLB <> " FOR " <> E.parensM p3 foriTLB)
|
|
, strVals <> fromiVals <> foriVals
|
|
)
|
|
substring a b c = substring (construct a) (construct b) (construct c)
|
|
where construct :: E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a)
|
|
construct (E.ERaw p f) = E.ERaw E.Parens $ \info ->
|
|
let (b1, vals) = f info
|
|
build ("?", [E.PersistList vals']) =
|
|
(E.uncommas $ replicate (length vals') "?", vals')
|
|
build expr = expr
|
|
in build (E.parensM p b1, vals)
|
|
construct (E.ECompositeKey f) =
|
|
E.ERaw E.Parens $ \info -> (E.uncommas $ f info, mempty)
|
|
construct (E.EAliasedValue i _) =
|
|
E.ERaw E.Never $ E.aliasedValueIdentToRawSql i
|
|
construct (E.EValueReference i i') =
|
|
E.ERaw E.Never $ E.valueReferenceToRawSql i i'
|
|
|
|
and, or :: Foldable f => f (E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool)
|
|
and = F.foldr (E.&&.) true
|
|
or = F.foldr (E.||.) false
|
|
|
|
-- | 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 `mkExactFiler` 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)
|
|
|
|
-- | 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 `mkContainsFiler` 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)
|
|
|
|
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
|
|
|
|
-- | 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
|
|
|
|
|
|
orderByList :: PersistField a => [a] -> E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Int)
|
|
orderByList vals
|
|
= let sortUni = zip [1..] vals -- 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 vals)
|
|
|
|
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))
|
|
|
|
|
|
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)
|
|
|
|
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)
|
|
|
|
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
|
|
|
|
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) => 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'
|
|
|
|
instance (PersistEntity val, PersistField typ) => SqlProject val typ (E.Entity val) typ where
|
|
sqlProject = (E.^.)
|
|
unSqlProject _ _ = id
|
|
|
|
instance (PersistEntity val, PersistField typ) => SqlProject val typ (Maybe (E.Entity val)) (Maybe typ) where
|
|
sqlProject = (E.?.)
|
|
unSqlProject _ _ = 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 (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
|
|
|
|
|
|
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"
|
|
|
|
selectMaybe :: (E.SqlSelect a r, MonadIO m) => E.SqlQuery a -> E.SqlReadT m (Maybe r)
|
|
selectMaybe = fmap listToMaybe . E.select . (<* E.limit 1)
|
|
|
|
|
|
day :: E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Day)
|
|
day = E.unsafeSqlCastAs "date"
|
|
|
|
infixl 6 `diffDays`
|
|
|
|
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
|
|
|
|
|
|
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 ()))))
|
|
|