{-# LANGUAGE TypeInType #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Servant.Util.Combinators.Filtering.Server
    ( AreFilteringParams
    ) where

import Universum

import qualified Data.Map as M
import qualified Data.Text as T
import Fmt (Buildable (..))
import GHC.TypeLits (KnownSymbol)
import Network.HTTP.Types.URI (QueryText, parseQueryText)
import Network.Wai.Internal (rawQueryString)
import Servant (FromHttpApiData (..), HasServer (..), ServerError (..), err400, (:>))
import Servant.Server.Internal (addParameterCheck, delayedFailFatal, withRequest)

import Servant.Util.Combinators.Filtering.Base
import Servant.Util.Common

-- | Try to parse query key assuming that the specified field to filter on
-- should match the given name.
-- If specified filter does not match the given one, 'Nothing' is returned.
-- Otherwise operation name is extracted and returned.
parseQueryKey :: Text -> Text -> Maybe Text
parseQueryKey :: Text -> Text -> Maybe Text
parseQueryKey Text
field Text
key = do
    Text
remainder <- Text -> Text -> Maybe Text
T.stripPrefix Text
field Text
key
    [Maybe Text] -> Maybe Text
forall t (f :: * -> *) a.
(Container t, Alternative f, Element t ~ f a) =>
t -> f a
asum
        [ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Text -> Bool
forall t. Container t => t -> Bool
null Text
remainder) Maybe () -> Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Text
DefFilteringCmd
        , Text -> Text -> Maybe Text
T.stripPrefix Text
"[" (Text -> Maybe Text) -> (Text -> Maybe Text) -> Text -> Maybe Text
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Text -> Text -> Maybe Text
T.stripSuffix Text
"]" (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
remainder
        , Text -> Text -> Maybe Text
T.stripPrefix Text
"_" Text
remainder
        ]

-- | Try to parse given query parameter as filter applicable to type @a@.
-- If the parameter is not recognized as filtering one, 'Nothing' is returned.
-- Otherwise it is parsed and any potential errors are reported as-is.
parseAutoTypeFilteringParam
    :: forall a (filters :: [Type -> Type]).
       (filters ~ SupportedFilters a, AreAutoFilters filters, FromHttpApiData a)
    => Text -> Text -> Text -> Maybe (Either Text $ SomeTypeAutoFilter a)
parseAutoTypeFilteringParam :: Text -> Text -> Text -> Maybe (Either Text $ SomeTypeAutoFilter a)
parseAutoTypeFilteringParam Text
field Text
key Text
val = do
    Text
op <- Text -> Text -> Maybe Text
parseQueryKey Text
field Text
key
    let parsersPerOp :: Map Text $ FilteringValueParser (SomeTypeAutoFilter a)
parsersPerOp = (AreAutoFilters filters, FromHttpApiData a) =>
Map Text $ FilteringValueParser (SomeTypeAutoFilter a)
forall (filters :: [* -> *]) a.
(AreAutoFilters filters, FromHttpApiData a) =>
Map Text $ FilteringValueParser (SomeTypeAutoFilter a)
autoFiltersParsers @filters @a
    let allowedOps :: [Text]
allowedOps = (Map Text $ FilteringValueParser (SomeTypeAutoFilter a)) -> [Text]
forall k a. Map k a -> [k]
M.keys Map Text $ FilteringValueParser (SomeTypeAutoFilter a)
parsersPerOp

    (Either Text $ SomeTypeAutoFilter a)
-> Maybe (Either Text $ SomeTypeAutoFilter a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Either Text $ SomeTypeAutoFilter a)
 -> Maybe (Either Text $ SomeTypeAutoFilter a))
-> (Either Text $ SomeTypeAutoFilter a)
-> Maybe (Either Text $ SomeTypeAutoFilter a)
forall a b. (a -> b) -> a -> b
$ do
        FilteringValueParser Text -> Either Text $ SomeTypeAutoFilter a
parser <- case Text
-> (Map Text $ FilteringValueParser (SomeTypeAutoFilter a))
-> Maybe (FilteringValueParser (SomeTypeAutoFilter a))
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
op Map Text $ FilteringValueParser (SomeTypeAutoFilter a)
parsersPerOp of
            Maybe (FilteringValueParser (SomeTypeAutoFilter a))
