{-# OPTIONS_GHC -Wno-redundant-constraints #-}
module Wire.API.Routes.Named where
import Control.Lens ((%~))
import Data.Kind
import Data.Metrics.Servant
import Data.OpenApi.Lens hiding (HasServer)
import Data.OpenApi.Operation
import Data.Proxy
import Data.Text qualified as T
import GHC.Generics
import GHC.TypeLits
import Imports
import Servant
import Servant.Client
import Servant.Client.Core (clientIn)
import Servant.OpenApi
newtype Named name x = Named {forall {k} (name :: k) x. Named name x -> x
unnamed :: x}
deriving ((forall a b. (a -> b) -> Named name a -> Named name b)
-> (forall a b. a -> Named name b -> Named name a)
-> Functor (Named name)
forall k (name :: k) a b. a -> Named name b -> Named name a
forall k (name :: k) a b. (a -> b) -> Named name a -> Named name b
forall a b. a -> Named name b -> Named name a
forall a b. (a -> b) -> Named name a -> Named name b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall k (name :: k) a b. (a -> b) -> Named name a -> Named name b
fmap :: forall a b. (a -> b) -> Named name a -> Named name b
$c<$ :: forall k (name :: k) a b. a -> Named name b -> Named name a
<$ :: forall a b. a -> Named name b -> Named name a
Functor)
class RenderableSymbol a where
renderSymbol :: Text
instance (KnownSymbol a) => RenderableSymbol a where
renderSymbol :: Text
renderSymbol = String -> Text
T.pack (String -> Text) -> (String -> String) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. Show a => a -> String
show (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy a -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @a)
instance (RenderableSymbol a, RenderableSymbol b) => RenderableSymbol '(a, b) where
renderSymbol :: Text
renderSymbol = Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (forall (a :: k). RenderableSymbol a => Text
forall {k} (a :: k). RenderableSymbol a => Text
renderSymbol @a) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (forall (a :: k). RenderableSymbol a => Text
forall {k} (a :: k). RenderableSymbol a => Text
renderSymbol @b) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
newtype RenderableTypeName a = RenderableTypeName a
instance (GRenderableSymbol (Rep a)) => RenderableSymbol (RenderableTypeName a) where
renderSymbol :: Text
renderSymbol = forall {k} (f :: k). GRenderableSymbol f => Text
forall (f :: * -> *). GRenderableSymbol f => Text
grenderSymbol @(Rep a)
class GRenderableSymbol f where
grenderSymbol :: Text
instance (KnownSymbol tyName) => GRenderableSymbol (D1 (MetaData tyName modName pkg b) k) where
grenderSymbol :: Text
grenderSymbol = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy tyName -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @tyName)
instance (HasOpenApi api, RenderableSymbol name) => HasOpenApi (Named name api) where
toOpenApi :: Proxy (Named name api) -> OpenApi
toOpenApi Proxy (Named name api)
_ =
Proxy api -> OpenApi
forall {k} (api :: k). HasOpenApi api => Proxy api -> OpenApi
toOpenApi (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api)
OpenApi -> (OpenApi -> OpenApi) -> OpenApi
forall a b. a -> (a -> b) -> b
& (Operation -> Identity Operation) -> OpenApi -> Identity OpenApi
Traversal' OpenApi Operation
allOperations ((Operation -> Identity Operation) -> OpenApi -> Identity OpenApi)
-> ((Maybe Text -> Identity (Maybe Text))
-> Operation -> Identity Operation)
-> (Maybe Text -> Identity (Maybe Text))
-> OpenApi
-> Identity OpenApi
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Text -> Identity (Maybe Text))
-> Operation -> Identity Operation
forall s a. HasDescription s a => Lens' s a
Lens' Operation (Maybe Text)
description ((Maybe Text -> Identity (Maybe Text))
-> OpenApi -> Identity OpenApi)
-> (Maybe Text -> Maybe Text) -> OpenApi -> OpenApi
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text
dscr Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\n") <>)
where
dscr :: Text
dscr :: Text
dscr =
Text
" [<a href=\"https://docs.wire.com/developer/developer/servant.html#named-and-internal-route-ids\">internal route ID:</a> "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> forall (a :: k). RenderableSymbol a => Text
forall {k} (a :: k). RenderableSymbol a => Text
renderSymbol @name
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"
instance (HasServer api ctx) => HasServer (Named name api) ctx where
type ServerT (Named name api) m = Named name (ServerT api m)
route :: forall env.
Proxy (Named name api)
-> Context ctx
-> Delayed env (Server (Named name api))
-> Router env
route Proxy (Named name api)
_ Context ctx
ctx Delayed env (Server (Named name api))
action = Proxy api -> Context ctx -> Delayed env (Server api) -> Router env
forall env.
Proxy api -> Context ctx -> Delayed env (Server api) -> Router env
forall {k} (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api) Context ctx
ctx ((Named name (Server api) -> Server api)
-> Delayed env (Named name (Server api))
-> Delayed env (Server api)
forall a b. (a -> b) -> Delayed env a -> Delayed env b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Named name (Server api) -> Server api
forall {k} (name :: k) x. Named name x -> x
unnamed Delayed env (Server (Named name api))
Delayed env (Named name (Server api))
action)
hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
Proxy (Named name api)
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT (Named name api) m
-> ServerT (Named name api) n
hoistServerWithContext Proxy (Named name api)
_ Proxy ctx
ctx forall x. m x -> n x
f =
(ServerT api m -> ServerT api n)
-> Named name (ServerT api m) -> Named name (ServerT api n)
forall a b. (a -> b) -> Named name a -> Named name b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Proxy api
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api 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
forall (m :: * -> *) (n :: * -> *).
Proxy api
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api) Proxy ctx
ctx m x -> n x
forall x. m x -> n x
f)
instance (HasLink endpoint) => HasLink (Named name endpoint) where
type MkLink (Named name endpoint) a = MkLink endpoint a
toLink :: forall a.
(Link -> a)
-> Proxy (Named name endpoint)
-> Link
-> MkLink (Named name endpoint) a
toLink Link -> a
toA Proxy (Named name endpoint)
_ = (Link -> a) -> Proxy endpoint -> Link -> MkLink endpoint a
forall a.
(Link -> a) -> Proxy endpoint -> Link -> MkLink endpoint a
forall {k} (endpoint :: k) a.
HasLink endpoint =>
(Link -> a) -> Proxy endpoint -> Link -> MkLink endpoint a
toLink Link -> a
toA (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @endpoint)
instance (RoutesToPaths api) => RoutesToPaths (Named name api) where
getRoutes :: Forest PathSegment
getRoutes = forall routes. RoutesToPaths routes => Forest PathSegment
forall {k} (routes :: k).
RoutesToPaths routes =>
Forest PathSegment
getRoutes @api
instance (HasClient m api) => HasClient m (Named n api) where
type Client m (Named n api) = Client m api
clientWithRoute :: Proxy m -> Proxy (Named n api) -> Request -> Client m (Named n api)
clientWithRoute Proxy m
pm Proxy (Named n api)
_ Request
req = Proxy m -> Proxy api -> Request -> Client m api
forall (m :: * -> *) api.
HasClient m api =>
Proxy m -> Proxy api -> Request -> Client m api
clientWithRoute Proxy m
pm (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api) Request
req
hoistClientMonad :: forall (mon :: * -> *) (mon' :: * -> *).
Proxy m
-> Proxy (Named n api)
-> (forall x. mon x -> mon' x)
-> Client mon (Named n api)
-> Client mon' (Named n api)
hoistClientMonad Proxy m
pm Proxy (Named n api)
_ forall x. mon x -> mon' x
f = Proxy m
-> Proxy api
-> (forall x. mon x -> mon' x)
-> Client mon api
-> Client mon' api
forall (m :: * -> *) api (mon :: * -> *) (mon' :: * -> *).
HasClient m api =>
Proxy m
-> Proxy api
-> (forall x. mon x -> mon' x)
-> Client mon api
-> Client mon' api
forall (mon :: * -> *) (mon' :: * -> *).
Proxy m
-> Proxy api
-> (forall x. mon x -> mon' x)
-> Client mon api
-> Client mon' api
hoistClientMonad Proxy m
pm (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api) mon x -> mon' x
forall x. mon x -> mon' x
f
type family FindName n (api :: Type) :: (n, Type) where
FindName n (Named name api) = '(name, api)
FindName n (x :> api) = AddPrefix x (FindName n api)
FindName n api = '(TypeError ('Text "Named combinator not found"), api)
type family AddPrefix x napi where
AddPrefix x '(name, api) = '(name, x :> api)
type family LiftNamed' napi where
LiftNamed' '(name, api) = Named name api
type family Flatten api where
Flatten (x :> api) = Flatten1 x (Flatten api)
Flatten api = api
type family Flatten1 x api where
Flatten1 x (api1 :<|> api2) = Flatten1 x api1 :<|> Flatten1 x api2
Flatten1 x api = x :> api
type family LiftFlatNamed n api where
LiftFlatNamed n (api1 :<|> api2) = LiftFlatNamed n api1 :<|> LiftFlatNamed n api2
LiftFlatNamed n api = LiftNamed' (FindName n api)
type LiftNamedOfKind n api = LiftFlatNamed n (Flatten api)
type LiftNamed api = LiftNamedOfKind Symbol api
type family MappendMaybe (x :: Maybe k) (y :: Maybe k) :: Maybe k where
MappendMaybe 'Nothing y = y
MappendMaybe ('Just x) y = 'Just x
type family FMap (f :: a -> b) (m :: Maybe a) :: Maybe b where
FMap _ 'Nothing = 'Nothing
FMap f ('Just a) = 'Just (f a)
type family LookupEndpoint api name :: Maybe Type where
LookupEndpoint (Named name endpoint) name = 'Just endpoint
LookupEndpoint (api1 :<|> api2) name =
MappendMaybe
(LookupEndpoint api1 name)
(LookupEndpoint api2 name)
LookupEndpoint (prefix :> api) name = FMap ((:>) prefix) (LookupEndpoint api name)
LookupEndpoint api name = 'Nothing
type HasEndpoint api endpoint name = ('Just endpoint ~ LookupEndpoint api name)
namedClient ::
forall api (name :: Symbol) m endpoint.
(HasEndpoint api endpoint name, HasClient m endpoint) =>
Client m endpoint
namedClient :: forall api (name :: Symbol) (m :: * -> *) endpoint.
(HasEndpoint api endpoint name, HasClient m endpoint) =>
Client m endpoint
namedClient = Proxy endpoint -> Proxy m -> Client m endpoint
forall (m :: * -> *) api.
HasClient m api =>
Proxy api -> Proxy m -> Client m api
clientIn (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @endpoint) (forall {k} (t :: k). Proxy t
forall (t :: * -> *). Proxy t
Proxy @m)
type family x ::> api
infixr 4 ::>
type instance
x ::> (Named name api) =
Named name (x :> api)
type instance
x ::> (api1 :<|> api2) =
(x ::> api1) :<|> (x ::> api2)