-- Disabling to stop warnings on HasCallStack
{-# 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.Federation.API
  ( FedApi,
    HasFedEndpoint,
    HasUnsafeFedEndpoint,
    FederationMonad (..),
    IsNamed (..),
    nameVal,
    fedClient,
    fedQueueClient,
    sendBundle,
    fedClientIn,
    module X,

    -- * Re-exports
    Component (..),
    makeConversationUpdateBundle,
  )
where

import Data.Aeson
import Data.Domain
import Data.Kind
import Data.Proxy
import Data.Singletons
import Data.Text qualified as Text
import GHC.TypeLits
import Imports
import Network.AMQP
import Servant.Client
import Servant.Client.Core
import Wire.API.Component as X
import Wire.API.Federation.API.Brig
import Wire.API.Federation.API.Cargohold
import Wire.API.Federation.API.Galley
import Wire.API.Federation.API.Util
import Wire.API.Federation.BackendNotifications
import Wire.API.Federation.Client
import Wire.API.Federation.Component
import Wire.API.Federation.Endpoint
import Wire.API.Federation.HasNotificationEndpoint
import Wire.API.Federation.Version
import Wire.API.Routes.Named

-- Note: this type family being injective means that in most cases there is no need
-- to add component annotations when invoking the federator client
type family FedApi (comp :: Component) = (api :: Type) | api -> comp

type instance FedApi 'Galley = GalleyApi

type instance FedApi 'Brig = BrigApi

type instance FedApi 'Cargohold = CargoholdApi

type HasFedEndpoint comp api name = (HasUnsafeFedEndpoint comp api name)

-- | Like 'HasFedEndpoint', but doesn't propagate a 'CallsFed' constraint.
-- Useful for tests, but unsafe in the sense that incorrect usage will allow
-- you to forget about some federated calls.
type HasUnsafeFedEndpoint comp api name = 'Just api ~ LookupEndpoint (FedApi comp) name

nameVal :: forall {k} (name :: k). (IsNamed name) => Text
nameVal :: forall {k} (name :: k). IsNamed name => Text
nameVal = forall {k} (name :: k). IsNamed name => Text
nameVal' @k @name

class IsNamed (name :: k) where
  nameVal' :: Text

instance (KnownSymbol name) => IsNamed (name :: Symbol) where
  nameVal' :: Text
nameVal' = String -> Text
Text.pack (Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @name))

instance (IsNamed name, SingI v) => IsNamed (Versioned (v :: Version) name) where
  nameVal' :: Text
nameVal' = Version -> Text
versionText (forall {k} (a :: k). (SingKind k, SingI a) => Demote k
forall (a :: Version).
(SingKind Version, SingI a) =>
Demote Version
demote @v) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> forall (name :: k1). IsNamed name => Text
forall {k} (name :: k). IsNamed name => Text
nameVal @name

class FederationMonad (fedM :: Component -> Type -> Type) where
  fedClientWithProxy ::
    forall (comp :: Component) name api.
    ( HasClient (fedM comp) api,
      HasFedEndpoint comp api name,
      KnownComponent comp,
      IsNamed name,
      Typeable (Client (fedM comp) api)
    ) =>
    Proxy name ->
    Proxy api ->
    Proxy (fedM comp) ->
    Client (fedM comp) api

instance FederationMonad FederatorClient where
  fedClientWithProxy :: forall {k} (comp :: Component) (name :: k) api.
(HasClient (FederatorClient comp) api,
 HasFedEndpoint comp api name, KnownComponent comp, IsNamed name,
 Typeable (Client (FederatorClient comp) api)) =>
Proxy name
-> Proxy api
-> Proxy (FederatorClient comp)
-> Client (FederatorClient comp) api
fedClientWithProxy Proxy name
_ = Proxy api
-> Proxy (FederatorClient comp)
-> Client (FederatorClient comp) api
forall (m :: * -> *) api.
HasClient m api =>
Proxy api -> Proxy m -> Client m api
clientIn

-- | Return a client for a named endpoint.
fedClient ::
  forall (comp :: Component) name fedM (showcomp :: Symbol) api.
  ( showcomp ~ ShowComponent comp,
    HasFedEndpoint comp api name,
    HasClient (fedM comp) api,
    KnownComponent comp,
    IsNamed name,
    FederationMonad fedM,
    Typeable (Client (fedM comp) api)
  ) =>
  Client (fedM comp) api
fedClient :: forall {k} (comp :: Component) (name :: k)
       (fedM :: Component -> * -> *) (showcomp :: Symbol) api.
(showcomp ~ ShowComponent comp, HasFedEndpoint comp api name,
 HasClient (fedM comp) api, KnownComponent comp, IsNamed name,
 FederationMonad fedM, Typeable (Client (fedM comp) api)) =>
