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

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

import Universum

import Control.Lens ((<>~), (?~))
import qualified Data.Swagger as S
import qualified Data.Text as T
import Fmt (build, fmt, unlinesF)
import Servant.API ((:>))
import Servant.Swagger (HasSwagger (..))

import Servant.Util.Combinators.Sorting.Base
import Servant.Util.Common

instance (HasSwagger api, ReifySortingItems base, ReifyParamsNames provided) =>
         HasSwagger (SortingParams provided base :> api) where
    toSwagger :: Proxy (SortingParams provided base :> api) -> Swagger
toSwagger Proxy (SortingParams provided base :> 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
forall a. a -> Referenced a
S.Inline Param
param]
      where
        param :: Param
param = Param
forall a. Monoid a => a
mempty
            Param -> (Param -> Param) -> Param
forall a b. a -> (a -> b) -> b
& (Text -> Identity Text) -> Param -> Identity Param
forall s a. HasName s a => Lens' s a
S.name ((Text -> Identity Text) -> Param -> Identity Param)
-> Text -> Param -> Param
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text
"sortBy"
            Param -> (Param -> Param) -> Param
forall a b. a -> (a -> b) -> b
& (Maybe Text -> Identity (Maybe Text)) -> Param -> Identity Param
forall s a. HasDescription s a => Lens' s a
S.description ((Maybe Text -> Identity (Maybe Text)) -> Param -> Identity Param)
-> Text -> Param -> Param
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Builder -> Text
forall b. FromBuilder b => Builder -> b
fmt do
              [Builder] -> Builder
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
unlinesF
                [ Builder
"Allows lexicographical sorting on fields."
                , Builder
"General format is one of:"
                , Builder
"  * `+field1,-field2`"
                , Builder
"  * `asc(field1),desc(field2)`"
                , Builder
""
                , Builder
allowedFieldsDesc
                , Builder
baseFieldsDesc
                , Builder
" "
                ]
            Param -> (Param -> Param) -> Param
forall a b. a -> (a -> b) -> b
& (Maybe Bool -> Identity (Maybe Bool)) -> Param -> Identity Param
forall s a. HasRequired s a => Lens' s a
S.required ((Maybe Bool -> Identity (Maybe Bool)) -> Param -> Identity Param)
-> Bool -> Param -> Param
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Bool
False
            Param -> (Param -> Param) -> Param
forall a b. a -> (a -> b) -> b
& (ParamAnySchema -> Identity ParamAnySchema)
-> Param -> Identity Param
forall s a. HasSchema s a => Lens' s a
S.schema ((ParamAnySchema -> Identity ParamAnySchema)
 -> Param -> Identity Param)
