{- | Implements filtering with beam-postgres.

When setting filtering for an endpoint, you usually need to construct a filtering spec
application first, which describes how to perform filtering over your rows:

@
filteringSpecApp
    :: FilteringSpecApp
        (QExprFilterBackend syntax s)
        [ "course" ?: 'AutoFilter Course
        , "desc" ?: 'AutoFilter Text
        , "isAwesome" ?: 'ManualFilter Bool
        ]
filteringSpecApp =
    filterOn_ @"course" courseField .*.
    filterOn_ @"desc" descField .*.
    customFilter_ @"isAwesome"
        (\isAwesome -> (courseAwesomeness >. val_ 42) ==. val_ isAwesome) .*.
    HNil
@

Annotating 'filterOn' and 'customFilter' calls with parameter name is fully optional
and used only to visually disambiguate filters of the same types.

Next, you use 'matches_' or 'filterGuard_' to build a filtering expression understandable
by Beam.
-}
module Servant.Util.Beam.Postgres.Filtering
    ( matches_
    , filtersGuard_
    , filterOn
    , manualFilter

      -- * Internals
    , likeToSqlPattern
    ) where

import Universum

import Database.Beam.Backend.SQL (BeamSqlBackend, BeamSqlBackendIsString, BeamSqlBackendSyntax,
                                  HasSqlValueSyntax, Sql92ExpressionValueSyntax,
                                  Sql92SelectSelectTableSyntax, Sql92SelectTableExpressionSyntax)
import Database.Beam.Backend.SQL.SQL92 (Sql92SelectSyntax)
import Database.Beam.Query (HasSqlEqualityCheck, Q, guard_, in_, like_, val_, (&&.), (/=.), (<.),
                            (<=.), (==.), (>.), (>=.))
import Database.Beam.Query.Internal (QExpr)

import Servant.Util.Combinators.Filtering.Backend
import Servant.Util.Combinators.Filtering.Base
import Servant.Util.Combinators.Filtering.Filters

-- | Implements filters via Beam query expressions ('QExpr').
data QExprFilterBackend be s

instance FilterBackend (QExprFilterBackend be s) where

    type AutoFilteredValue (QExprFilterBackend be s) a =
        QExpr be s a

    type MatchPredicate (QExprFilterBackend be s) =
        QExpr be s Bool

instance ( HasSqlEqualityCheck be a
         , HasSqlValueSyntax
            (Sql92ExpressionValueSyntax
              (Sql92SelectTableExpressionSyntax
                  (Sql92SelectSelectTableSyntax
                    (Sql92SelectSyntax
                        (Database.Beam.Backend.SQL.BeamSqlBackendSyntax be)))))
           a
         ) =>
         AutoFilterSupport (QExprFilterBackend be s) FilterMatching a where
    autoFilterSupport :: FilterMatching a -> AutoFilterImpl (QExprFilterBackend be s) a
autoFilterSupport = \case
        FilterMatching a
v    -> (QExpr be s a -> QExpr be s a -> QGenExpr QValueContext be s Bool
forall (expr :: * -> *) a. SqlEq expr a => a -> a -> expr Bool
==. HaskellLiteralForQExpr (QExpr be s a) -> QExpr be s a
forall a. SqlValable a => HaskellLiteralForQExpr a -> a
val_ a
HaskellLiteralForQExpr (QExpr be s a)
v)
        FilterNotMatching a
v -> (QExpr be s a -> QExpr be s a -> QGenExpr QValueContext be s Bool
forall (expr :: * -> *) a. SqlEq expr a => a -> a -> expr Bool
/=. HaskellLiteralForQExpr (QExpr be s a) -> QExpr be s a
forall a. SqlValable a => HaskellLiteralForQExpr a -> a
val_ a
HaskellLiteralForQExpr (QExpr be s a)
v)
        FilterItemsIn [a]
