-- 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 Galley.Intra.Federator (interpretFederatorAccess) where

import Control.Lens
import Data.Bifunctor
import Data.Qualified
import Galley.Cassandra.Util
import Galley.Effects.FederatorAccess (FederatorAccess (..))
import Galley.Env
import Galley.Env qualified as E
import Galley.Monad
import Galley.Options
import Imports
import Polysemy
import Polysemy.Input
import Polysemy.TinyLog
import UnliftIO
import Wire.API.Federation.Client
import Wire.API.Federation.Error

interpretFederatorAccess ::
  ( Member (Embed IO) r,
    Member (Input Env) r,
    Member TinyLog r
  ) =>
  Sem (FederatorAccess ': r) a ->
  Sem r a
interpretFederatorAccess :: forall (r :: EffectRow) a.
(Member (Embed IO) r, Member (Input Env) r, Member TinyLog r) =>
Sem (FederatorAccess : r) a -> Sem r a
interpretFederatorAccess = (forall (rInitial :: EffectRow) x.
 FederatorAccess (Sem rInitial) x -> Sem r x)
-> Sem (FederatorAccess : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall (rInitial :: EffectRow) x. e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret ((forall (rInitial :: EffectRow) x.
  FederatorAccess (Sem rInitial) x -> Sem r x)
 -> Sem (FederatorAccess : r) a -> Sem r a)
-> (forall (rInitial :: EffectRow) x.
    FederatorAccess (Sem rInitial) x -> Sem r x)
-> Sem (FederatorAccess : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
  RunFederated Remote x
dom FederatorClient c x
rpc -> do
    ByteString -> Sem r ()
forall (r :: EffectRow). Member TinyLog r => ByteString -> Sem r ()
logEffect ByteString
"FederatorAccess.RunFederated"
    App x -> Sem r x
forall (r :: EffectRow) a.
(Member (Embed IO) r, Member (Input Env) r) =>
App a -> Sem r a
embedApp (App x -> Sem r x) -> App x -> Sem r x
forall a b. (a -> b) -> a -> b
$ Remote x -> FederatorClient c x -> App x
forall x (c :: Component) a.
Remote x -> FederatorClient c a -> App a
runFederated Remote x
dom FederatorClient c x
rpc
  RunFederatedEither Remote x
dom FederatorClient c a1
rpc -> do
    ByteString -> Sem r ()
forall (r :: EffectRow). Member TinyLog r => ByteString -> Sem r ()
logEffect ByteString
"FederatorAccess.RunFederatedEither"
    App x -> Sem r x
forall (r :: EffectRow) a.
(Member (Embed IO) r, Member (Input Env) r) =>
App a -> Sem r a
embedApp (App x -> Sem r x) -> App x -> Sem r x
forall a b. (a -> b) -> a -> b
$ Remote x -> FederatorClient c a1 -> App (Either FederationError a1)
forall x (c :: Component) a.
Remote x -> FederatorClient c a -> App (Either FederationError a)
runFederatedEither Remote x
dom FederatorClient c a1
rpc
  RunFederatedConcurrently f (Remote x)
rs Remote [x] -> FederatorClient c a1
f -> do
    ByteString -> Sem r ()
forall (r :: EffectRow). Member TinyLog r => ByteString -> Sem r ()
logEffect ByteString
"FederatorAccess.RunFederatedConcurrently"
    App x -> Sem r x
forall (r :: EffectRow) a.
(Member (Embed IO) r, Member (Input Env) r) =>
App a -> Sem r a
embedApp (App x -> Sem r x) -> App x -> Sem r x
forall a b. (a -> b) -> a -> b
$ f (Remote x)
-> (Remote [x] -> FederatorClient c a1) -> App [Remote a1]
forall (f :: * -> *) a (c :: Component) b.
(Foldable f, Functor f) =>
f (Remote a)
-> (Remote [a] -> FederatorClient c b) -> App [Remote b]
runFederatedConcurrently f (Remote x)
rs Remote [x] -> FederatorClient c a1
f
  RunFederatedConcurrentlyEither f (Remote x)
rs Remote [x] -> FederatorClient c a1
f -> do
    ByteString -> Sem r ()
forall (r :: EffectRow). Member TinyLog r => ByteString -> Sem r ()
logEffect ByteString
"FederatorAccess.RunFederatedConcurrentlyEither"
    App x -> Sem r x
forall (r :: EffectRow) a.
(Member (Embed IO) r, Member (Input Env) r) =>
App a -> Sem r a
embedApp (App x -> Sem r x) -> App x -> Sem r x
forall a b. (a -> b) -> a -> b
$ f (Remote x)
-> (Remote [x] -> FederatorClient c a1)
-> App [Either (Remote [x], FederationError) (Remote a1)]
forall (f :: * -> *) a (c :: Component) b.
(Foldable f, Functor f) =>
f (Remote a)
-> (Remote [a] -> FederatorClient c b)
-> App [Either (Remote [a], FederationError) (Remote b)]
runFederatedConcurrentlyEither f (Remote x)
rs Remote [x] -> FederatorClient c a1
f
  RunFederatedConcurrentlyBucketsEither f (Remote x)
rs Remote x -> FederatorClient c a1
f -> do
    ByteString -> Sem r ()
forall (r :: EffectRow). Member TinyLog r => ByteString -> Sem r ()
logEffect ByteString
"FederatorAccess.RunFederatedConcurrentlyBucketsEither"
    App x -> Sem r x
forall (r :: EffectRow) a.
(Member (Embed IO) r, Member (Input Env) r) =>
App a -> Sem r a
embedApp (App x -> Sem r x) -> App x -> Sem r x
forall a b. (a -> b) -> a -> b
$ f (Remote x)
-> (Remote x -> FederatorClient c a1)
-> App [Either (Remote x, FederationError) (Remote a1)]
forall (f :: * -> *) x (c :: Component) b.
Foldable f =>
f (Remote x)
-> (Remote x -> FederatorClient c b)
-> App [Either (Remote x, FederationError) (Remote b)]
runFederatedConcurrentlyBucketsEither f (Remote x)
rs Remote x -> FederatorClient c a1
f
  FederatorAccess (Sem rInitial) x
IsFederationConfigured -> do
    ByteString -> Sem r ()
forall (r :: EffectRow). Member TinyLog r => ByteString -> Sem r ()
logEffect ByteString
"FederatorAccess.IsFederationConfigured"
    App x -> Sem r x
forall (r :: EffectRow) a.
(Member (Embed IO) r, Member (Input Env) r) =>
App a -> Sem r a
embedApp (App x -> Sem r x) -> App x -> Sem r x
forall a b. (a -> b) -> a -> b
$ Maybe Endpoint -> x
Maybe Endpoint -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Endpoint -> x) -> App (Maybe Endpoint) -> App x
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting (Maybe Endpoint) Env (Maybe Endpoint)
-> App (Maybe Endpoint)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe Endpoint) Env (Maybe Endpoint)
Lens' Env (Maybe Endpoint)
E.federator

runFederatedEither ::
  Remote x ->
  FederatorClient c a ->
  App (Either FederationError a)
runFederatedEither :: forall x (c :: Component) a.
Remote x -> FederatorClient c a -> App (Either FederationError a)
runFederatedEither (Remote x -> Domain
forall (t :: QTag) a. QualifiedWithTag t a -> Domain
tDomain -> Domain
remoteDomain) FederatorClient c a
rpc = do
  Domain
ownDomain <- Getting Domain Env Domain -> App Domain
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Opts -> Const Domain Opts) -> Env -> Const Domain Env
Lens' Env Opts
options ((Opts -> Const Domain Opts) -> Env -> Const Domain Env)
-> ((Domain -> Const Domain Domain) -> Opts -> Const Domain Opts)
-> Getting Domain Env Domain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Settings -> Const Domain Settings) -> Opts -> Const Domain Opts
Lens' Opts Settings
settings ((Settings -> Const Domain Settings) -> Opts -> Const Domain Opts)
-> ((Domain -> Const Domain Domain)
    -> Settings -> Const Domain Settings)
