module Servant.Util.Swagger
    ( ParamDescription
    , DescribedParam
    , paramDescription

    , QueryFlagDescription

    , SwaggerrizeApi
    ) where

import Universum

import Control.Exception (assert)
import Control.Lens (_head, ix, makePrisms, zoom, (?=))
import qualified Data.Swagger as S
import GHC.TypeLits (KnownSymbol, Symbol)
import Servant (Capture', Description, EmptyAPI, NoContent, QueryFlag, QueryParam', Raw, StdMethod,
                Verb, (:<|>), (:>))
import Servant.Swagger (HasSwagger (..))

import Servant.Util.Common

makePrisms ''S.Referenced

----------------------------------------------------------------------------
-- Parameter description
----------------------------------------------------------------------------

-- | Description of parameter.
--
-- Unfortunatelly, @servant-swagger@ package, when deriving description of
-- an endpoint parameter, fills its description for you and makes you implement
-- just 'ParamSchema' which has no description field.
-- To circumvent that you can define description in instance of this type family
-- and later override swagger derivation accordingly.
type family ParamDescription a :: Symbol

type DescribedParam a = (S.ToParamSchema a, KnownSymbol (ParamDescription a))

-- | Set description according to 'ParamDescription' definition.
paramDescription
    :: forall a proxy.
       KnownSymbol (ParamDescription a)
    => proxy a -> Text
paramDescription :: proxy a -> Text
paramDescription proxy a
_ = KnownSymbol (ParamDescription a) => Text
forall (s :: Symbol). KnownSymbol s => Text
symbolValT @(ParamDescription a)

----------------------------------------------------------------------------
-- Capture description
----------------------------------------------------------------------------

-- | Like 'Capture', but does not modify description of 404 error (which looks
-- pretty like robot-generated).
-- See 'Servant.Util.Combinators.ErrorResponses' module for manual errors
-- definition.
data SwaggerCapture (mods :: [*]) (sym :: Symbol) a

