247 lines
9.0 KiB
Haskell
247 lines
9.0 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module Database.Esqueleto.Utils
|
|
( true, false
|
|
, isJust
|
|
, isInfixOf, hasInfix
|
|
, or, and
|
|
, any, all
|
|
, SqlIn(..)
|
|
, mkExactFilter, mkExactFilterWith
|
|
, mkContainsFilter, mkContainsFilterWith
|
|
, mkExistsFilter
|
|
, anyFilter, allFilter
|
|
, orderByList
|
|
, orderByOrd, orderByEnum
|
|
, lower, ciEq
|
|
, selectExists
|
|
, SqlHashable
|
|
, sha256
|
|
, maybe
|
|
, SqlProject(..)
|
|
) where
|
|
|
|
|
|
import ClassyPrelude.Yesod hiding (isInfixOf, any, all, or, and, isJust, maybe)
|
|
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.Internal.Sql 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
|
|
|
|
-- | Negation of `isNothing` which is missing
|
|
isJust :: (E.Esqueleto query expr backend, PersistField typ) => expr (E.Value (Maybe typ)) -> expr (E.Value Bool)
|
|
isJust = E.not_ . E.isNothing
|
|
|
|
infix 4 `isInfixOf`, `hasInfix`
|
|
|
|
-- | Check if the first string is contained in the text derived from the second argument
|
|
isInfixOf :: ( E.Esqueleto query expr backend
|
|
, E.SqlString s1
|
|
, E.SqlString s2
|
|
)
|
|
=> expr (E.Value s1) -> expr (E.Value s2) -> expr (E.Value Bool)
|
|
isInfixOf needle strExpr = E.castString strExpr `E.ilike` (E.%) E.++. needle E.++. (E.%)
|
|
|
|
hasInfix :: ( E.Esqueleto query expr backend
|
|
, E.SqlString s1
|
|
, E.SqlString s2
|
|
)
|
|
=> expr (E.Value s2) -> expr (E.Value s1) -> expr (E.Value Bool)
|
|
hasInfix = flip isInfixOf
|
|
|
|
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
|
|
|
|
|
|
-- 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"
|
|
|
|
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 :: 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"
|
|
|
|
|
|
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)
|
|
|
|
|
|
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
|