-> (Domain -> Const Domain Domain)
-> Opts
-> Const Domain Opts
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Domain -> Const Domain Domain)
-> Settings -> Const Domain Settings
Lens' Settings Domain
federationDomain)
  Maybe Endpoint
mfedEndpoint <- Getting (Maybe Endpoint) Env (Maybe Endpoint)
-> App (Maybe Endpoint)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe Endpoint) Env (Maybe Endpoint)
Lens' Env (Maybe Endpoint)
E.federator
  Http2Manager
mgr <- Getting Http2Manager Env Http2Manager -> App Http2Manager
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Http2Manager Env Http2Manager
Lens' Env Http2Manager
http2Manager
  RequestId
rid <- Getting RequestId Env RequestId -> App RequestId
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting RequestId Env RequestId
Lens' Env RequestId
reqId
  case Maybe Endpoint
mfedEndpoint of
    Maybe Endpoint
Nothing -> Either FederationError a -> App (Either FederationError a)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FederationError -> Either FederationError a
forall a b. a -> Either a b
Left FederationError
FederationNotConfigured)
    Just Endpoint
fedEndpoint -> do
      let ce :: FederatorClientEnv
ce =
            FederatorClientEnv
              { $sel:ceOriginDomain:FederatorClientEnv :: Domain
ceOriginDomain = Domain
ownDomain,
                $sel:ceTargetDomain:FederatorClientEnv :: Domain
ceTargetDomain = Domain
remoteDomain,
                $sel:ceFederator:FederatorClientEnv :: Endpoint
ceFederator = Endpoint
fedEndpoint,
                $sel:ceHttp2Manager:FederatorClientEnv :: Http2Manager
ceHttp2Manager = Http2Manager
mgr,
                $sel:ceOriginRequestId:FederatorClientEnv :: RequestId
ceOriginRequestId = RequestId
rid
              }
      IO (Either FederationError a) -> App (Either FederationError a)
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either FederationError a) -> App (Either FederationError a))
-> (IO (Either FederatorClientError a)
    -> IO (Either FederationError a))