Nothing -> Text -> Either Text (FilteringValueParser (SomeTypeAutoFilter a))
forall a b. a -> Either a b
Left (Text -> Either Text (FilteringValueParser (SomeTypeAutoFilter a)))
-> Text
-> Either Text (FilteringValueParser (SomeTypeAutoFilter a))
forall a b. (a -> b) -> a -> b
$ Text
"Unsupported filtering command " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall b a. (Show a, IsString b) => a -> b
show Text
op Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". \
                              \Available commands: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                              (Text -> [Text] -> Text
T.intercalate Text
", " ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Text -> Text
forall b a. (Show a, IsString b) => a -> b
show [Text]
allowedOps)
            Just FilteringValueParser (SomeTypeAutoFilter a)
parser -> FilteringValueParser (SomeTypeAutoFilter a)
-> Either Text (FilteringValueParser (SomeTypeAutoFilter a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilteringValueParser (SomeTypeAutoFilter a)
parser

        Text -> Either Text $ SomeTypeAutoFilter a
parser Text
val
{-# INLINE parseAutoTypeFilteringParam #-}

-- | Application of filter params.
class AreFilteringParams (params :: [TyNamedFilter]) where
    -- | Try to parser given query parameter as a filter corresponding to @params@
    -- configuration.
    -- If the query parameter is not recognized as filtering one, 'Nothing' is returned.
    -- Otherwise it is parsed and any potential errors are reported as-is.
    parseFilteringParam :: Text -> Text -> Maybe (Either Text $ SomeFilter params)

instance AreFilteringParams '[] where
    parseFilteringParam :: Text -> Text -> Maybe (Either Text $ SomeFilter '[])
parseFilteringParam Text
_ Text
_ = Maybe (Either Text $ SomeFilter '[])
forall a. Maybe a
Nothing
    {-# INLINE parseFilteringParam #-}

instance ( FromHttpApiData ty
         , Typeable ty
         , AreAutoFilters (SupportedFilters ty)
         , KnownSymbol name
         , AreFilteringParams params
         ) =>
         AreFilteringParams ('TyNamedParam name ('AutoFilter ty) ': params) where
    parseFilteringParam :: Text
-> Text
-> Maybe
     (Either Text
      $ SomeFilter ('TyNamedParam name ('AutoFilter ty) : params))
parseFilteringParam Text
key Text
val = [Maybe
   (Either Text
    $ SomeFilter ('TyNamedParam name ('AutoFilter ty) : params))]
-> Maybe
     (Either Text
      $ SomeFilter ('TyNamedParam name ('AutoFilter ty) : params))
forall t (f :: * -> *) a.
(Container t, Alternative f, Element t ~ f a) =>
t -> f a
asum
        [ (Either Text (SomeTypeAutoFilter ty)
 -> Either Text
    $ SomeFilter ('TyNamedParam name ('AutoFilter ty) : params))
-> Maybe (Either Text (SomeTypeAutoFilter ty))
-> Maybe
     (Either Text
      $ SomeFilter ('TyNamedParam name ('AutoFilter ty) : params))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((SomeTypeAutoFilter ty
 -> SomeFilter ('TyNamedParam name ('AutoFilter ty) : params))
-> Either Text (SomeTypeAutoFilter ty)
-> Either Text
   $ SomeFilter ('TyNamedParam name ('AutoFilter ty) : params)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text
-> TypeFilter 'AutoFilter ty
-> SomeFilter ('TyNamedParam name ('AutoFilter ty) : params)
forall (fk :: * -> FilterKind *) a (params :: [TyNamedFilter]).
(Typeable fk, Typeable a) =>
Text -> TypeFilter fk a -> SomeFilter params
SomeFilter Text
name (TypeFilter 'AutoFilter ty
 -> SomeFilter ('TyNamedParam name ('AutoFilter ty) : params))
-> (SomeTypeAutoFilter ty -> TypeFilter 'AutoFilter ty)
-> SomeTypeAutoFilter ty
-> SomeFilter ('TyNamedParam name ('AutoFilter ty) : params)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeTypeAutoFilter ty -> TypeFilter 'AutoFilter ty
forall a. SomeTypeAutoFilter a -> TypeFilter 'AutoFilter a
TypeAutoFilter)) (Maybe (Either Text (SomeTypeAutoFilter ty))
 -> Maybe
      (Either Text
       $ SomeFilter ('TyNamedParam name ('AutoFilter ty) : params)))
