module Servant.Util.Combinators.Tag
    ( Tag
    , TagDescriptions
    , TagsVerification (..)
    ) where

import Universum

import Control.Lens (at, (?~))
import qualified Data.HashSet.InsOrd as HS
import qualified Data.Swagger as S
import GHC.TypeLits (ErrorMessage (..), KnownSymbol, Symbol, TypeError)
import Servant (HasServer (..), StdMethod, Verb, (:<|>), (:>))
import Servant.Client (HasClient (..))
import Servant.Swagger (HasSwagger (..))

import Servant.Util.Combinators.Logging
import Servant.Util.Common

-- | Attaches a tag to swagger documentation.
-- Server implementation remains intact.
data Tag (name :: Symbol)

instance HasServer subApi ctx => HasServer (Tag name :> subApi) ctx where
    type ServerT (Tag name :> subApi) m = ServerT subApi m
    route :: Proxy (Tag name :> subApi)
-> Context ctx
-> Delayed env (Server (Tag name :> subApi))
-> Router env
route Proxy (Tag name :> subApi)
_ = 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)
    hoistServerWithContext :: Proxy (Tag name :> subApi)
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT (Tag name :> subApi) m
-> ServerT (Tag name :> subApi) n
hoistServerWithContext Proxy (Tag name :> subApi)
_ = 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)

instance HasClient m subApi => HasClient m (Tag name :> subApi) where
    type Client m (Tag name :> subApi) = Client m subApi
    clientWithRoute :: Proxy m
-> Proxy (Tag name :> subApi)
-> Request
-> Client m (Tag name :> subApi)
clientWithRoute Proxy m
pm Proxy (Tag name :> subApi)
_ = Proxy m -> Proxy subApi -> Request -> Client m subApi
forall (m :: * -> *) api.
HasClient m api =>
Proxy m -> Proxy api -> Request -> Client m api
clientWithRoute Proxy m
pm (Proxy subApi
forall k (t :: k). Proxy t
Proxy @subApi)
    hoistClientMonad :: Proxy m