-> IO (Either FederatorClientError a)
-> App (Either FederationError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either FederatorClientError a -> Either FederationError a)
-> IO (Either FederatorClientError a)
-> IO (Either FederationError a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((FederatorClientError -> FederationError)
-> Either FederatorClientError a -> Either FederationError a
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first FederatorClientError -> FederationError
FederationCallFailure) (IO (Either FederatorClientError a)
 -> App (Either FederationError a))
-> IO (Either FederatorClientError a)
-> App (Either FederationError a)
forall a b. (a -> b) -> a -> b
$ FederatorClientEnv
-> FederatorClient c a -> IO (Either FederatorClientError a)
forall (c :: Component) a.
FederatorClientEnv
-> FederatorClient c a -> IO (Either FederatorClientError a)
runFederatorClient FederatorClientEnv
ce FederatorClient c a
rpc

runFederated ::
  Remote x ->
  FederatorClient c a ->
  App a
runFederated :: forall x (c :: Component) a.
Remote x -> FederatorClient c a -> App a
runFederated Remote x
dom FederatorClient c a
rpc =
  Remote x -> FederatorClient c a -> App (Either FederationError a)
forall x (c :: Component) a.
Remote x -> FederatorClient c a -> App (Either FederationError a)
runFederatedEither Remote x
dom FederatorClient c a
rpc
    App (Either FederationError a)
-> (Either FederationError a -> App a) -> App a
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (FederationError -> App a)
-> (a -> App a) -> Either FederationError a -> App a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Error -> App a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (Error -> App a)
-> (FederationError -> Error) -> FederationError -> App a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FederationError -> Error
federationErrorToWai) a -> App a
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

runFederatedConcurrently ::
  ( Foldable f,
    Functor f
  ) =>
  f (Remote a) ->
  (Remote [a] -> FederatorClient c b) ->
  App [Remote b]
runFederatedConcurrently :: forall (f :: * -> *) a (c :: Component) b.
(Foldable f, Functor f) =>
f (Remote a)
-> (Remote [a] -> FederatorClient c b) -> App [Remote b]
runFederatedConcurrently f (Remote a)
xs Remote [a] -> FederatorClient c b
rpc =
  Int
-> [Remote [a]] -> (Remote [a] -> App (Remote b)) -> App [Remote b]
forall (m :: * -> *) (t :: * -> *) a b.
(MonadUnliftIO m, Traversable t) =>
Int -> t a -> (a -> m b) -> m (t b)
pooledForConcurrentlyN Int
8 (f (Remote a) -> [Remote [a]]
forall (f :: * -> *) a.
(Functor f, Foldable f) =>
f (Remote a) -> [Remote [a]]
bucketRemote f (Remote a)
xs) ((Remote [a] -> App (Remote b)) -> App [Remote b])
-> (Remote [a] -> App (Remote b)) -> App [Remote b]
forall a b. (a -> b) -> a -> b
$ \Remote [a]
r ->
    Remote [a] -> b -> Remote b