instance (HasSwagger (Capture' mods sym a :> api), HasSwagger api) =>
         HasSwagger (SwaggerCapture mods sym a :> api) where
    toSwagger :: Proxy (SwaggerCapture mods sym a :> api) -> Swagger
toSwagger Proxy (SwaggerCapture mods sym a :> api)
_ =
        Proxy (Capture' mods sym a :> api) -> Swagger
forall k (api :: k). HasSwagger api => Proxy api -> Swagger
toSwagger (Proxy (Capture' mods sym a :> api)
forall k (t :: k). Proxy t
Proxy @(Capture' mods sym a :> api))
            Swagger -> (Swagger -> Swagger) -> Swagger
forall a b. a -> (a -> b) -> b
& (Text -> Identity Text) -> Swagger -> Identity Swagger
Traversal' Swagger Text
desc404L ((Text -> Identity Text) -> Swagger -> Identity Swagger)
-> Text -> Swagger -> Swagger
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" Maybe Text
pureDesc404
      where
        desc404L :: Traversal' S.Swagger Text
        desc404L :: (Text -> f Text) -> Swagger -> f Swagger
desc404L = (Operation -> f Operation) -> Swagger -> f Swagger
Traversal' Swagger Operation
S.allOperations ((Operation -> f Operation) -> Swagger -> f Swagger)
-> ((Text -> f Text) -> Operation -> f Operation)
-> (Text -> f Text)
-> Swagger
-> f Swagger
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Responses -> f Responses) -> Operation -> f Operation
forall s a. HasResponses s a => Lens' s a
S.responses ((Responses -> f Responses) -> Operation -> f Operation)
-> ((Text -> f Text) -> Responses -> f Responses)
-> (Text -> f Text)
-> Operation
-> f Operation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InsOrdHashMap HttpStatusCode (Referenced Response)
 -> f (InsOrdHashMap HttpStatusCode (Referenced Response)))
-> Responses -> f Responses
forall s a. HasResponses s a => Lens' s a
S.responses ((InsOrdHashMap HttpStatusCode (Referenced Response)
  -> f (InsOrdHashMap HttpStatusCode (Referenced Response)))
 -> Responses -> f Responses)
-> ((Text -> f Text)
    -> InsOrdHashMap HttpStatusCode (Referenced Response)
    -> f (InsOrdHashMap HttpStatusCode (Referenced Response)))
-> (Text -> f Text)
-> Responses
-> f Responses
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                   Index (InsOrdHashMap HttpStatusCode (Referenced Response))
-> Traversal'
     (InsOrdHashMap HttpStatusCode (Referenced Response))
     (IxValue (InsOrdHashMap HttpStatusCode (Referenced Response)))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Index (InsOrdHashMap HttpStatusCode (Referenced Response))
404 ((Referenced Response -> f (Referenced Response))
 -> InsOrdHashMap HttpStatusCode (Referenced Response)
 -> f (InsOrdHashMap HttpStatusCode (Referenced Response)))
-> ((Text -> f Text)
    -> Referenced Response -> f (Referenced Response))
-> (Text -> f Text)
-> InsOrdHashMap HttpStatusCode (Referenced Response)
-> f (InsOrdHashMap HttpStatusCode (Referenced Response))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Response -> f Response)
-> Referenced Response -> f (Referenced Response)
forall a a. Prism (Referenced a) (Referenced a) a a
_Inline ((Response -> f Response)
 -> Referenced Response -> f (Referenced Response))
-> ((Text -> f Text) -> Response -> f Response)
-> (Text -> f Text)
-> Referenced Response
-> f (Referenced Response)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> f Text) -> Response -> f Response
forall s a. HasDescription s a => Lens' s a
S.description
        pureDesc404 :: Maybe Text
pureDesc404 = Proxy api -> Swagger
forall k (api :: k). HasSwagger api => Proxy api -> Swagger
toSwagger (Proxy api
forall k (t :: k). Proxy t
Proxy @api) Swagger -> Getting (First Text) Swagger Text -> Maybe Text
forall s a. s -> Getting (First a) s a -> Maybe a
^? Getting (First Text) Swagger Text
Traversal' Swagger Text
desc404L

----------------------------------------------------------------------------
-- QueryParam description
----------------------------------------------------------------------------

-- | Like 'QueryParam', but does not modify description of 404 error.
-- See 'Servant.Util.Combinators.ErrorResponses' module for manual errors
-- definition.
data SwaggerQueryParam (mods :: [*]) (sym :: Symbol) a

instance (HasSwagger (QueryParam' mods sym a :> api), HasSwagger api) =>
         HasSwagger (SwaggerQueryParam mods sym a :> api) where
    toSwagger :: Proxy (SwaggerQueryParam mods sym a :> api) -> Swagger
toSwagger Proxy (SwaggerQueryParam mods sym a :> api)
_ =
        Proxy (QueryParam' mods sym a :> api) -> Swagger
forall k (api :: k). HasSwagger api => Proxy api -> Swagger
toSwagger (Proxy (QueryParam' mods sym a :> api)
forall k (t :: k). Proxy t
Proxy @(QueryParam' mods sym a :> api))
            Swagger -> (Swagger -> Swagger) -> Swagger
forall a b. a -> (a -> b) -> b
& (Text -> Identity Text) -> Swagger -> Identity Swagger
Traversal' Swagger Text
desc404L ((Text -> Identity Text) -> Swagger -> Identity Swagger)
-> Text -> Swagger -> Swagger
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" Maybe Text
pureDesc404
      where
        desc404L :: Traversal' S.Swagger Text
        desc404L :: (Text -> f Text) -> Swagger -> f Swagger
desc404L = (Operation -> f Operation) -> Swagger -> f Swagger
Traversal' Swagger Operation
S.allOperations ((Operation -> f Operation) -> Swagger -> f Swagger)
-> ((Text -> f Text) -> Operation -> f Operation)
-> (Text -> f Text)
-> Swagger
-> f Swagger
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Responses -> f Responses) -> Operation -> f Operation
forall s a. HasResponses s a => Lens' s a
S.responses ((Responses -> f Responses) -> Operation -> f Operation)
-> ((Text -> f Text) -> Responses -> f Responses)
-> (Text -> f Text)
-> Operation
-> f Operation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InsOrdHashMap HttpStatusCode (Referenced Response)
 -> f (InsOrdHashMap HttpStatusCode (Referenced Response)))
-> Responses -> f Responses
forall s a. HasResponses s a => Lens' s a
S.responses ((InsOrdHashMap HttpStatusCode (Referenced Response)
  -> f (InsOrdHashMap HttpStatusCode (Referenced Response)))
 -> Responses -> f Responses)
-> ((Text -> f Text)
    -> InsOrdHashMap HttpStatusCode (Referenced Response)
    -> f (InsOrdHashMap HttpStatusCode (Referenced Response)))
-> (Text -> f Text)
-> Responses
-> f Responses
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                   Index (InsOrdHashMap HttpStatusCode (Referenced Response))
-> Traversal'
     (InsOrdHashMap HttpStatusCode (Referenced Response))
     (IxValue (InsOrdHashMap HttpStatusCode (Referenced Response)))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Index (InsOrdHashMap HttpStatusCode (Referenced Response))
404 ((Referenced Response -> f (Referenced Response))
 -> InsOrdHashMap HttpStatusCode (Referenced Response)
 -> f (InsOrdHashMap HttpStatusCode (Referenced Response)))
-> ((Text -> f Text)
    -> Referenced Response -> f (Referenced Response))
-> (Text -> f Text)
-> InsOrdHashMap HttpStatusCode (Referenced Response)
-> f (InsOrdHashMap HttpStatusCode (Referenced Response))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Response -> f Response)
-> Referenced Response -> f (Referenced Response)
forall a a. Prism (Referenced a) (Referenced a) a a
_Inline ((Response -> f Response)
 -> Referenced Response -> f (Referenced Response))
-> ((Text -> f Text) -> Response -> f Response)
-> (Text -> f Text)
-> Referenced Response
-> f (Referenced Response)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> f Text) -> Response -> f Response
forall s a. HasDescription s a => Lens' s a
S.description
        pureDesc404 :: Maybe Text
pureDesc404 = Proxy api -> Swagger
forall k (api :: k). HasSwagger api => Proxy api -> Swagger
toSwagger (Proxy api
forall k (t :: k). Proxy t
Proxy @api) Swagger -> Getting (First Text) Swagger Text -> Maybe Text
forall s a. s -> Getting (First a) s a -> Maybe a
^? Getting (First Text) Swagger Text
Traversal' Swagger Text
desc404L

----------------------------------------------------------------------------
-- Query flag description
----------------------------------------------------------------------------

-- | Defines swagger description for the given `QueryFlag` parameter.
type family QueryFlagDescription (name :: Symbol) :: Symbol

-- | Replacement for 'QueryFlag' which has a better documentation.
data SwaggerQueryFlag (name :: Symbol)

type instance QueryFlagDescription "onlyCount" =
    "If this parameter is present, return only the total count of items."

instance (HasSwagger subApi, KnownSymbol name, KnownSymbol (QueryFlagDescription name)) =>
         HasSwagger (SwaggerQueryFlag name :> subApi) where
    toSwagger :: Proxy (SwaggerQueryFlag name :> subApi) -> Swagger
toSwagger Proxy (SwaggerQueryFlag name :> subApi)
_ = Proxy (QueryFlag name :> subApi) -> Swagger
forall k (api :: k). HasSwagger api => Proxy api -> Swagger
toSwagger (Proxy (QueryFlag name :> subApi)
forall k (t :: k). Proxy t
Proxy @(QueryFlag name :> subApi)) Swagger -> State Swagger () -> Swagger
forall s a. s -> State s a -> s
`executingState` do
        LensLike' (Zoomed (StateT Param Identity) ()) Swagger Param
-> StateT Param Identity () -> State Swagger ()
forall (m :: * -> *) (n :: * -> *) s t c.
Zoom m n s t =>
LensLike' (Zoomed m c) t s -> m c -> n c
zoom ((Operation -> Focusing Identity () Operation)
-> Swagger -> Focusing Identity () Swagger
Traversal' Swagger Operation
S.allOperations ((Operation -> Focusing Identity () Operation)
 -> Swagger -> Focusing Identity () Swagger)
-> ((Param -> Focusing Identity () Param)
    -> Operation -> Focusing Identity () Operation)
-> (Param -> Focusing Identity () Param)
-> Swagger
-> Focusing Identity () Swagger
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Referenced Param] -> Focusing Identity () [Referenced Param])
-> Operation -> Focusing Identity () Operation
forall s a. HasParameters s a => Lens' s a
S.parameters (([Referenced Param] -> Focusing Identity () [Referenced Param])
 -> Operation -> Focusing Identity () Operation)
-> ((Param -> Focusing Identity () Param)
    -> [Referenced Param] -> Focusing Identity () [Referenced Param])
-> (Param -> Focusing Identity () Param)
-> Operation
-> Focusing Identity () Operation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Referenced Param -> Focusing Identity () (Referenced Param))
-> [Referenced Param] -> Focusing Identity () [Referenced Param]
forall s a. Cons s s a a => Traversal' s a
_head ((Referenced Param -> Focusing Identity () (Referenced Param))
 -> [Referenced Param] -> Focusing Identity () [Referenced Param])
-> ((Param -> Focusing Identity () Param)
    -> Referenced Param -> Focusing Identity () (Referenced Param))
-> (Param -> Focusing Identity () Param)
-> [Referenced Param]
-> Focusing Identity () [Referenced Param]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Param -> Focusing Identity () Param)
-> Referenced Param -> Focusing Identity () (Referenced Param)
forall a a. Prism (Referenced a) (Referenced a) a a
_Inline) (StateT Param Identity () -> State Swagger ())
-> StateT Param Identity () -> State Swagger ()
forall a b. (a -> b) -> a -> b
$ do
            Text
