content: {-# 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 {unnamed :: x}
    deriving (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
    renderOperationId :: Text
    renderOperationId = renderSymbol @a
  
  instance (KnownSymbol a) => RenderableSymbol a where
    renderSymbol = T.pack . show $ symbolVal (Proxy @a)
    renderOperationId = T.pack $ symbolVal (Proxy @a)
  
  instance (RenderableSymbol a, RenderableSymbol b) => RenderableSymbol '(a, b) where
    renderSymbol = "(" <> (renderSymbol @a) <> ", " <> (renderSymbol @b) <> ")"
    renderOperationId = renderOperationId @a <> "_" <> renderOperationId @b
  
  newtype RenderableTypeName a = RenderableTypeName a
  
  instance (GRenderableSymbol (Rep a)) => RenderableSymbol (RenderableTypeName a) where
    renderSymbol = grenderSymbol @(Rep a)
    renderOperationId = grenderSymbol @(Rep a)
  
  class GRenderableSymbol f where
    grenderSymbol :: Text
  
  instance (KnownSymbol tyName) => GRenderableSymbol (D1 (MetaData tyName modName pkg b) k) where
    grenderSymbol = T.pack $ symbolVal (Proxy @tyName)
  
  instance (HasOpenApi api, RenderableSymbol name) => HasOpenApi (Named name api) where
    toOpenApi _ =
      toOpenApi (Proxy @api)
        & allOperations . description %~ (Just (dscr <> "\n\n") <>)
        & allOperations . operationId ?~ renderOperationId @name
      where
        dscr :: Text
        dscr =
          " [<a href=\"https://docs.wire.com/developer/developer/servant.html#named-and-internal-route-ids\">internal route ID:</a> "
            <> renderSymbol @name
            <> "]"
  
  instance (HasServer api ctx) => HasServer (Named name api) ctx where
    type ServerT (Named name api) m = Named name (ServerT api m)
  
    route _ ctx action = route (Proxy @api) ctx (fmap unnamed action)
    hoistServerWithContext _ ctx f =
      fmap (hoistServerWithContext (Proxy @api) ctx f)
  
  instance (HasLink endpoint) => HasLink (Named name endpoint) where
    type MkLink (Named name endpoint) a = MkLink endpoint a
    toLink toA _ = toLink toA (Proxy @endpoint)
  
  instance (RoutesToPaths api) => RoutesToPaths (Named name api) where
    getRoutes = getRoutes @api
  
  instance (HasClient m api) => HasClient m (Named n api) where
    type Client m (Named n api) = Client m api
    clientWithRoute pm _ req = clientWithRoute pm (Proxy @api) req
    hoistClientMonad pm _ f = hoistClientMonad pm (Proxy @api) 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 = clientIn (Proxy @endpoint) (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)
  