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
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
data TagsVerification
=
VerifyTags
| NoVerifyTags
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
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) = '[]
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