-> Maybe (Either Text (SomeTypeAutoFilter ty))
-> Maybe
     (Either Text
      $ SomeFilter ('TyNamedParam name ('AutoFilter ty) : params))
forall a b. (a -> b) -> a -> b
$
            Text -> Text -> Text -> Maybe (Either Text (SomeTypeAutoFilter ty))
forall a (filters :: [* -> *]).
(filters ~ SupportedFilters a, AreAutoFilters filters,
 FromHttpApiData a) =>
Text -> Text -> Text -> Maybe (Either Text $ SomeTypeAutoFilter a)
parseAutoTypeFilteringParam @ty (KnownSymbol name => Text
forall (s :: Symbol). KnownSymbol s => Text
symbolValT @name) Text
key Text
val

        , (Either Text (SomeFilter params)
 -> Either Text
    $ SomeFilter ('TyNamedParam name ('AutoFilter ty) : params))
-> Maybe (Either Text (SomeFilter params))
-> Maybe
     (Either Text
      $ SomeFilter ('TyNamedParam name ('AutoFilter ty) : params))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((SomeFilter params
 -> SomeFilter ('TyNamedParam name ('AutoFilter ty) : params))
-> Either Text (SomeFilter params)
-> Either Text
   $ SomeFilter ('TyNamedParam name ('AutoFilter ty) : params)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SomeFilter params
-> SomeFilter ('TyNamedParam name ('AutoFilter ty) : params)
forall (params :: [TyNamedFilter]) (param :: TyNamedFilter).
SomeFilter params -> SomeFilter (param : params)
extendSomeFilter) (Maybe (Either Text (SomeFilter params))
 -> Maybe
      (Either Text
       $ SomeFilter ('TyNamedParam name ('AutoFilter ty) : params)))
-> Maybe (Either Text (SomeFilter params))
-> Maybe
     (Either Text
      $ SomeFilter ('TyNamedParam name ('AutoFilter ty) : params))
forall a b. (a -> b) -> a -> b
$
            Text -> Text -> Maybe (Either Text (SomeFilter params))
forall (params :: [TyNamedFilter]).
AreFilteringParams params =>
Text -> Text -> Maybe (Either Text $ SomeFilter params)
parseFilteringParam @params Text
key Text
val
        ]
      where
        name :: Text
name = KnownSymbol name => Text
forall (s :: Symbol). KnownSymbol s => Text
symbolValT @name
    {-# INLINE parseFilteringParam #-}

instance ( FromHttpApiData ty
         , Buildable ty
         , Typeable ty
         , KnownSymbol name
         , AreFilteringParams params
         ) =>
         AreFilteringParams ('TyNamedParam name ('ManualFilter ty) ': params) where
    parseFilteringParam :: Text
-> Text
-> Maybe
     (Either Text
      $ SomeFilter ('TyNamedParam name ('ManualFilter ty) : params))
parseFilteringParam Text
key Text
val = [Maybe
   (Either Text
    $ SomeFilter ('TyNamedParam name ('ManualFilter ty) : params))]
-> Maybe
     (Either Text
      $ SomeFilter ('TyNamedParam name ('ManualFilter ty) : params))
forall t (f :: * -> *) a.
(Container t, Alternative f, Element t ~ f a) =>
t -> f a
asum
        [ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
key) Maybe ()
-> (Either Text
    $ SomeFilter ('TyNamedParam name ('ManualFilter ty) : params))
-> Maybe
     (Either Text
      $ SomeFilter ('TyNamedParam name ('ManualFilter ty) : params))
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> do
            ty
v <- Text -> Either Text ty
forall a. FromHttpApiData a => Text -> Either Text a
parseUrlPiece @ty Text
val
            SomeFilter ('TyNamedParam name ('ManualFilter ty) : params)
