module Wire.FederationAPIAccess.Interpreter where import Data.Bifunctor (first) import Data.Domain import Data.Id import Data.Qualified import HTTP2.Client.Manager import Imports import Polysemy import Util.Options import Wire.API.Federation.Client import Wire.API.Federation.Error import Wire.FederationAPIAccess (FederationAPIAccess (..)) import Wire.Sem.Concurrency data FederationAPIAccessConfig = FederationAPIAccessConfig { FederationAPIAccessConfig -> Domain ownDomain :: Domain, FederationAPIAccessConfig -> Maybe Endpoint federatorEndpoint :: Maybe Endpoint, FederationAPIAccessConfig -> Http2Manager http2Manager :: Http2Manager, FederationAPIAccessConfig -> RequestId requestId :: RequestId } type FederatedActionRunner fedM r = forall c x. Domain -> fedM c x -> Sem r (Either FederationError x) noFederationAPIAccess :: forall r fedM. (Member (Concurrency 'Unsafe) r) => InterpreterFor (FederationAPIAccess fedM) r noFederationAPIAccess :: forall (r :: EffectRow) (fedM :: Component -> * -> *). Member (Concurrency 'Unsafe) r => InterpreterFor (FederationAPIAccess fedM) r noFederationAPIAccess = FederatedActionRunner fedM r -> Sem r Bool -> InterpreterFor (FederationAPIAccess fedM) r forall (fedM :: Component -> * -> *) (r :: EffectRow). Member (Concurrency 'Unsafe) r => FederatedActionRunner fedM r -> Sem r Bool -> InterpreterFor (FederationAPIAccess fedM) r interpretFederationAPIAccessGeneral (\Domain _ fedM c x _ -> Either FederationError x -> Sem r (Either FederationError x) forall a. a -> Sem r a forall (f :: * -> *) a. Applicative f => a -> f a pure (Either FederationError x -> Sem r (Either FederationError x)) -> Either FederationError x -> Sem r (Either FederationError x) forall a b. (a -> b) -> a -> b $ FederationError -> Either FederationError x forall a b. a -> Either a b Left FederationError FederationNotConfigured) (Bool -> Sem r Bool forall a. a -> Sem r a forall (f :: * -> *) a. Applicative f => a -> f a pure Bool False) interpretFederationAPIAccess :: forall r. (Member (Embed IO) r, Member (Concurrency 'Unsafe) r) => FederationAPIAccessConfig -> InterpreterFor (FederationAPIAccess FederatorClient) r interpretFederationAPIAccess :: forall (r :: EffectRow). (Member (Embed IO) r, Member (Concurrency 'Unsafe) r) => FederationAPIAccessConfig -> InterpreterFor (FederationAPIAccess FederatorClient) r interpretFederationAPIAccess FederationAPIAccessConfig config Sem (FederationAPIAccess FederatorClient : r) a action = do let isFederationConfigured :: Bool isFederationConfigured = Maybe Endpoint -> Bool forall a. Maybe a -> Bool isJust FederationAPIAccessConfig config.federatorEndpoint runner :: FederatedActionRunner FederatorClient r runner :: FederatedActionRunner FederatorClient r runner Domain remoteDomain FederatorClient c x rpc = case FederationAPIAccessConfig config.federatorEndpoint of Maybe Endpoint Nothing -> Either FederationError x -> Sem r (Either FederationError x) forall a. a -> Sem r a forall (f :: * -> *) a. Applicative f => a -> f a pure (FederationError -> Either FederationError x forall a b. a -> Either a b Left FederationError FederationNotConfigured) Just Endpoint fedEndpoint -> do let ce :: FederatorClientEnv ce = FederatorClientEnv { $sel:ceOriginDomain:FederatorClientEnv :: Domain ceOriginDomain = FederationAPIAccessConfig config.ownDomain, $sel:ceTargetDomain:FederatorClientEnv :: Domain ceTargetDomain = Domain remoteDomain, $sel:ceFederator:FederatorClientEnv :: Endpoint ceFederator = Endpoint fedEndpoint, $sel:ceHttp2Manager:FederatorClientEnv :: Http2Manager ceHttp2Manager = FederationAPIAccessConfig config.http2Manager, $sel:ceOriginRequestId:FederatorClientEnv :: RequestId ceOriginRequestId = FederationAPIAccessConfig config.requestId } IO (Either FederationError x) -> Sem r (Either FederationError x) forall (m :: * -> *) (r :: EffectRow) a. Member (Embed m) r => m a -> Sem r a embed (IO (Either FederationError x) -> Sem r (Either FederationError x)) -> (IO (Either FederatorClientError x) -> IO (Either FederationError x)) -> IO (Either FederatorClientError x) -> Sem r (Either FederationError x) forall b c a. (b -> c) -> (a -> b) -> a -> c . (Either FederatorClientError x -> Either FederationError x) -> IO (Either FederatorClientError x) -> IO (Either FederationError x) 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 x -> Either FederationError x 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 x) -> Sem r (Either FederationError x)) -> IO (Either FederatorClientError x) -> Sem r (Either FederationError x) forall a b. (a -> b) -> a -> b $ FederatorClientEnv -> FederatorClient c x -> IO (Either FederatorClientError x) forall (c :: Component) a. FederatorClientEnv -> FederatorClient c a -> IO (Either FederatorClientError a) runFederatorClient FederatorClientEnv ce FederatorClient c x rpc FederatedActionRunner FederatorClient r -> Sem r Bool -> InterpreterFor (FederationAPIAccess FederatorClient) r forall (fedM :: Component -> * -> *) (r :: EffectRow). Member (Concurrency 'Unsafe) r => FederatedActionRunner fedM r -> Sem r Bool -> InterpreterFor (FederationAPIAccess fedM) r interpretFederationAPIAccessGeneral Domain -> FederatorClient c x -> Sem r (Either FederationError x) FederatedActionRunner FederatorClient r runner (Bool -> Sem r Bool forall a. a -> Sem r a forall (f :: * -> *) a. Applicative f => a -> f a pure Bool isFederationConfigured) Sem (FederationAPIAccess FederatorClient : r) a action interpretFederationAPIAccessGeneral :: forall fedM r. (Member (Concurrency 'Unsafe) r) => FederatedActionRunner fedM r -> (Sem r Bool) -> InterpreterFor (FederationAPIAccess fedM) r interpretFederationAPIAccessGeneral :: forall (fedM :: Component -> * -> *) (r :: EffectRow). Member (Concurrency 'Unsafe) r => FederatedActionRunner fedM r -> Sem r Bool -> InterpreterFor (FederationAPIAccess fedM) r interpretFederationAPIAccessGeneral FederatedActionRunner fedM r runFedM Sem r Bool isFederationConfigured = (forall (rInitial :: EffectRow) x. FederationAPIAccess fedM (Sem rInitial) x -> Sem r x) -> Sem (FederationAPIAccess fedM : r) a -> Sem r a forall (e :: Effect) (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. FederationAPIAccess fedM (Sem rInitial) x -> Sem r x) -> Sem (FederationAPIAccess fedM : r) a -> Sem r a) -> (forall (rInitial :: EffectRow) x. FederationAPIAccess fedM (Sem rInitial) x -> Sem r x) -> Sem (FederationAPIAccess fedM : r) a -> Sem r a forall a b. (a -> b) -> a -> b $ \case RunFederatedEither Remote x remote fedM c a1 rpc -> FederatedActionRunner fedM r -> Remote x -> fedM c a1 -> Sem r (Either FederationError a1) forall {k} (fedM :: k -> * -> *) (r :: EffectRow) a (c :: k) b. FederatedActionRunner fedM r -> Remote a -> fedM c b -> Sem r (Either FederationError b) runFederatedEither Domain -> fedM c x -> Sem r (Either FederationError x) FederatedActionRunner fedM r runFedM Remote x remote fedM c a1 rpc RunFederatedConcurrently f (Remote x) remotes Remote x -> fedM c a1 rpc -> FederatedActionRunner fedM r -> f (Remote x) -> (Remote x -> fedM c a1) -> Sem r [Either (Remote x, FederationError) (Remote a1)] forall {k} (f :: * -> *) (r :: EffectRow) (fedM :: k -> * -> *) a (c :: k) b. (Foldable f, Member (Concurrency 'Unsafe) r) => FederatedActionRunner fedM r -> f (Remote a) -> (Remote a -> fedM c b) -> Sem r [Either (Remote a, FederationError) (Remote b)] runFederatedConcurrently Domain -> fedM c x -> Sem r (Either FederationError x) FederatedActionRunner fedM r runFedM f (Remote x) remotes Remote x -> fedM c a1 rpc RunFederatedBucketed f (Remote x) remotes Remote [x] -> fedM c a1 rpc -> FederatedActionRunner fedM r -> f (Remote x) -> (Remote [x] -> fedM c a1) -> Sem r [Either (Remote [x], FederationError) (Remote a1)] forall {k} (f :: * -> *) (r :: EffectRow) (fedM :: k -> * -> *) a (c :: k) b. (Foldable f, Functor f, Member (Concurrency 'Unsafe) r) => FederatedActionRunner fedM r -> f (Remote a) -> (Remote [a] -> fedM c b) -> Sem r [Either (Remote [a], FederationError) (Remote b)] runFederatedBucketed Domain -> fedM c x -> Sem r (Either FederationError x) FederatedActionRunner fedM r runFedM f (Remote x) remotes Remote [x] -> fedM c a1 rpc FederationAPIAccess fedM (Sem rInitial) x IsFederationConfigured -> Sem r x Sem r Bool isFederationConfigured runFederatedEither :: FederatedActionRunner fedM r -> Remote a -> fedM c b -> Sem r (Either FederationError b) runFederatedEither :: forall {k} (fedM :: k -> * -> *) (r :: EffectRow) a (c :: k) b. FederatedActionRunner fedM r -> Remote a -> fedM c b -> Sem r (Either FederationError b) runFederatedEither FederatedActionRunner fedM r runFedM (Remote a -> Domain forall (t :: QTag) a. QualifiedWithTag t a -> Domain tDomain -> Domain remoteDomain) fedM c b rpc = Domain -> fedM c b -> Sem r (Either FederationError b) FederatedActionRunner fedM r runFedM Domain remoteDomain fedM c b rpc runFederatedConcurrently :: ( Foldable f, Member (Concurrency 'Unsafe) r ) => FederatedActionRunner fedM r -> f (Remote a) -> (Remote a -> fedM c b) -> Sem r [Either (Remote a, FederationError) (Remote b)] runFederatedConcurrently :: forall {k} (f :: * -> *) (r :: EffectRow) (fedM :: k -> * -> *) a (c :: k) b. (Foldable f, Member (Concurrency 'Unsafe) r) => FederatedActionRunner fedM r -> f (Remote a) -> (Remote a -> fedM c b) -> Sem r [Either (Remote a, FederationError) (Remote b)] runFederatedConcurrently FederatedActionRunner fedM r runFedM f (Remote a) xs Remote a -> fedM c b rpc = Int -> [Remote a] -> (Remote a -> Sem r (Either (Remote a, FederationError) (Remote b))) -> Sem r [Either (Remote a, FederationError) (Remote b)] forall (r :: EffectRow) (t :: * -> *) a b. (Member (Concurrency 'Unsafe) r, Foldable t) => Int -> t a -> (a -> Sem r b) -> Sem r [b] unsafePooledForConcurrentlyN Int 8 (f (Remote a) -> [Remote a] forall a. f a -> [a] forall (t :: * -> *) a. Foldable t => t a -> [a] toList f (Remote a) xs) ((Remote a -> Sem r (Either (Remote a, FederationError) (Remote b))) -> Sem r [Either (Remote a, FederationError) (Remote b)]) -> (Remote a -> Sem r (Either (Remote a, FederationError) (Remote b))) -> Sem r [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)) -> Sem r (Either FederationError b) -> Sem r (Either (Remote a, FederationError) (Remote b)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> FederatedActionRunner fedM r -> Remote a -> fedM c b -> Sem r (Either FederationError b) forall {k} (fedM :: k -> * -> *) (r :: EffectRow) a (c :: k) b. FederatedActionRunner fedM r -> Remote a -> fedM c b -> Sem r (Either FederationError b) runFederatedEither Domain -> fedM c x -> Sem r (Either FederationError x) FederatedActionRunner fedM r runFedM Remote a r (Remote a -> fedM c b rpc Remote a r) runFederatedBucketed :: ( Foldable f, Functor f, Member (Concurrency 'Unsafe) r ) => FederatedActionRunner fedM r -> f (Remote a) -> (Remote [a] -> fedM c b) -> Sem r [Either (Remote [a], FederationError) (Remote b)] runFederatedBucketed :: forall {k} (f :: * -> *) (r :: EffectRow) (fedM :: k -> * -> *) a (c :: k) b. (Foldable f, Functor f, Member (Concurrency 'Unsafe) r) => FederatedActionRunner fedM r -> f (Remote a) -> (Remote [a] -> fedM c b) -> Sem r [Either (Remote [a], FederationError) (Remote b)] runFederatedBucketed FederatedActionRunner fedM r runFedM f (Remote a) xs Remote [a] -> fedM c b rpc = Int -> [Remote [a]] -> (Remote [a] -> Sem r (Either (Remote [a], FederationError) (Remote b))) -> Sem r [Either (Remote [a], FederationError) (Remote b)] forall (r :: EffectRow) (t :: * -> *) a b. (Member (Concurrency 'Unsafe) r, Foldable t) => Int -> t a -> (a -> Sem r b) -> Sem r [b] unsafePooledForConcurrentlyN 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] -> Sem r (Either (Remote [a], FederationError) (Remote b))) -> Sem r [Either (Remote [a], FederationError) (Remote b)]) -> (Remote [a] -> Sem r (Either (Remote [a], FederationError) (Remote b))) -> Sem r [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)) -> Sem r (Either FederationError b) -> Sem r (Either (Remote [a], FederationError) (Remote b)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> FederatedActionRunner fedM r -> Remote [a] -> fedM c b -> Sem r (Either FederationError b) forall {k} (fedM :: k -> * -> *) (r :: EffectRow) a (c :: k) b. FederatedActionRunner fedM r -> Remote a -> fedM c b -> Sem r (Either FederationError b) runFederatedEither Domain -> fedM c x -> Sem r (Either FederationError x) FederatedActionRunner fedM r runFedM Remote [a] r (Remote [a] -> fedM c b rpc Remote [a] r)