-- 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.Federation.Domain where

import Control.Lens ((?~))
import Data.Domain (Domain)
import Data.Metrics.Servant
import Data.OpenApi (OpenApi)
import Data.OpenApi qualified as S
import Data.Proxy (Proxy (..))
import GHC.TypeLits (Symbol, symbolVal)
import Imports
import Servant.API (Header', Required, Strict, (:>))
import Servant.Client
import Servant.OpenApi (HasOpenApi (toOpenApi))
import Servant.Server
import Servant.Server.Internal (MkContextWithErrorFormatter)
import Wire.API.Routes.ClientAlgebra
import Wire.API.Routes.SpecialiseToVersion

type OriginDomainHeaderName = "Wire-Origin-Domain" :: Symbol

data OriginDomainHeader

instance (RoutesToPaths api) => RoutesToPaths (OriginDomainHeader :> api) where
  getRoutes :: Forest PathSegment
getRoutes = forall api. RoutesToPaths api => Forest PathSegment
forall {k} (routes :: k).
RoutesToPaths routes =>
Forest PathSegment
getRoutes @api

type instance
  SpecialiseToVersion v (OriginDomainHeader :> api) =
    OriginDomainHeader :> SpecialiseToVersion v api

instance (HasClient m api) => HasClient m (OriginDomainHeader :> api) where
  type Client m (OriginDomainHeader :> api) = Client m api
  clientWithRoute :: Proxy m
-> Proxy (OriginDomainHeader :> api)
-> Request
-> Client m (OriginDomainHeader :> api)
clientWithRoute Proxy m
pm Proxy (OriginDomainHeader :> 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 (OriginDomainHeader :> api)
-> (forall x. mon x -> mon' x)
-> Client mon (OriginDomainHeader :> api)
-> Client mon' (OriginDomainHeader :> api)
hoistClientMonad Proxy m
pm Proxy (OriginDomainHeader :> api)
_ = 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)

instance (HasClientAlgebra m api) => HasClientAlgebra m (OriginDomainHeader :> api) where
  joinClient :: m (Client m (OriginDomainHeader :> api))
-> Client m (OriginDomainHeader :> api)
joinClient = forall (m :: * -> *) api.
HasClientAlgebra m api =>
m (Client m api) -> Client m api
joinClient @m @api
  bindClient :: forall a.
m a
-> (a -> Client m (OriginDomainHeader :> api))
-> Client m (OriginDomainHeader :> api)
bindClient = forall (m :: * -> *) api a.
HasClientAlgebra m api =>
m a -> (a -> Client m api) -> Client m api
bindClient @m @api

type OriginDomainHeaderHasServer = Header' [Strict, Required] OriginDomainHeaderName Domain

instance
  ( HasServer api context,
    HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
  ) =>
  HasServer (OriginDomainHeader :> api) context
  where
  type ServerT (OriginDomainHeader :> api) m = Domain -> ServerT api m
  route :: forall env.
Proxy (OriginDomainHeader :> api)
-> Context context
-> Delayed env (Server (OriginDomainHeader :> api))
-> Router env
route Proxy (OriginDomainHeader :> api)
_pa = Proxy (OriginDomainHeaderHasServer :> api)
-> Context context
-> Delayed env (Server (OriginDomainHeaderHasServer :> api))
-> Router' env RoutingApplication
forall env.
Proxy (OriginDomainHeaderHasServer :> api)
-> Context context
-> Delayed env (Server (OriginDomainHeaderHasServer :> 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 @(OriginDomainHeaderHasServer :> api))
  hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
Proxy (OriginDomainHeader :> api)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (OriginDomainHeader :> api) m
-> ServerT (OriginDomainHeader :> api) n
hoistServerWithContext Proxy (OriginDomainHeader :> api)
_ Proxy context
pc forall x. m x -> n x
nt ServerT (OriginDomainHeader :> api) m
s = Proxy api
-> Proxy context
-> (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 context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Proxy context
pc m x -> n x
forall x. m x -> n x
nt (ServerT api m -> ServerT api n)
-> (Domain -> ServerT api m) -> Domain -> ServerT api n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (OriginDomainHeader :> api) m
Domain -> ServerT api m
s

originDomainHeaderName :: (IsString a) => a
originDomainHeaderName :: forall a. IsString a => a
originDomainHeaderName = String -> a
forall a. IsString a => String -> a
fromString (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ Proxy "Wire-Origin-Domain" -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @OriginDomainHeaderName)

instance (HasOpenApi api) => HasOpenApi (OriginDomainHeader :> api) where
  toOpenApi :: Proxy (OriginDomainHeader :> api) -> OpenApi
toOpenApi Proxy (OriginDomainHeader :> api)
_ = OpenApi -> OpenApi
desc (OpenApi -> OpenApi) -> OpenApi -> OpenApi
forall a b. (a -> b) -> a -> b
$ 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)
    where
      desc :: OpenApi -> OpenApi
      desc :: OpenApi -> OpenApi
desc = (Operation -> Identity Operation) -> OpenApi -> Identity OpenApi
Traversal' OpenApi Operation
S.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)
S.description ((Maybe Text -> Identity (Maybe Text))
 -> OpenApi -> Identity OpenApi)
-> Text -> OpenApi -> OpenApi
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ (Text
"All federated endpoints expect origin domain header: `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
forall a. IsString a => a
originDomainHeaderName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`")