Client (fedM comp) api
fedClient = Proxy name
-> Proxy api -> Proxy (fedM comp) -> Client (fedM comp) api
forall {k} (comp :: Component) (name :: k) api.
(HasClient (fedM comp) api, HasFedEndpoint comp api name,
 KnownComponent comp, IsNamed name,
 Typeable (Client (fedM comp) api)) =>
Proxy name
-> Proxy api -> Proxy (fedM comp) -> Client (fedM comp) api
forall (fedM :: Component -> * -> *) {k} (comp :: Component)
       (name :: k) api.
(FederationMonad fedM, HasClient (fedM comp) api,
 HasFedEndpoint comp api name, KnownComponent comp, IsNamed name,
 Typeable (Client (fedM comp) api)) =>
Proxy name
-> Proxy api -> Proxy (fedM comp) -> Client (fedM comp) api
fedClientWithProxy (forall (t :: k). Proxy t
forall {k} (t :: k). Proxy t
Proxy @name) (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api) (forall {k} (t :: k). Proxy t
forall (t :: * -> *). Proxy t
Proxy @(fedM comp))

fedClientIn ::
  forall (comp :: Component) (name :: Symbol) m api.
  (HasFedEndpoint comp api name, HasClient m api) =>
  Client m api
fedClientIn :: forall (comp :: Component) (name :: Symbol) (m :: * -> *) api.
(HasFedEndpoint comp api name, HasClient m api) =>
Client m api
fedClientIn = Proxy api -> Proxy m -> Client m api
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 @api) (forall {k} (t :: k). Proxy t
forall (t :: * -> *). Proxy t
Proxy @m)

sendBundle ::
  (KnownComponent c) =>
  PayloadBundle c ->
  FedQueueClient c ()
sendBundle :: forall (c :: Component).
KnownComponent c =>
PayloadBundle c -> FedQueueClient c ()
sendBundle PayloadBundle c
bundle = do
  FedQueueEnv
env <- FedQueueClient c FedQueueEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
  let msg :: Message
msg =
        Message
newMsg
          { msgBody = encode bundle,
            msgDeliveryMode = Just (env.deliveryMode),
            msgContentType = Just "application/json"
          }
      -- Empty string means default exchange
      exchange :: Text
exchange = Text
""
  IO () -> FedQueueClient c ()
forall a. IO a -> FedQueueClient c a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FedQueueClient c ()) -> IO () -> FedQueueClient c ()
forall a b. (a -> b) -> a -> b
$ do
    Channel -> Text -> IO ()
ensureQueue FedQueueEnv
env.channel FedQueueEnv
env.targetDomain._domainText
    IO (Maybe Int) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe Int) -> IO ()) -> IO (Maybe Int) -> IO ()
forall a b. (a -> b) -> a -> b
$ Channel -> Text -> Text -> Message -> IO (Maybe Int)
publishMsg FedQueueEnv
env.channel Text
exchange (Text -> Text
routingKey FedQueueEnv
env.targetDomain._domainText) Message
msg

fedQueueClient ::
  forall {k} (tag :: k) c.
  ( HasNotificationEndpoint tag,
    HasVersionRange tag,
    HasFedPath tag,
    KnownComponent (NotificationComponent k),
    ToJSON (Payload tag),
    c ~ NotificationComponent k
  ) =>
  Payload tag ->
  FedQueueClient c ()
fedQueueClient :: forall {k} (tag :: k) (c :: Component).
(HasNotificationEndpoint tag, HasVersionRange tag, HasFedPath tag,
 KnownComponent (NotificationComponent k), ToJSON (Payload tag),
 c ~ NotificationComponent k) =>
Payload tag -> FedQueueClient c ()
fedQueueClient Payload tag
payload = PayloadBundle c -> FedQueueClient c ()
forall (c :: Component).
KnownComponent c =>
PayloadBundle c -> FedQueueClient c ()
sendBundle (PayloadBundle c -> FedQueueClient c ())
-> FedQueueClient c (PayloadBundle c) -> FedQueueClient c ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (tag :: k) (c :: Component).
(HasFedPath tag, HasVersionRange tag,
 KnownComponent (NotificationComponent k), ToJSON (Payload tag),
 c ~ NotificationComponent k) =>
Payload tag -> FedQueueClient c (PayloadBundle c)
forall {k} (tag :: k) (c :: Component).
(HasFedPath tag, HasVersionRange tag,
 KnownComponent (NotificationComponent k), ToJSON (Payload tag),
 c ~ NotificationComponent k) =>
Payload tag -> FedQueueClient c (PayloadBundle c)
makeBundle @tag Payload tag
payload