vs    -> (QExpr be s a -> [QExpr be s a] -> QGenExpr QValueContext be s Bool
forall (expr :: * -> *) a. SqlIn expr a => a -> [a] -> expr Bool
`in_` (a -> QExpr be s a) -> [a] -> [QExpr be s a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map a -> QExpr be s a
forall a. SqlValable a => HaskellLiteralForQExpr a -> a
val_ [a]
vs)

instance ( BeamSqlBackend be
         , HasSqlValueSyntax
            (Sql92ExpressionValueSyntax
              (Sql92SelectTableExpressionSyntax
                  (Sql92SelectSelectTableSyntax
                    (Sql92SelectSyntax
                        (Database.Beam.Backend.SQL.BeamSqlBackendSyntax be)))))
           a
         ) =>
         AutoFilterSupport (QExprFilterBackend be s) FilterComparing a where
    autoFilterSupport :: FilterComparing a -> AutoFilterImpl (QExprFilterBackend be s) a
autoFilterSupport = \case
        FilterGT a
v  -> (QExpr be s a -> QExpr be s a -> QGenExpr QValueContext be s Bool
forall (expr :: * -> *) e. SqlOrd expr e => e -> e -> expr Bool
>. HaskellLiteralForQExpr (QExpr be s a) -> QExpr be s a
forall a. SqlValable a => HaskellLiteralForQExpr a -> a
val_ a
HaskellLiteralForQExpr (QExpr be s a)
v)
        FilterLT a
v  -> (QExpr be s a -> QExpr be s a -> QGenExpr QValueContext be s Bool
forall (expr :: * -> *) e. SqlOrd expr e => e -> e -> expr Bool
<. HaskellLiteralForQExpr (QExpr be s a) -> QExpr be s a
forall a. SqlValable a => HaskellLiteralForQExpr a -> a
val_ a
HaskellLiteralForQExpr (QExpr be s a)
v)
        FilterGTE a
v -> (QExpr be s a -> QExpr be s a -> QGenExpr QValueContext be s Bool
forall (expr :: * -> *) e. SqlOrd expr e => e -> e -> expr Bool
>=. HaskellLiteralForQExpr (QExpr be s a) -> QExpr be s a
forall a. SqlValable a => HaskellLiteralForQExpr a -> a
val_ a
HaskellLiteralForQExpr (QExpr be s a)
v)
        FilterLTE a
v -> (QExpr be s a -> QExpr be s a -> QGenExpr QValueContext be s Bool
forall (expr :: * -> *) e. SqlOrd expr e => e -> e -> expr Bool
<=. HaskellLiteralForQExpr (QExpr be s a) -> QExpr be s a
forall a. SqlValable a => HaskellLiteralForQExpr a -> a
val_ a
HaskellLiteralForQExpr (QExpr be s a)
v)

-- For now we do not support custom escape characters.
pattern PgEsc :: Char
pattern $bPgEsc :: Char
$mPgEsc :: forall r. Char -> (Void# -> r) -> (Void# -> r) -> r
PgEsc = '\\'

likeToSqlPattern :: LikePattern -> String
likeToSqlPattern :: LikePattern -> String
likeToSqlPattern = String -> String
go (String -> String)
-> (LikePattern -> String) -> LikePattern -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LText -> String
forall a. ToString a => a -> String
toString (LText -> String)
-> (LikePattern -> LText) -> LikePattern -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LikePattern -> LText
unLikePattern
  where
    go :: String -> String
go = \case
        Char
Esc : Char
'.' : String
r -> Char
'.' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
r
        Char
Esc : Char
'*' : String
r -> Char
'*' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
r
        Char
Esc : Char
c : String
r   -> Char
Esc Char -> String -> String
forall a. a -> [a] -> [a]
: Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
r

        Char
'_' : String
r       -> Char
PgEsc Char -> String -> String
forall a. a -> [a] -> [a]
: Char
'_' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
r
        Char
'%' : String
r       -> Char
PgEsc Char -> String -> String
forall a. a -> [a] -> [a]
: Char
'%' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
r

        Char
'.' : String
r       -> Char
'_' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
r
        Char
'*' : String
r       -> Char
'%' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
r

        Char
c : String
r         -> Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
r
        []            -> []

instance ( IsString text
         , BeamSqlBackend be
         , BeamSqlBackendIsString be text
         , HasSqlValueSyntax
            (Sql92ExpressionValueSyntax
              (Sql92SelectTableExpressionSyntax
                  (Sql92SelectSelectTableSyntax
                    (Sql92SelectSyntax
                        (Database.Beam.Backend.SQL.BeamSqlBackendSyntax be)))))
           text
         ) =>
         AutoFilterSupport (QExprFilterBackend be s) FilterLike text where
    autoFilterSupport :: FilterLike text -> AutoFilterImpl (QExprFilterBackend be s) text
autoFilterSupport = \case
        FilterLike (CaseSensitivity Bool
True) LikePattern
pat ->
            let sqlPat :: text
sqlPat = String -> text
forall a. IsString a => String -> a
fromString (String -> text) -> String -> text
forall a b. (a -> b) -> a -> b
$ LikePattern -> String
likeToSqlPattern LikePattern
pat
            in (QGenExpr QValueContext be s text
-> QGenExpr QValueContext be s text
-> QGenExpr QValueContext be s Bool
forall be text ctxt s.
(BeamSqlBackendIsString be text, BeamSqlBackend be) =>
QGenExpr ctxt be s text
-> QGenExpr ctxt be s text -> QGenExpr ctxt be s Bool
`like_` HaskellLiteralForQExpr (QGenExpr QValueContext be s text)
-> QGenExpr QValueContext be s text
forall a. SqlValable a => HaskellLiteralForQExpr a -> a
val_ text
HaskellLiteralForQExpr (QGenExpr QValueContext be s text)
sqlPat)
        FilterLike (CaseSensitivity Bool
False) LikePattern
_ ->
            -- TODO: allow disabling this at parsing stage
            Text
-> QGenExpr QValueContext be s text
-> QGenExpr QValueContext be s Bool
forall a. HasCallStack => Text -> a
error Text
"Case-insensitive filters are not supported by this backend."

-- | Applies a whole filtering specification to a set of response fields.
-- Resulting value can be put to 'guard_' or 'filter_' function.
matches_
    :: ( BeamSqlBackend be
       , backend ~ QExprFilterBackend be s
       , BackendApplySomeFilter backend params
       )
    => FilteringSpec params
    -> FilteringSpecApp backend params
    -> QExpr be s Bool
matches_ :: FilteringSpec params
-> FilteringSpecApp backend params -> QExpr be s Bool
matches_ = (Element [QExpr be s Bool] -> QExpr be s Bool -> QExpr be s Bool)
-> QExpr be s Bool -> [QExpr be s Bool] -> QExpr be s Bool
forall t b. Container t => (Element t -> b -> b) -> b -> t -> b
foldr Element [QExpr be s Bool] -> QExpr be s Bool -> QExpr be s Bool
forall be context s.
BeamSqlBackend be =>
QGenExpr context be s Bool
-> QGenExpr context be s Bool -> QGenExpr context be s Bool
(&&.) (HaskellLiteralForQExpr (QExpr be s Bool) -> QExpr be s Bool
forall a. SqlValable a => HaskellLiteralForQExpr a -> a
val_ Bool
HaskellLiteralForQExpr (QExpr be s Bool)
True) ([QExpr be s Bool] -> QExpr be s Bool)
-> (FilteringSpec params
    -> FilteringSpecApp (QExprFilterBackend be s) params
    -> [QExpr be s Bool])
-> FilteringSpec params
-> FilteringSpecApp backend params
-> QExpr be s Bool
forall a b c. SuperComposition a b c => a -> b -> c
... FilteringSpec params
-> FilteringSpecApp (QExprFilterBackend be s) params
-> [QExpr be s Bool]
forall k (backend :: k) (params :: [TyNamedFilter]).
BackendApplySomeFilter backend params =>
FilteringSpec params
-> FilteringSpecApp backend params -> [MatchPredicate backend]
backendApplyFilters

-- | Implements filters via Beam query monad ('Q').
data QFilterBackend be (db :: (* -> *) -> *) s

instance FilterBackend (QFilterBackend be db s) where

    type AutoFilteredValue (QFilterBackend be db s) a =
        QExpr be s a

    type MatchPredicate (QFilterBackend be db s) =
        Q be db s ()

instance ( BeamSqlBackend be
         , AutoFilterSupport (QExprFilterBackend be s) filter a
         ) =>
         AutoFilterSupport (QFilterBackend be db s) filter a where
    autoFilterSupport :: filter a -> AutoFilterImpl (QFilterBackend be db s) a
autoFilterSupport =
      QExpr be s Bool -> Q be db s ()
forall be (db :: (* -> *) -> *) s.
BeamSqlBackend be =>
QExpr be s Bool -> Q be db s ()
guard_ (QExpr be s Bool -> Q be db s ())
-> (filter a -> QExpr be s a -> QExpr be s Bool)
-> filter a
-> QExpr be s a
-> Q be db s ()
forall a b c. SuperComposition a b c => a -> b -> c
... forall k (backend :: k) (filter :: * -> *) a.
AutoFilterSupport backend filter a =>
filter a -> AutoFilterImpl backend a
forall (filter :: * -> *) a.
AutoFilterSupport (QExprFilterBackend be s) filter a =>
filter a -> AutoFilterImpl (QExprFilterBackend be s) a
autoFilterSupport @(QExprFilterBackend _ _)

-- | Applies a whole filtering specification to a set of response fields.
-- Resulting value can be monadically binded with the remaining query (just like 'guard_').
filtersGuard_
    :: ( backend ~ QFilterBackend be db s
       , BackendApplySomeFilter backend params
       )
    => FilteringSpec params
    -> FilteringSpecApp backend params
    -> Q be db s ()
filtersGuard_ :: FilteringSpec params
-> FilteringSpecApp backend params -> Q be db s ()
filtersGuard_ = [Q be db s ()] -> Q be db s ()
forall t (m :: * -> *) a.
(Container t, Monad m, Element t ~ m a) =>
t -> m ()
sequence_ ([Q be db s ()] -> Q be db s ())
-> (FilteringSpec params
    -> FilteringSpecApp (QFilterBackend be db s) params
    -> [Q be db s ()])
-> FilteringSpec params
-> FilteringSpecApp backend params
-> Q be db s ()
forall a b c. SuperComposition a b c => a -> b -> c
... FilteringSpec params
-> FilteringSpecApp (QFilterBackend be db s) params
-> [Q be db s ()]
forall k (backend :: k) (params :: [TyNamedFilter]).
BackendApplySomeFilter backend params =>
FilteringSpec params
-> FilteringSpecApp backend params -> [MatchPredicate backend]
backendApplyFilters