-> Either Text
   $ SomeFilter ('TyNamedParam name ('ManualFilter ty) : params)
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeFilter ('TyNamedParam name ('ManualFilter ty) : params)
 -> Either Text
    $ SomeFilter ('TyNamedParam name ('ManualFilter ty) : params))
-> SomeFilter ('TyNamedParam name ('ManualFilter ty) : params)
-> Either Text
   $ SomeFilter ('TyNamedParam name ('ManualFilter ty) : params)
forall a b. (a -> b) -> a -> b
$ SomeFilter :: forall (fk :: * -> FilterKind *) a (params :: [TyNamedFilter]).
(Typeable fk, Typeable a) =>
Text -> TypeFilter fk a -> SomeFilter params
SomeFilter
                { sfName :: Text
sfName = Text
name
                , sfFilter :: TypeFilter 'ManualFilter ty
sfFilter = ty -> TypeFilter 'ManualFilter ty
forall a. a -> TypeFilter 'ManualFilter a
TypeManualFilter ty
v
                }

        , (Either Text (SomeFilter params)
 -> Either Text
    $ SomeFilter ('TyNamedParam name ('ManualFilter ty) : params))
-> Maybe (Either Text (SomeFilter params))
-> Maybe
     (Either Text
      $ SomeFilter ('TyNamedParam name ('ManualFilter ty) : params))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((SomeFilter params
 -> SomeFilter ('TyNamedParam name ('ManualFilter ty) : params))
-> Either Text (SomeFilter params)
-> Either Text
   $ SomeFilter ('TyNamedParam name ('ManualFilter ty) : params)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SomeFilter params
-> SomeFilter ('TyNamedParam name ('ManualFilter ty) : params)
forall (params :: [TyNamedFilter]) (param :: TyNamedFilter).
SomeFilter params -> SomeFilter (param : params)
extendSomeFilter) (Maybe (Either Text (SomeFilter params))
 -> Maybe
      (Either Text
       $ SomeFilter ('TyNamedParam name ('ManualFilter ty) : params)))
-> Maybe (Either Text (SomeFilter params))
-> Maybe
     (Either Text
      $ SomeFilter ('TyNamedParam name ('ManualFilter ty) : params))
forall a b. (a -> b) -> a -> b
$
            Text -> Text -> Maybe (Either Text (SomeFilter params))
forall (params :: [TyNamedFilter]).
AreFilteringParams params =>
Text -> Text -> Maybe (Either Text $ SomeFilter params)
parseFilteringParam @params Text
key Text
val
        ]
      where
        name :: Text
name = KnownSymbol name => Text
forall (s :: Symbol). KnownSymbol s => Text
symbolValT @name
    {-# INLINE parseFilteringParam #-}

extractQueryParamsFilters
    :: forall (params :: [TyNamedFilter]).
       (AreFilteringParams params)
    => QueryText -> Either Text [SomeFilter params]
extractQueryParamsFilters :: QueryText -> Either Text [SomeFilter params]
extractQueryParamsFilters QueryText
qt = [Either Text (SomeFilter params)]
-> Either Text [SomeFilter params]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Either Text (SomeFilter params)]
 -> Either Text [SomeFilter params])
-> [Either Text (SomeFilter params)]
-> Either Text [SomeFilter params]
forall a b. (a -> b) -> a -> b
$ do
    (Text
key, Maybe Text
mvalue) <- QueryText
qt
    Just Text
value <- Maybe Text -> [Maybe Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
mvalue
    Just Either Text (SomeFilter params)
aFilter <- Maybe (Either Text (SomeFilter params))
-> [Maybe (Either Text (SomeFilter params))]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Either Text (SomeFilter params))
 -> [Maybe (Either Text (SomeFilter params))])
-> Maybe (Either Text (SomeFilter params))
-> [Maybe (Either Text (SomeFilter params))]
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Maybe (Either Text (SomeFilter params))
forall (params :: [TyNamedFilter]).
AreFilteringParams params =>
Text -> Text -> Maybe (Either Text $ SomeFilter params)
parseFilteringParam @params Text
key Text
value
    Either Text (SomeFilter params)