-> Proxy (Tag name :> subApi)
-> (forall x. mon x -> mon' x)
-> Client mon (Tag name :> subApi)
-> Client mon' (Tag name :> subApi)
hoistClientMonad Proxy m
pm Proxy (Tag name :> subApi)
_ forall x. mon x -> mon' x
hst = Proxy m
-> Proxy subApi
-> (forall x. mon x -> mon' x)
-> Client mon subApi
-> Client mon' subApi
forall (m :: * -> *) api (mon :: * -> *) (mon' :: * -> *).
HasClient m api =>
Proxy m
-> Proxy api
-> (forall x. mon x -> mon' x)
-> Client mon api
-> Client mon' api
hoistClientMonad Proxy m
pm (Proxy subApi
forall k (t :: k). Proxy t
Proxy @subApi) forall x. mon x -> mon' x
hst

instance HasLoggingServer config lcontext subApi ctx =>
         HasLoggingServer config lcontext (Tag name :> subApi) ctx where
    routeWithLog :: Proxy (LoggingApiRec config lcontext (Tag name :> subApi))
-> Context ctx
-> Delayed
     env (Server (LoggingApiRec config lcontext (Tag name :> subApi)))
-> Router env
routeWithLog = (Proxy (Tag name :> LoggingApiRec config lcontext subApi)
 -> Context ctx
 -> Delayed
      env (Server (Tag name :> LoggingApiRec config lcontext subApi))
 -> Router env)
-> (Server (LoggingApiRec config lcontext (Tag name :> subApi))
    -> Server (Tag name :> LoggingApiRec config lcontext subApi))
-> Proxy (LoggingApiRec config lcontext (Tag name :> subApi))
-> Context ctx
-> Delayed
     env (Server (LoggingApiRec config lcontext (Tag name :> subApi)))
-> Router env
forall api api' (ctx :: [*]) env.
(Proxy api
 -> Context ctx -> Delayed env (Server api) -> Router env)
-> (Server api' -> Server api)
-> Proxy api'
-> Context ctx
-> Delayed env (Server api')
-> Router env
inRouteServer @(Tag name :> LoggingApiRec config lcontext subApi) Proxy (Tag name :> LoggingApiRec config lcontext subApi)
-> Context ctx
-> Delayed
     env (Server (Tag name :> LoggingApiRec config lcontext subApi))
-> Router env
forall k (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route Server (LoggingApiRec config lcontext (Tag name :> subApi))
-> Server (Tag name :> LoggingApiRec config lcontext subApi)
forall a. a -> a
id

instance (HasSwagger subApi, KnownSymbol name) =>
         HasSwagger (Tag name :> subApi) where
    toSwagger :: Proxy (Tag name :> subApi) -> Swagger
toSwagger Proxy (Tag name :> subApi)
_ = Proxy subApi -> Swagger
forall k (api :: k). HasSwagger api => Proxy api -> Swagger
toSwagger (Proxy subApi
forall k (t :: k). Proxy t
Proxy @subApi)
        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)
-> ((Maybe () -> Identity (Maybe ()))
    -> Operation -> Identity Operation)
-> (Maybe () -> Identity (Maybe ()))
-> Swagger
-> Identity Swagger
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InsOrdHashSet TagName -> Identity (InsOrdHashSet TagName))
-> Operation -> Identity Operation
forall s a. HasTags s a => Lens' s a
S.tags ((InsOrdHashSet TagName -> Identity (InsOrdHashSet TagName))
 -> Operation -> Identity Operation)
-> ((Maybe () -> Identity (Maybe ()))
    -> InsOrdHashSet TagName -> Identity (InsOrdHashSet TagName))
-> (Maybe () -> Identity (Maybe ()))
-> Operation
-> Identity Operation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (InsOrdHashSet TagName)
-> Lens'
     (InsOrdHashSet TagName) (Maybe (IxValue (InsOrdHashSet TagName)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at TagName
Index (InsOrdHashSet TagName)
name ((Maybe () -> Identity (Maybe ())) -> Swagger -> Identity Swagger)
-> () -> Swagger -> Swagger
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ ()
      where
        name :: TagName
name = KnownSymbol name => TagName
forall (s :: Symbol). KnownSymbol s => TagName
symbolValT @name

-- | Whether to enable some type-level checks for 'Tag's and 'TagsDescription's
-- correspondence.
data TagsVerification
    = -- | Ensure that mappings are specified exactly for those tags which
      -- appear in API.
      -- This may slow down compilation dramatically starting from ~15 tags.
      VerifyTags
      -- | Do not check anything.
    | NoVerifyTags

-- | Attaches descriptions to tags according to the given
-- @name -> description@ mapping.
-- Unused elements of mapping will cause a compile error; tags which have
-- no mapping declared are not allowed as well.
data TagDescriptions (verify :: TagsVerification) (mapping :: [TyNamedParam Symbol])

instance HasServer subApi ctx => HasServer (TagDescriptions ver mapping :> subApi) ctx where
    type ServerT (TagDescriptions ver mapping :> subApi) m = ServerT subApi m
    route :: Proxy (TagDescriptions ver mapping :> subApi)
-> Context ctx
-> Delayed env (Server (TagDescriptions ver mapping :> subApi))
-> Router env
route Proxy (TagDescriptions ver mapping :> subApi)
_ = 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)
    hoistServerWithContext :: Proxy (TagDescriptions ver mapping :> subApi)
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT (TagDescriptions ver mapping :> subApi) m
-> ServerT (TagDescriptions ver mapping :> subApi) n
hoistServerWithContext Proxy (TagDescriptions ver mapping :> subApi)
_ = 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)

instance HasClient m subApi => HasClient m (TagDescriptions ver mapping :> subApi) where
    type Client m (TagDescriptions ver mapping :> subApi) = Client m subApi
    clientWithRoute :: Proxy m
-> Proxy (TagDescriptions ver mapping :> subApi)
-> Request
-> Client m (TagDescriptions ver mapping :> subApi)
clientWithRoute Proxy m
pm Proxy (TagDescriptions ver mapping :> subApi)
_ = Proxy m -> Proxy subApi -> Request -> Client m subApi
forall (m :: * -> *) api.
HasClient m api =>
Proxy m -> Proxy api -> Request -> Client m api
clientWithRoute Proxy m
pm (Proxy subApi
forall k (t :: k). Proxy t
Proxy @subApi)
    hoistClientMonad :: Proxy m
-> Proxy (TagDescriptions ver mapping :> subApi)
-> (forall x. mon x -> mon' x)
-> Client mon (TagDescriptions ver mapping :> subApi)
-> Client mon' (TagDescriptions ver mapping :> subApi)
hoistClientMonad Proxy m
pm Proxy (TagDescriptions ver mapping :> subApi)
_ forall x. mon x -> mon' x
hst = Proxy m
-> Proxy subApi
-> (forall x. mon x -> mon' x)
-> Client mon subApi
-> Client mon' subApi
forall (m :: * -> *) api (mon :: * -> *) (mon' :: * -> *).
HasClient m api =>
Proxy m
-> Proxy api
-> (forall x. mon x -> mon' x)
-> Client mon api
-> Client mon' api
hoistClientMonad Proxy m
pm (Proxy subApi
forall k (t :: k). Proxy t
Proxy @subApi) forall x. mon x -> mon' x
hst

instance HasLoggingServer config context subApi ctx =>
         HasLoggingServer config context (TagDescriptions ver mapping :> subApi) ctx where
    routeWithLog :: Proxy
  (LoggingApiRec
     config context (TagDescriptions ver mapping :> subApi))
-> Context ctx
-> Delayed
     env
     (Server
        (LoggingApiRec
           config context (TagDescriptions ver mapping :> subApi)))
-> Router env
routeWithLog =
        (Proxy
   (TagDescriptions ver mapping
    :> LoggingApiRec config context subApi)
 -> Context ctx
 -> Delayed
      env
      (Server
         (TagDescriptions ver mapping
          :> LoggingApiRec config context subApi))
 -> Router env)
-> (Server
      (LoggingApiRec
         config context (TagDescriptions ver mapping :> subApi))
    -> Server
         (TagDescriptions ver mapping
          :> LoggingApiRec config context subApi))
-> Proxy
     (LoggingApiRec
        config context (TagDescriptions ver mapping :> subApi))
-> Context ctx
-> Delayed
     env
     (Server
        (LoggingApiRec
           config context (TagDescriptions ver mapping :> subApi)))
-> Router env
forall api api' (ctx :: [*]) env.
(Proxy api
 -> Context ctx -> Delayed env (Server api) -> Router env)
-> (Server api' -> Server api)
-> Proxy api'
-> Context ctx
-> Delayed env (Server api')
-> Router env
inRouteServer @(TagDescriptions ver mapping :> LoggingApiRec config context subApi)
        Proxy
  (TagDescriptions ver mapping
   :> LoggingApiRec config context subApi)
-> Context ctx
-> Delayed
     env
     (Server
        (TagDescriptions ver mapping
         :> LoggingApiRec config context subApi))
-> Router env
forall k (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route Server
  (LoggingApiRec
     config context (TagDescriptions ver mapping :> subApi))
-> Server
     (TagDescriptions ver mapping
      :> LoggingApiRec config context subApi)
forall a. a -> a
id

-- | Gather all tag names used in API. Result may contain duplicates.
type family AllApiTags api :: [Symbol] where
    AllApiTags (Tag name :> api) = name `InsSorted` AllApiTags api
    AllApiTags (arg :> api) = AllApiTags api
    AllApiTags ((path :: Symbol) :> api) = AllApiTags api
    AllApiTags (api1 :<|> api2) = AllApiTags api1 `UnionSorted` AllApiTags api2
    AllApiTags (Verb (method :: StdMethod) (code :: Nat) ctx a) = '[]

-- | Extract tags defined by this mapping.
class ReifyTagsFromMapping (mapping :: [TyNamedParam Symbol]) where
    reifyTagsFromMapping :: HS.InsOrdHashSet S.Tag

instance ReifyTagsFromMapping '[] where
    reifyTagsFromMapping :: InsOrdHashSet Tag
reifyTagsFromMapping = InsOrdHashSet Tag
forall a. Monoid a => a
mempty

instance ( KnownSymbol name, KnownSymbol desc
         , ReifyTagsFromMapping mapping
         , ParamsContainNoName mapping name
         ) =>
         ReifyTagsFromMapping ('TyNamedParam name desc ': mapping) where
    reifyTagsFromMapping :: InsOrdHashSet Tag
reifyTagsFromMapping =
        Tag :: TagName -> Maybe TagName -> Maybe ExternalDocs -> Tag
S.Tag
        { _tagName :: TagName
S._tagName = KnownSymbol name => TagName
forall (s :: Symbol). KnownSymbol s => TagName
symbolValT @name
        , _tagDescription :: Maybe TagName
S._tagDescription = TagName -> Maybe TagName
forall a. a -> Maybe a
Just (TagName -> Maybe TagName) -> TagName -> Maybe TagName
forall a b. (a -> b) -> a -> b
$ KnownSymbol desc => TagName
forall (s :: Symbol). KnownSymbol s => TagName
symbolValT @desc
        , _tagExternalDocs :: Maybe ExternalDocs
S._tagExternalDocs = Maybe ExternalDocs
forall a. Maybe a
Nothing
        } Tag -> InsOrdHashSet Tag -> InsOrdHashSet Tag
forall k.
(Eq k, Hashable k) =>
k -> InsOrdHashSet k -> InsOrdHashSet k
`HS.insert` ReifyTagsFromMapping mapping => InsOrdHashSet Tag
forall (mapping :: [TyNamedParam Symbol]).
ReifyTagsFromMapping mapping =>
InsOrdHashSet Tag
reifyTagsFromMapping @mapping

instance ( HasSwagger api
         , ReifyTagsFromMapping mapping
         ) =>
         HasSwagger (TagDescriptions 'NoVerifyTags mapping :> api) where
    toSwagger :: Proxy (TagDescriptions 'NoVerifyTags mapping :> api) -> Swagger
toSwagger Proxy (TagDescriptions 'NoVerifyTags mapping :> 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
& (InsOrdHashSet Tag -> Identity (InsOrdHashSet Tag))
-> Swagger -> Identity Swagger
forall s a. HasTags s a => Lens' s a
S.tags ((InsOrdHashSet Tag -> Identity (InsOrdHashSet Tag))
 -> Swagger -> Identity Swagger)
-> InsOrdHashSet Tag -> Swagger -> Swagger
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ReifyTagsFromMapping mapping => InsOrdHashSet Tag
forall (mapping :: [TyNamedParam Symbol]).
ReifyTagsFromMapping mapping =>
InsOrdHashSet Tag
reifyTagsFromMapping @mapping

instance ( HasSwagger api
         , ReifyTagsFromMapping mapping
         , missingMapping ~ (AllApiTags api // TyNamedParamsNames mapping)
         , If (missingMapping == '[])
            (() :: Constraint)
            (TypeError ('Text "Following tags have no mapping specified in \
                        \TagDescriptions: " ':<>: 'ShowType missingMapping))
         , extraMapping ~ (TyNamedParamsNames mapping // AllApiTags api)
         , If (extraMapping == '[])
            (() :: Constraint)
            (TypeError ('Text "Mappings for the following names specified in \
                              \TagDescriptions are unused: "
                        ':<>: 'ShowType extraMapping))
         ) =>
         HasSwagger (TagDescriptions 'VerifyTags mapping :> api) where
    toSwagger :: Proxy (TagDescriptions 'VerifyTags mapping :> api) -> Swagger
toSwagger Proxy (TagDescriptions 'VerifyTags mapping :> 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
& (InsOrdHashSet Tag -> Identity (InsOrdHashSet Tag))
-> Swagger -> Identity Swagger
forall s a. HasTags s a => Lens' s a
S.tags ((InsOrdHashSet Tag -> Identity (InsOrdHashSet Tag))
 -> Swagger -> Identity Swagger)
-> InsOrdHashSet Tag -> Swagger -> Swagger
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ReifyTagsFromMapping mapping => InsOrdHashSet Tag
forall (mapping :: [TyNamedParam Symbol]).
ReifyTagsFromMapping mapping =>
InsOrdHashSet Tag
reifyTagsFromMapping @mapping