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)