{-# OPTIONS_GHC -Wno-redundant-constraints #-}
module Wire.API.Federation.API
( FedApi,
HasFedEndpoint,
HasUnsafeFedEndpoint,
FederationMonad (..),
IsNamed (..),
nameVal,
fedClient,
fedQueueClient,
sendBundle,
fedClientIn,
module X,
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
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)
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
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"
}
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