paramName <- Getting Text Param Text -> StateT Param Identity Text
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Text Param Text
forall s a. HasName s a => Lens' s a
S.name
            Bool -> StateT Param Identity () -> StateT Param Identity ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
paramName) StateT Param Identity ()
forall (f :: * -> *). Applicative f => f ()
pass
            (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 -> StateT Param Identity ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a (Maybe b) -> b -> m ()
?= Text
desc
      where
        name :: Text
name = KnownSymbol name => Text
forall (s :: Symbol). KnownSymbol s => Text
symbolValT @name
        desc :: Text
desc = KnownSymbol (QueryFlagDescription name) => Text
forall (s :: Symbol). KnownSymbol s => Text
symbolValT @(QueryFlagDescription name)

----------------------------------------------------------------------------
-- Global
----------------------------------------------------------------------------

{- | This applies following transformations to API for the sake of better swagger
documentation.

* Response of methods returning `()` is replaced with `NoContents` (otherwise invalid
swagger is generated).

* `Capture`s and `QueryParam`s are attached a description according to
'ParamDescription' type family (default description is empty).

* @QueryFlag name@ occurences are attached descriptions according to
@ParamsDescription (QueryFlagDescription name)@ (there was no description by default).
-}
type family SwaggerrizeApi api where
    SwaggerrizeApi ((path :: Symbol) :> api) =
        path :> SwaggerrizeApi api

    SwaggerrizeApi (Capture' mods sym a :> api) =
        SwaggerCapture (Description (ParamDescription a) ': mods) sym a :> SwaggerrizeApi api

    SwaggerrizeApi (QueryParam' mods sym a :> api) =
        SwaggerQueryParam (Description (ParamDescription a) ': mods) sym a
        :> SwaggerrizeApi api

    SwaggerrizeApi (QueryFlag name :> api) =
        SwaggerQueryFlag name :> SwaggerrizeApi api

    SwaggerrizeApi (arg :> api) =
        arg :> SwaggerrizeApi api

    SwaggerrizeApi (api1 :<|> api2) =
        SwaggerrizeApi api1 :<|> SwaggerrizeApi api2

    SwaggerrizeApi (Verb (method :: StdMethod) (code :: Nat) ctx ()) =
        Verb method code ctx NoContent

    SwaggerrizeApi (Verb (method :: StdMethod) (code :: Nat) ctx a) =
        Verb method code ctx a

    SwaggerrizeApi Raw = Raw

    SwaggerrizeApi EmptyAPI = EmptyAPI