forall (t :: QTag) x a.
QualifiedWithTag t x -> a -> QualifiedWithTag t a
qualifyAs Remote [a]
r (b -> Remote b) -> App b -> App (Remote b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Remote [a] -> FederatorClient c b -> App b
forall x (c :: Component) a.
Remote x -> FederatorClient c a -> App a
runFederated Remote [a]
r (Remote [a] -> FederatorClient c b
rpc Remote [a]
r)

runFederatedConcurrentlyEither ::
  (Foldable f, Functor f) =>
  f (Remote a) ->
  (Remote [a] -> FederatorClient c b) ->
  App [Either (Remote [a], FederationError) (Remote b)]
runFederatedConcurrentlyEither :: forall (f :: * -> *) a (c :: Component) b.
(Foldable f, Functor f) =>
f (Remote a)
-> (Remote [a] -> FederatorClient c b)
-> App [Either (Remote [a], FederationError) (Remote b)]
runFederatedConcurrentlyEither f (Remote a)
xs Remote [a] -> FederatorClient c b
rpc =
  Int
-> [Remote [a]]
-> (Remote [a]
    -> App (Either (Remote [a], FederationError) (Remote b)))
-> App [Either (Remote [a], FederationError) (Remote b)]
forall (m :: * -> *) (t :: * -> *) a b.
(MonadUnliftIO m, Traversable t) =>
Int -> t a -> (a -> m b) -> m (t b)
pooledForConcurrentlyN Int
8 (f (Remote a) -> [Remote [a]]
forall (f :: * -> *) a.
(Functor f, Foldable f) =>
f (Remote a) -> [Remote [a]]
bucketRemote f (Remote a)
xs) ((Remote [a]
  -> App (Either (Remote [a], FederationError) (Remote b)))
 -> App [Either (Remote [a], FederationError) (Remote b)])
-> (Remote [a]
    -> App (Either (Remote [a], FederationError) (Remote b)))
-> App [Either (Remote [a], FederationError) (Remote b)]
forall a b. (a -> b) -> a -> b
$ \Remote [a]
r ->
    (FederationError -> (Remote [a], FederationError))
-> (b -> Remote b)
-> Either FederationError b
-> Either (Remote [a], FederationError) (Remote b)
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (Remote [a]
r,) (Remote [a] -> b -> Remote b
forall (t :: QTag) x a.
QualifiedWithTag t x -> a -> QualifiedWithTag t a
qualifyAs Remote [a]
r) (Either FederationError b
 -> Either (Remote [a], FederationError) (Remote b))
-> App (Either FederationError b)
-> App (Either (Remote [a], FederationError) (Remote b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Remote [a] -> FederatorClient c b -> App (Either FederationError b)
forall x (c :: Component) a.
Remote x -> FederatorClient c a -> App (Either FederationError a)
runFederatedEither Remote [a]
r (Remote [a] -> FederatorClient c b
rpc Remote [a]
r)

runFederatedConcurrentlyBucketsEither ::
  (Foldable f) =>
  f (Remote x) ->
  (Remote x -> FederatorClient c b) ->
  App [Either (Remote x, FederationError) (Remote b)]
runFederatedConcurrentlyBucketsEither :: forall (f :: * -> *) x (c :: Component) b.
Foldable f =>
f (Remote x)
-> (Remote x -> FederatorClient c b)
-> App [Either (Remote x, FederationError) (Remote b)]
runFederatedConcurrentlyBucketsEither f (Remote x)
xs Remote x -> FederatorClient c b
rpc =
  Int
-> [Remote x]
-> (Remote x
    -> App (Either (Remote x, FederationError) (Remote b)))
-> App [Either (Remote x, FederationError) (Remote b)]
forall (m :: * -> *) (t :: * -> *) a b.
(MonadUnliftIO m, Traversable t) =>
Int -> t a -> (a -> m b) -> m (t b)
pooledForConcurrentlyN Int
8 (f (Remote x) -> [Remote x]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f (Remote x)
xs) ((Remote x -> App (Either (Remote x, FederationError) (Remote b)))
 -> App [Either (Remote x, FederationError) (Remote b)])
-> (Remote x
    -> App (Either (Remote x, FederationError) (Remote b)))
-> App [Either (Remote x, FederationError) (Remote b)]
forall a b. (a -> b) -> a -> b
$ \Remote x
r ->
    (FederationError -> (Remote x, FederationError))
-> (b -> Remote b)
-> Either FederationError b
-> Either (Remote x, FederationError) (Remote b)
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (Remote x
r,) (Remote x -> b -> Remote b
forall (t :: QTag) x a.
QualifiedWithTag t x -> a -> QualifiedWithTag t a
qualifyAs Remote x
r) (Either FederationError b
 -> Either (Remote x, FederationError) (Remote b))
-> App (Either FederationError b)
-> App (Either (Remote x, FederationError) (Remote b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Remote x -> FederatorClient c b -> App (Either FederationError b)
forall x (c :: Component) a.
Remote x -> FederatorClient c a -> App (Either FederationError a)
runFederatedEither Remote x
r (Remote x -> FederatorClient c b
rpc Remote x
r)