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

module Servant.Util.Combinators.Filtering.Swagger () where

import Universum

import Control.Lens ((<>~))
import qualified Data.Swagger as S
import qualified Data.Text as T
import GHC.TypeLits (KnownSymbol)
import Servant.API ((:>))
import Servant.Swagger (HasSwagger (..))

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

-- | Make a 'S.Param' for a filtering query parameter.
filterSwaggerParam :: forall a. S.ToParamSchema a => Text -> Text -> S.Param
filterSwaggerParam :: Text -> Text -> Param
filterSwaggerParam Text
name Text
desc =
    Param :: Text -> Maybe Text -> Maybe Bool -> ParamAnySchema -> Param
S.Param
    { _paramName :: Text
S._paramName = Text
name
    , _paramDescription :: Maybe Text
S._paramDescription = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
desc
    , _paramRequired :: Maybe Bool
S._paramRequired = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
    , _paramSchema :: ParamAnySchema
S._paramSchema = ParamOtherSchema -> ParamAnySchema
S.ParamOther ParamOtherSchema :: ParamLocation
-> Maybe Bool
-> ParamSchema 'SwaggerKindParamOtherSchema
-> ParamOtherSchema
S.ParamOtherSchema
        { _paramOtherSchemaIn :: ParamLocation
S._paramOtherSchemaIn = ParamLocation
S.ParamQuery
        , _paramOtherSchemaAllowEmptyValue :: Maybe Bool
S._paramOtherSchemaAllowEmptyValue = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
        , _paramOtherSchemaParamSchema :: ParamSchema 'SwaggerKindParamOtherSchema
S._paramOtherSchemaParamSchema = Proxy a -> ParamSchema 'SwaggerKindParamOtherSchema
forall a (t :: SwaggerKind *).
ToParamSchema a =>
Proxy a -> ParamSchema t
S.toParamSchema (Proxy a
forall k (t :: k). Proxy t
Proxy @a)
        }
    }

parenValueDesc :: forall a. KnownSymbol (ParamDescription a) => Text
parenValueDesc :: Text
parenValueDesc = Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
stripTrailingDot (KnownSymbol (ParamDescription a) => Text
forall (s :: Symbol). KnownSymbol s => Text
symbolValT @(ParamDescription a)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
  where
    stripTrailingDot :: Text -> Text
stripTrailingDot Text
t = Text -> Text -> Maybe Text
T.stripSuffix Text
"." Text
t Maybe Text -> Text -> Text
forall a. Maybe a -> a -> a
?: Text
t

autoFilterDesc :: forall a. KnownSymbol (ParamDescription a) => OpsDescriptions -> Text
autoFilterDesc :: OpsDescriptions -> Text
autoFilterDesc OpsDescriptions
ops = Text
fullDesc
  where
    opsDesc :: [Text]
opsDesc
        | [(Text
DefFilteringCmd, Text
_)] <- OpsDescriptions
ops = []
        | Bool
otherwise =
            Text
"You can specify a custom filtering operation in `param[op]=value` \
            \or `param_op=value` format." Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:
            Text
"Allowed operations:" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:
            (OpsDescriptions
ops OpsDescriptions -> ((Text, Text) -> Text) -> [Text]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Text
op, Text
engDesc) -> Text
"* `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
op Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"` (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
engDesc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")

    noDefaultOpWarn :: [Text]
noDefaultOpWarn =
        [ () | Maybe (Text, Text)
Nothing <- Maybe (Text, Text) -> [Maybe (Text, Text)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Text, Text) -> [Maybe (Text, Text)])
-> Maybe (Text, Text) -> [Maybe (Text, Text)]
forall a b. (a -> b) -> a -> b
$ (Element OpsDescriptions -> Bool)
-> OpsDescriptions -> Maybe (Element OpsDescriptions)
forall t.
Container t =>
(Element t -> Bool) -> t -> Maybe (Element t)
find ((Text
DefFilteringCmd Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== ) (Text -> Bool) -> ((Text, Text) -> Text) -> (Text, Text) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Text) -> Text
forall a b. (a, b) -> a
fst) OpsDescriptions
ops ]
      [()] -> [Text] -> [Text]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
        [ Text
""
        , Text
"_NB: Specifying filtering operation is mandatory for this parameter!_"
        ]

    fullDesc :: Text
fullDesc = [Text] -> Text
unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
        [ Text
"Filter values according to provided operation " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> KnownSymbol (ParamDescription a) => Text
forall a. KnownSymbol (ParamDescription a) => Text
parenValueDesc @a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."
        ] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
