{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TypeInType    #-}

module Servant.Util.Combinators.Filtering.Base
    ( FilterKind (..)
    , TyNamedFilter
    , FilteringParams
    , SupportedFilters
    , FilteringSpec (..)
    , pattern DefFilteringCmd

    , SomeTypeAutoFilter (..)
    , TypeFilter (..)
    , SomeFilter (..)
    , extendSomeFilter
    , castTypeFilter

    , BuildableAutoFilter (..)
    , IsAutoFilter (..)
    , AreAutoFilters (..)
    , FilteringValueParser (..)
    , OpsDescriptions
    , parseFilteringValueAsIs
    , unsupportedFilteringValue
    , autoFiltersParsers

    , FilteringParamTypesOf
    , FilteringParamsOf
    , FilteringSpecOf
    ) where

import Universum

import qualified Data.Map as M
import Data.Typeable (cast)
import Fmt (Buildable (..), Builder)
import GHC.Exts (IsList)
import Servant (FromHttpApiData (..), ToHttpApiData (..))
import Servant.API (NoContent)

import Servant.Util.Common

-- | We support two kinds of filters.
data FilterKind a
    = AutoFilter a
      -- ^ Automatic filter where different operations are supported (eq, in, cmp).
      -- When applied to backend, only filtered value should be supplied.
    | ManualFilter a
      -- ^ User-provided value is passed to backend implementation as-is,
      -- and filtering on this value should be written manually.

type TyNamedFilter = TyNamedParam (FilterKind Type)

-- | Servant API combinator which enables filtering on given fields.
--
-- If type @T@ appears with a name @name@ in @params@ argument, then query parameters of
-- @name[op]=value@ format will be accepted, where @op@ is a filtering operation
-- (e.g. equal, not equal, greater) and @value@ is an item of type @T@ we filter against.
-- Multiple filters will form a conjunction.
--
-- List of allowed filtering operations depends on type @T@ and is specified by
-- 'SupportedFilters' type family.
--
-- Operation argument is optional, when not specified "equality" filter is applied.
--
-- Endpoint implementation will receive 'FilteringSpec' value which contains information
-- about all filters passed by user. You can later put it to an appropriate function
-- to apply filtering.
data FilteringParams (params :: [TyNamedFilter])

-- | For a type of field, get a list of supported filtering operations on this field.
type family SupportedFilters ty :: [Type -> Type]

-- | If no filtering command specified, think like if the given one was passed.
pattern DefFilteringCmd :: Text
pattern $bDefFilteringCmd :: Text
$mDefFilteringCmd :: forall r. Text -> (Void# -> r) -> (Void# -> r) -> r
DefFilteringCmd = "eq"

-- | Parses text on the right side of "=" sign in query parameters.
newtype FilteringValueParser a = FilteringValueParser (Text -> Either Text a)
    deriving (a -> FilteringValueParser b -> FilteringValueParser a
(a -> b) -> FilteringValueParser a -> FilteringValueParser b
(forall a b.
 (a -> b) -> FilteringValueParser a -> FilteringValueParser b)
-> (forall a b.
    a -> FilteringValueParser b -> FilteringValueParser a)
-> Functor FilteringValueParser
forall a b. a -> FilteringValueParser b -> FilteringValueParser a
forall a b.
(a -> b) -> FilteringValueParser a -> FilteringValueParser b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> FilteringValueParser b -> FilteringValueParser a
$c<$ :: forall a b. a -> FilteringValueParser b -> FilteringValueParser a
fmap :: (a -> b) -> FilteringValueParser a -> FilteringValueParser b
$cfmap :: forall a b.
(a -> b) -> FilteringValueParser a -> FilteringValueParser b
Functor)

-- | Delegate to 'FromHttpApiData'.
parseFilteringValueAsIs :: FromHttpApiData a => FilteringValueParser a
parseFilteringValueAsIs :: FilteringValueParser a
parseFilteringValueAsIs = (Text -> Either Text a) -> FilteringValueParser a
forall a. (Text -> Either Text a) -> FilteringValueParser a
FilteringValueParser Text -> Either Text a
forall a. FromHttpApiData a => Text -> Either Text a
parseUrlPiece

unsupportedFilteringValue :: Text -> FilteringValueParser a
unsupportedFilteringValue :: Text -> FilteringValueParser a
unsupportedFilteringValue Text
errMsg = (Text -> Either Text a) -> FilteringValueParser a
forall a. (Text -> Either Text a) -> FilteringValueParser a
FilteringValueParser (\Text
_ -> Text -> Either Text a
forall a b. a -> Either a b
Left Text
errMsg)

-- | For each filtering operation specifies a short plain-english description.
-- This is not a 'Map' to prevent developer-defined entries order.
type OpsDescriptions = [(Text, Text)]

-- | How auto filters appear in logging.
class BuildableAutoFilter (filter :: Type -> Type) where
    buildAutoFilter
        :: Buildable a => Text -> filter a -> Builder

-- | Application of a filter type to Servant API.
class (Typeable filter, BuildableAutoFilter filter) =>
      IsAutoFilter (filter :: Type -> Type) where

    -- | For each supported filtering operation specifies a short plain-english
    -- description.
    autoFilterEnglishOpsNames
        :: OpsDescriptions

    -- | For each supported filtering operation specifies parser for a filtering value.
    autoFilterParsers
        :: FromHttpApiData a
        => Proxy filter -> Map Text (FilteringValueParser (filter a))

    -- | Encode a filter to query parameter value.
    autoFilterEncode
        :: ToHttpApiData a
        => filter a -> (Text, Text)

    mapAutoFilterValue
        :: (a -> b) -> filter a -> filter b
    default mapAutoFilterValue
        :: Functor filter => (a -> b) -> filter a -> filter b
    mapAutoFilterValue = (a -> b) -> filter a -> filter b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap

-- | Multi-version of 'IsFilter'.
class AreAutoFilters (filters :: [Type -> Type]) where
    mapFilterTypes
        :: (forall filter. IsAutoFilter filter => Proxy filter -> a)
        -> Proxy filters -> [a]

instance AreAutoFilters '[] where
    mapFilterTypes :: (forall (filter :: * -> *).
 IsAutoFilter filter =>
 Proxy filter -> a)
-> Proxy '[] -> [a]
mapFilterTypes forall (filter :: * -> *). IsAutoFilter filter => Proxy filter -> a
_ Proxy '[]
_ = []

instance (IsAutoFilter filter, AreAutoFilters filters) =>
         AreAutoFilters (filter ': filters) where
    mapFilterTypes :: (forall (filter :: * -> *).
 IsAutoFilter filter =>
 Proxy filter -> a)
-> Proxy (filter : filters) -> [a]
mapFilterTypes forall (filter :: * -> *). IsAutoFilter filter => Proxy filter -> a
mapper Proxy (filter : filters)
_ =
        Proxy filter -> a
forall (filter :: * -> *). IsAutoFilter filter => Proxy filter -> a
mapper (Proxy filter
forall k (t :: k). Proxy t
Proxy @filter) a -> [a] -> [a]
forall a. a -> [a] -> [a]
: (forall (filter :: * -> *).
 IsAutoFilter filter =>
 Proxy filter -> a)
-> Proxy filters -> [a]
forall (filters :: [* -> *]) a.
AreAutoFilters filters =>
(forall (filter :: * -> *).
 IsAutoFilter filter =>
 Proxy filter -> a)
-> Proxy filters -> [a]
mapFilterTypes forall (filter :: * -> *). IsAutoFilter filter => Proxy filter -> a
mapper (Proxy filters
forall k (t :: k). Proxy t
Proxy @filters)

-- | Gather parsers from multiple filters.
autoFiltersParsers
    :: forall filters a.
       (AreAutoFilters filters, FromHttpApiData a)
    => Map Text $ FilteringValueParser (SomeTypeAutoFilter a)
autoFiltersParsers :: Map Text $ FilteringValueParser (SomeTypeAutoFilter a)
autoFiltersParsers =
    let parsers :: [Map Text $ FilteringValueParser (SomeTypeAutoFilter a)]
parsers = (forall (filter :: * -> *).
 IsAutoFilter filter =>
 Proxy filter
 -> Map Text $ FilteringValueParser (SomeTypeAutoFilter a))
-> Proxy filters
-> [Map Text $ FilteringValueParser (SomeTypeAutoFilter a)]
forall (filters :: [* -> *]) a.
AreAutoFilters filters =>
(forall (filter :: * -> *).
 IsAutoFilter filter =>
 Proxy filter -> a)
-> Proxy filters -> [a]
mapFilterTypes ((FilteringValueParser (filter a)
 -> FilteringValueParser (SomeTypeAutoFilter a))
-> Map Text (FilteringValueParser (filter a))
-> Map Text $ FilteringValueParser (SomeTypeAutoFilter a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((filter a -> SomeTypeAutoFilter a)
-> FilteringValueParser (filter a)
-> FilteringValueParser (SomeTypeAutoFilter a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap filter a -> SomeTypeAutoFilter a
forall a (filter :: * -> *).
IsAutoFilter filter =>
filter a -> SomeTypeAutoFilter a
SomeTypeAutoFilter) (Map Text (FilteringValueParser (filter a))
 -> Map Text $ FilteringValueParser (SomeTypeAutoFilter a))
-> (Proxy filter -> Map Text (FilteringValueParser (filter a)))
-> Proxy filter
-> Map Text $ FilteringValueParser (SomeTypeAutoFilter a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy filter -> Map Text (FilteringValueParser (filter a))
forall (filter :: * -> *) a.
(IsAutoFilter filter, FromHttpApiData a) =>
Proxy filter -> Map Text (FilteringValueParser (filter a))
autoFilterParsers)
                                 (Proxy filters
forall k (t :: k). Proxy t
Proxy @filters)
    in ((Map Text $ FilteringValueParser (SomeTypeAutoFilter a))
 -> Element [Map Text $ FilteringValueParser (SomeTypeAutoFilter a)]
 -> Map Text $ FilteringValueParser (SomeTypeAutoFilter a))
-> (Map Text $ FilteringValueParser (SomeTypeAutoFilter a))
-> [Map Text $ FilteringValueParser (SomeTypeAutoFilter a)]
-> Map Text $ FilteringValueParser (SomeTypeAutoFilter a)
forall t b. Container t => (b -> Element t -> b) -> b -> t -> b
foldl' ((Text
 -> FilteringValueParser (SomeTypeAutoFilter a)
 -> FilteringValueParser (SomeTypeAutoFilter a)
 -> FilteringValueParser (SomeTypeAutoFilter a))
-> (Map Text $ FilteringValueParser (SomeTypeAutoFilter a))
-> (Map Text $ FilteringValueParser (SomeTypeAutoFilter a))
-> Map Text $ FilteringValueParser (SomeTypeAutoFilter a)
forall k a.
Ord k =>
(k -> a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWithKey Text
-> FilteringValueParser (SomeTypeAutoFilter a)
-> FilteringValueParser (SomeTypeAutoFilter a)
-> FilteringValueParser (SomeTypeAutoFilter a)
forall a a. Show a => a -> a
onDuplicateCmd) Map Text $ FilteringValueParser (SomeTypeAutoFilter a)
forall a. Monoid a => a
mempty [Map Text $ FilteringValueParser (SomeTypeAutoFilter a)]
parsers
  where
    onDuplicateCmd :: a -> a
onDuplicateCmd a
cmd = Text -> a
forall a. HasCallStack => Text -> a
error (Text -> a) -> Text -> a
forall a b. (a -> b) -> a -> b
$ Text
"Different filters have the same command " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall b a. (Show a, IsString b) => a -> b
show a
cmd

-- | Some filter for an item of type @a@.
-- Filter type is guaranteed to be one of @SupportedFilters a@.
data SomeTypeAutoFilter a =
    forall filter. IsAutoFilter filter => SomeTypeAutoFilter (filter a)

instance Functor SomeTypeAutoFilter where
    fmap :: (a -> b) -> SomeTypeAutoFilter a -> SomeTypeAutoFilter b
fmap a -> b
f (SomeTypeAutoFilter filter a
filtr) = filter b -> SomeTypeAutoFilter b
forall a (filter :: * -> *).
IsAutoFilter filter =>
filter a -> SomeTypeAutoFilter a
SomeTypeAutoFilter ((a -> b) -> filter a -> filter b
forall (filter :: * -> *) a b.
IsAutoFilter filter =>
(a -> b) -> filter a -> filter b
mapAutoFilterValue a -> b
f filter a
filtr)

instance Buildable a => Buildable (Text, SomeTypeAutoFilter a) where
    build :: (Text, SomeTypeAutoFilter a) -> Builder
build (Text
name, SomeTypeAutoFilter filter a
f) = Text -> filter a -> Builder
forall (filter :: * -> *) a.
(BuildableAutoFilter filter, Buildable a) =>
Text -> filter a -> Builder
buildAutoFilter Text
name filter a
f

-- | Some filter for an item of type @a@.
data TypeFilter (fk :: Type -> FilterKind Type) a where
    -- | One of automatic filters for type @a@.
    -- Filter type is guaranteed to be one of @SupportedFilters a@.
    TypeAutoFilter
        :: SomeTypeAutoFilter a -> TypeFilter 'AutoFilter a

    -- | Manually implemented filter.
    TypeManualFilter
        :: a -> TypeFilter 'ManualFilter a

castTypeFilter
    :: forall fk1 a1 fk2 a2.
       (Typeable fk1, Typeable a1, Typeable fk2, Typeable a2)
    => TypeFilter fk1 a1 -> Maybe (TypeFilter fk2 a2)
castTypeFilter :: TypeFilter fk1 a1 -> Maybe (TypeFilter fk2 a2)
castTypeFilter = TypeFilter fk1 a1 -> Maybe (TypeFilter fk2 a2)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast

-- | Some filter.
-- This filter is guaranteed to match a type which is mentioned in @params@.
data SomeFilter (params :: [TyNamedFilter]) where
    SomeFilter :: (Typeable fk, Typeable a) =>
        { SomeFilter params -> Text
sfName :: Text
        , ()
sfFilter :: TypeFilter fk a
        } -> SomeFilter params

extendSomeFilter :: SomeFilter params -> SomeFilter (param ': params)
extendSomeFilter :: SomeFilter params -> SomeFilter (param : params)
extendSomeFilter (SomeFilter Text
f TypeFilter fk a
n) = Text -> TypeFilter fk a -> SomeFilter (param : params)
forall (fk :: * -> FilterKind *) a (params :: [TyNamedFilter]).
(Typeable fk, Typeable a) =>
Text -> TypeFilter fk a -> SomeFilter params
SomeFilter Text
f TypeFilter fk a
n

-- | This is what you get in endpoint implementation, it contains all filters
-- supplied by a user.
-- Invariant: each filter correspond to some type mentioned in @params@.
newtype FilteringSpec (params :: [TyNamedFilter]) = FilteringSpec [SomeFilter params]
    deriving (Int -> [Item (FilteringSpec params)] -> FilteringSpec params
[Item (FilteringSpec params)] -> FilteringSpec params
FilteringSpec params -> [Item (FilteringSpec params)]
([Item (FilteringSpec params)] -> FilteringSpec params)
-> (Int -> [Item (FilteringSpec params)] -> FilteringSpec params)
-> (FilteringSpec params -> [Item (FilteringSpec params)])
-> IsList (FilteringSpec params)
forall (params :: [TyNamedFilter]).
Int -> [Item (FilteringSpec params)] -> FilteringSpec params
forall (params :: [TyNamedFilter]).
[Item (FilteringSpec params)] -> FilteringSpec params
forall (params :: [TyNamedFilter]).
FilteringSpec params -> [Item (FilteringSpec params)]
forall l.
([Item l] -> l)
-> (Int -> [Item l] -> l) -> (l -> [Item l]) -> IsList l
toList :: FilteringSpec params -> [Item (FilteringSpec params)]
$ctoList :: forall (params :: [TyNamedFilter]).
FilteringSpec params -> [Item (FilteringSpec params)]
fromListN :: Int -> [Item (FilteringSpec params)] -> FilteringSpec params
$cfromListN :: forall (params :: [TyNamedFilter]).
Int -> [Item (FilteringSpec params)] -> FilteringSpec params
fromList :: [Item (FilteringSpec params)] -> FilteringSpec params
$cfromList :: forall (params :: [TyNamedFilter]).
[Item (FilteringSpec params)] -> FilteringSpec params
IsList)

-- | For a given return type of an endpoint get corresponding filtering params.
-- This mapping is sensible, since we usually allow to filter only on fields appearing in
-- endpoint's response.
type family FilteringParamTypesOf a :: [TyNamedFilter]

-- | This you will most probably want to specify in API.
type FilteringParamsOf a = FilteringParams (FilteringParamTypesOf a)

-- | This you will most probably want to specify in an endpoint implementation.
type FilteringSpecOf a = FilteringSpec (FilteringParamTypesOf a)

type instance FilteringParamTypesOf NoContent = '[]