-> [Either Text (SomeFilter params)]
forall (m :: * -> *) a. Monad m => a -> m a
return Either Text (SomeFilter params)
aFilter
{-# INLINE extractQueryParamsFilters #-}

instance ( HasServer subApi ctx
         , AreFilteringParams params
         ) =>
         HasServer (FilteringParams params :> subApi) ctx where

    type ServerT (FilteringParams params :> subApi) m =
        FilteringSpec params -> ServerT subApi m

    route :: Proxy (FilteringParams params :> subApi)
-> Context ctx
-> Delayed env (Server (FilteringParams params :> subApi))
-> Router env
route Proxy (FilteringParams params :> subApi)
_ Context ctx
ctx Delayed env (Server (FilteringParams params :> subApi))
delayed =
        Proxy subApi
-> Context ctx -> Delayed env (Server subApi) -> Router env
forall k (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (Proxy subApi
forall k (t :: k). Proxy t
Proxy @subApi) Context ctx
ctx (Delayed env (Server subApi) -> Router env)
-> Delayed env (Server subApi) -> Router env
forall a b. (a -> b) -> a -> b
$
        Delayed env (FilteringSpec params -> Server subApi)
-> DelayedIO (FilteringSpec params) -> Delayed env (Server subApi)
forall env a b.
Delayed env (a -> b) -> DelayedIO a -> Delayed env b
addParameterCheck Delayed env (Server (FilteringParams params :> subApi))
Delayed env (FilteringSpec params -> Server subApi)
delayed ((Request -> DelayedIO (FilteringSpec params))
-> DelayedIO (FilteringSpec params)
forall a. (Request -> DelayedIO a) -> DelayedIO a
withRequest Request -> DelayedIO (FilteringSpec params)
extractParams)
      where
        extractParams :: Request -> DelayedIO (FilteringSpec params)
extractParams Request
req =
            let -- Copy-pasted from 'instance HasServer QueryParam'
                queryText :: QueryText
queryText = ByteString -> QueryText
parseQueryText (Request -> ByteString
rawQueryString Request
req)
            in ([SomeFilter params] -> FilteringSpec params)
-> DelayedIO [SomeFilter params]
-> DelayedIO (FilteringSpec params)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [SomeFilter params] -> FilteringSpec params
forall (params :: [TyNamedFilter]).
[SomeFilter params] -> FilteringSpec params
FilteringSpec (DelayedIO [SomeFilter params] -> DelayedIO (FilteringSpec params))
-> (Either Text [SomeFilter params]
    -> DelayedIO [SomeFilter params])
-> Either Text [SomeFilter params]
-> DelayedIO (FilteringSpec params)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Text [SomeFilter params] -> DelayedIO [SomeFilter params]
forall a. Either Text a -> DelayedIO a
eitherToDelayed (Either Text [SomeFilter params]
 -> DelayedIO (FilteringSpec params))
-> Either Text [SomeFilter params]
-> DelayedIO (FilteringSpec params)
forall a b. (a -> b) -> a -> b
$
                   QueryText -> Either Text [SomeFilter params]
forall (params :: [TyNamedFilter]).
AreFilteringParams params =>
QueryText -> Either Text [SomeFilter params]
extractQueryParamsFilters @params QueryText
queryText
        eitherToDelayed :: Either Text a -> DelayedIO a
eitherToDelayed = \case
            Left Text
err -> ServerError -> DelayedIO a
forall a. ServerError -> DelayedIO a
delayedFailFatal ServerError
err400{ errBody :: ByteString
errBody = Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
err }
            Right a
x  -> a -> DelayedIO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x

    hoistServerWithContext :: Proxy (FilteringParams params :> subApi)
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT (FilteringParams params :> subApi) m
-> ServerT (FilteringParams params :> subApi) n
hoistServerWithContext Proxy (FilteringParams params :> subApi)
_ Proxy ctx
pm forall x. m x -> n x
hst ServerT (FilteringParams params :> subApi) m
s = Proxy subApi
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT subApi m
-> ServerT subApi n
forall k (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy subApi
forall k (t :: k). Proxy t
Proxy @subApi) Proxy ctx
pm forall x. m x -> n x
hst (ServerT subApi m -> ServerT subApi n)
-> (FilteringSpec params -> ServerT subApi m)
-> FilteringSpec params
-> ServerT subApi n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (FilteringParams params :> subApi) m
FilteringSpec params -> ServerT subApi m
s