opsDesc
          [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
noDefaultOpWarn

manualFilterDesc :: forall a. KnownSymbol (ParamDescription a) => Text
manualFilterDesc :: Text
manualFilterDesc =
    Text
"Leave values matching given parameter " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> KnownSymbol (ParamDescription a) => Text
forall a. KnownSymbol (ParamDescription a) => Text
parenValueDesc @a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."

-- | Gather swagger params for all of the given filters.
class AutoFiltersOpsDesc (filters :: [Type -> Type]) where
    autoFiltersOpsDesc :: OpsDescriptions

instance AutoFiltersOpsDesc '[] where
    autoFiltersOpsDesc :: OpsDescriptions
autoFiltersOpsDesc = OpsDescriptions
forall a. Monoid a => a
mempty

instance ( IsAutoFilter filter
         , AutoFiltersOpsDesc filters
         ) =>
         AutoFiltersOpsDesc (filter ': filters) where
    autoFiltersOpsDesc :: OpsDescriptions
autoFiltersOpsDesc = [OpsDescriptions] -> OpsDescriptions
forall a. Monoid a => [a] -> a
mconcat
        [ IsAutoFilter filter => OpsDescriptions
forall (filter :: * -> *). IsAutoFilter filter => OpsDescriptions
autoFilterEnglishOpsNames @filter
        , AutoFiltersOpsDesc filters => OpsDescriptions
forall (filters :: [* -> *]).
AutoFiltersOpsDesc filters =>
OpsDescriptions
autoFiltersOpsDesc @filters
        ]

-- | Get documentation for the given filter kind.
class FilterKindHasSwagger (fk :: FilterKind Type) where
    filterKindSwagger :: Text -> S.Param

instance DescribedParam a => FilterKindHasSwagger ('ManualFilter a) where
    filterKindSwagger :: Text -> Param
filterKindSwagger Text
name = Text -> Text -> Param
forall a. ToParamSchema a => Text -> Text -> Param
filterSwaggerParam @a Text
name (KnownSymbol (ParamDescription a) => Text
forall a. KnownSymbol (ParamDescription a) => Text
manualFilterDesc @a)

instance (DescribedParam a, AutoFiltersOpsDesc (SupportedFilters a)) =>
         FilterKindHasSwagger ('AutoFilter a) where
    filterKindSwagger :: Text -> Param
filterKindSwagger Text
name = Text -> Text -> Param
forall a. ToParamSchema a => Text -> Text -> Param
filterSwaggerParam @a Text
name (OpsDescriptions -> Text
forall a.
KnownSymbol (ParamDescription a) =>
OpsDescriptions -> Text
autoFilterDesc @a OpsDescriptions
ops)
      where
        ops :: OpsDescriptions
ops = AutoFiltersOpsDesc (SupportedFilters a) => OpsDescriptions
forall (filters :: [* -> *]).
AutoFiltersOpsDesc filters =>
OpsDescriptions
autoFiltersOpsDesc @(SupportedFilters a)

-- | Get documentation for given filtering params.
class FilterParamsHaveSwagger (params :: [TyNamedFilter]) where
    filterParamsSwagger :: [S.Param]

instance FilterParamsHaveSwagger '[] where
    filterParamsSwagger :: [Param]
filterParamsSwagger = [Param]
forall a. Monoid a => a
mempty

instance ( KnownSymbol name, FilterKindHasSwagger fk
         , FilterParamsHaveSwagger params
         ) =>
         FilterParamsHaveSwagger ('TyNamedParam name fk ': params) where
    filterParamsSwagger :: [Param]
filterParamsSwagger =
        Text -> Param
forall (fk :: FilterKind *).
FilterKindHasSwagger fk =>
Text -> Param
filterKindSwagger @fk (KnownSymbol name => Text
forall (s :: Symbol). KnownSymbol s => Text
symbolValT @name) Param -> [Param] -> [Param]
forall a. a -> [a] -> [a]
: FilterParamsHaveSwagger params => [Param]
forall (params :: [TyNamedFilter]).
FilterParamsHaveSwagger params =>
[Param]
filterParamsSwagger @params

instance (HasSwagger api, ReifyParamsNames params, FilterParamsHaveSwagger params) =>
         HasSwagger (FilteringParams params :> api) where
    toSwagger :: Proxy (FilteringParams params :> api) -> Swagger
toSwagger Proxy (FilteringParams params :> api)
_ = Proxy api -> Swagger
forall k (api :: k). HasSwagger api => Proxy api -> Swagger
toSwagger (Proxy api
forall k (t :: k). Proxy t
Proxy @api)
        Swagger -> (Swagger -> Swagger) -> Swagger
forall a b. a -> (a -> b) -> b
& (Operation -> Identity Operation) -> Swagger -> Identity Swagger
Traversal' Swagger Operation
S.allOperations ((Operation -> Identity Operation) -> Swagger -> Identity Swagger)
-> (([Referenced Param] -> Identity [Referenced Param])
    -> Operation -> Identity Operation)
-> ([Referenced Param] -> Identity [Referenced Param])
-> Swagger
-> Identity Swagger
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Referenced Param] -> Identity [Referenced Param])
-> Operation -> Identity Operation
forall s a. HasParameters s a => Lens' s a
S.parameters (([Referenced Param] -> Identity [Referenced Param])
 -> Swagger -> Identity Swagger)
-> [Referenced Param] -> Swagger -> Swagger
forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ (Param -> Referenced Param) -> [Param] -> [Referenced Param]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Param -> Referenced Param
forall a. a -> Referenced a
S.Inline (FilterParamsHaveSwagger params => [Param]
forall (params :: [TyNamedFilter]).
FilterParamsHaveSwagger params =>
[Param]
filterParamsSwagger @params)