{-# OPTIONS_GHC -Wno-redundant-constraints #-}

-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

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

-- | See http://docs.wire.com/developer/developer/servant.html#named-and-internal-route-ids-in-swagger
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)

-- | For 'HasSwagger' instance of 'Named'.  'KnownSymbol' isn't enough because we're using
-- types other than string literals in some places.
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

------------------------------------
-- Lookup

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

-------------------------------------
-- Named Client

type HasEndpoint api endpoint name = ('Just endpoint ~ LookupEndpoint api name)

-- | Return a client for a named endpoint.
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)

-- | Utility to push a Servant combinator inside Named APIs.
--
-- For example:
-- @@
-- From 'V5 ::> (Named "foo" (Get '[JSON] Foo) :<|> Named "bar" (Post '[JSON] Bar))
-- ==
-- Named "foo" (From 'V5 :> Get '[JSON] Foo) :<|> Named "bar" (From 'V5 :> Post '[JSON] Bar)
-- @@
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)