-> ParamAnySchema -> Param -> Param
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ParamOtherSchema -> ParamAnySchema
S.ParamOther (ParamOtherSchema
forall a. Monoid a => a
mempty
                ParamOtherSchema
-> (ParamOtherSchema -> ParamOtherSchema) -> ParamOtherSchema
forall a b. a -> (a -> b) -> b
& (ParamLocation -> Identity ParamLocation)
-> ParamOtherSchema -> Identity ParamOtherSchema
forall s a. HasIn s a => Lens' s a
S.in_ ((ParamLocation -> Identity ParamLocation)
 -> ParamOtherSchema -> Identity ParamOtherSchema)
-> ParamLocation -> ParamOtherSchema -> ParamOtherSchema
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ParamLocation
S.ParamQuery
                ParamOtherSchema
-> (ParamOtherSchema -> ParamOtherSchema) -> ParamOtherSchema
forall a b. a -> (a -> b) -> b
& (ParamSchema 'SwaggerKindParamOtherSchema
 -> Identity (ParamSchema 'SwaggerKindParamOtherSchema))
-> ParamOtherSchema -> Identity ParamOtherSchema
forall s a. HasParamSchema s a => Lens' s a
S.paramSchema ((ParamSchema 'SwaggerKindParamOtherSchema
  -> Identity (ParamSchema 'SwaggerKindParamOtherSchema))
 -> ParamOtherSchema -> Identity ParamOtherSchema)
-> ParamSchema 'SwaggerKindParamOtherSchema
-> ParamOtherSchema
-> ParamOtherSchema
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ParamSchema 'SwaggerKindParamOtherSchema
paramSchema
                )
        paramSchema :: ParamSchema 'SwaggerKindParamOtherSchema
paramSchema = ParamSchema 'SwaggerKindParamOtherSchema
forall a. Monoid a => a
mempty
            ParamSchema 'SwaggerKindParamOtherSchema
-> (ParamSchema 'SwaggerKindParamOtherSchema
    -> ParamSchema 'SwaggerKindParamOtherSchema)
-> ParamSchema 'SwaggerKindParamOtherSchema
forall a b. a -> (a -> b) -> b
& (Maybe (SwaggerType 'SwaggerKindParamOtherSchema)
 -> Identity (Maybe (SwaggerType 'SwaggerKindParamOtherSchema)))
-> ParamSchema 'SwaggerKindParamOtherSchema
-> Identity (ParamSchema 'SwaggerKindParamOtherSchema)
forall s a. HasType s a => Lens' s a
S.type_ ((Maybe (SwaggerType 'SwaggerKindParamOtherSchema)
  -> Identity (Maybe (SwaggerType 'SwaggerKindParamOtherSchema)))
 -> ParamSchema 'SwaggerKindParamOtherSchema
 -> Identity (ParamSchema 'SwaggerKindParamOtherSchema))
-> SwaggerType 'SwaggerKindParamOtherSchema
-> ParamSchema 'SwaggerKindParamOtherSchema
-> ParamSchema 'SwaggerKindParamOtherSchema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ SwaggerType 'SwaggerKindParamOtherSchema
forall (t :: SwaggerKind *). SwaggerType t
S.SwaggerString
            ParamSchema 'SwaggerKindParamOtherSchema
-> (ParamSchema 'SwaggerKindParamOtherSchema
    -> ParamSchema 'SwaggerKindParamOtherSchema)
-> ParamSchema 'SwaggerKindParamOtherSchema
forall a b. a -> (a -> b) -> b
& (Maybe Text -> Identity (Maybe Text))
-> ParamSchema 'SwaggerKindParamOtherSchema
-> Identity (ParamSchema 'SwaggerKindParamOtherSchema)
forall s a. HasPattern s a => Lens' s a
S.pattern ((Maybe Text -> Identity (Maybe Text))
 -> ParamSchema 'SwaggerKindParamOtherSchema
 -> Identity (ParamSchema 'SwaggerKindParamOtherSchema))
-> Text
-> ParamSchema 'SwaggerKindParamOtherSchema
-> ParamSchema 'SwaggerKindParamOtherSchema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Text
"^" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fieldPattern Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"(," Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fieldPattern Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")*" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"$"
        fieldPattern :: Text
fieldPattern =
            Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"[+-](" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
allowedFieldsPattern Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")+" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"|" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
            Text
"(asc|desc)\\((" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
allowedFieldsPattern Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")+\\))"
        allowedFields :: [Text]
allowedFields = ReifyParamsNames provided => [Text]
forall k (params :: [TyNamedParam k]).
ReifyParamsNames params =>
[Text]
reifyParamsNames @provided
        allowedFieldsDesc :: Builder
allowedFieldsDesc = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
            [ Builder
" Fields allowed for this endpoint: "
            , [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder)
-> ([Builder] -> [Builder]) -> [Builder] -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperse Builder
", " ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$
                  (Text -> Builder) -> [Text] -> [Builder]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map ((Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"`") (Builder -> Builder) -> (Text -> Builder) -> Text -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Builder
"`" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>) (Builder -> Builder) -> (Text -> Builder) -> Text -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Builder
forall p. Buildable p => p -> Builder
build) [Text]
allowedFields
            ]
        allowedFieldsPattern :: Text
allowedFieldsPattern = Text -> [Text] -> Text
T.intercalate Text
"|" [Text]
allowedFields
        baseFields :: [SortingItem]
baseFields = ReifySortingItems base => [SortingItem]
forall (items :: [TyNamedParam (SortingOrderType *)]).
ReifySortingItems items =>
[SortingItem]
reifySortingItems @base
        baseFieldsDesc :: Builder
baseFieldsDesc
            | [SortingItem] -> Bool
forall t. Container t => t -> Bool
null [SortingItem]
baseFields = Builder
""
            | Bool
otherwise = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
                [ Builder
" Base sorting (always applied, lexicographically last): "
                , Builder
"`"
                , [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder)
-> ([Builder] -> [Builder]) -> [Builder] -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperse Builder
", " ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ (SortingItem -> Builder) -> [SortingItem] -> [Builder]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map SortingItem -> Builder
forall p. Buildable p => p -> Builder
build [SortingItem]
baseFields
                , Builder
"`"
                ]